Require Import ZArith String List Zwf Omega.
Open Scope Z_scope.
Open Scope list_scope.
Open Scope string_scope.

Inductive ml : Type :=
   var (x:string) | app (f a : ml) | letrec (x:string)(e1 e2:ml) 
 | num (n:Z) | ml_bool(b:bool) | ml_if (e1 e2 e3 : ml)
 | lam(x:string)(body:ml) | optc (e1 e2 e3 : ml) | some (e1:ml)
 | none.

Inductive value : Type :=
  vnum (n:Z) | vbool (b:bool) | native (f:Z->Z->value)
| closure (x:string)(body:ml)(env:list (string*value))
| fclosure (f x:string)(body:ml)(env:list (string*value))
| vnone | vsome (v:value).


Definition is_fclosure (x:value) : bool :=
  match x with fclosure _ _ _ _ => true | _ => false end.

Inductive ml_ds : list (string*value) -> ml -> value -> Prop :=
  dnum : forall r n, ml_ds r (num n) (vnum n)
| dbool : forall r b, ml_ds r (ml_bool b) (vbool b)
| dif_t : forall r e1 e2 e3 v,
   ml_ds r e1 (vbool true) -> ml_ds r e2 v -> ml_ds r (ml_if e1 e2 e3) v
| dif_f : forall r e1 e2 e3 v,
   ml_ds r e1 (vbool false) -> ml_ds r e3 v -> ml_ds r (ml_if e1 e2 e3) v
| dnone : forall r, ml_ds r none vnone
| dsome : forall r e v, ml_ds r e v -> ml_ds r (some e) (vsome v)
| doptc_n : forall r e1 e2 e3 v,
  ml_ds r e1 vnone -> ml_ds r e2 v -> ml_ds r (optc e1 e2 e3) v
| doptc_s : forall r e1 e2 e3 x body r' v' v,
  ml_ds r e1 (vsome v') -> ml_ds r e3 (closure x body r') ->
  ml_ds ((x,v')::r') body v ->  ml_ds r (optc e1 e2 e3) v
| dlam : forall r x body, ml_ds r (lam x body) (closure x body r)
| drec : forall r f x e1 e2 v,
  ml_ds ((f,(fclosure f x e1 r))::r) e2 v -> ml_ds r (letrec f (lam x e1) e2) v
| dvar1 : forall x v l, is_fclosure v = false -> ml_ds ((x,v)::l)(var x) v
| dvar2 : forall f x y body r' l,
             ml_ds ((x,fclosure f y body r')::l) (var x)
             (closure y body ((f, fclosure f y body r')::r'))
| dvar3 : forall x y l v v', x <> y -> ml_ds l (var y) v' ->
   ml_ds ((x,v)::l) (var y) v'
| dapp1 : forall r e1 e2 x body r' v2 v,
  ml_ds r e1 (closure x body r') ->
  ml_ds r e2 v2 -> ml_ds ((x, v2)::r') body v ->
  ml_ds r (app e1 e2) v
| dapp_native : forall r fsym f e1 e2 n1 n2,
  ml_ds r fsym (native f) -> ml_ds r e1 (vnum n1) -> ml_ds r e2 (vnum n2) ->
  ml_ds r (app (app fsym e1) e2) (f n1 n2)
| dapp_native1 : forall r fsym f e1 n1,
  ml_ds r fsym (native f) -> ml_ds r e1 (vnum n1) ->
  ml_ds r (app fsym e1) (closure "x" (app (app (var "f") (num n1)) (var "x"))
                       (("f",native f)::nil)).

Definition native_env :=
  ("plus", native (fun x y => vnum (x+y)))::
  ("lt", native (fun x y => vbool (if Z_lt_le_dec x y then true else false)))::
  ("mult", native (fun x y => vnum(x*y)))::nil.

Fixpoint unsome (t:ml) : ml :=
  match t with
    some a => (unsome a)
  | app a b => app (unsome a) (unsome b)
  | letrec x e1 e2 => letrec x (unsome e1) (unsome e2)
  | ml_if e1 e2 e3 => ml_if (unsome e1) (unsome e2) (unsome e3)
  | lam x e => lam x (unsome e)
  | optc e1 e2 e3 => app (unsome e3) (unsome e1)
  | none => none
  | e => e
  end.

Inductive nosd : ml -> Prop :=
  nosd1 : forall x, nosd (var x)
| nosd2 : forall f a, nosd f -> nosd a -> nosd (app f a)
| nosd3 : forall x e1 e2, nosd e1 -> nosd e2 -> nosd (letrec x e1 e2)
| nosd4 : forall n, nosd (num n)
| nosd5 : forall b, nosd (ml_bool b)
| nosd6 : forall e1 e2 e3, nosd e1 -> nosd e2 -> nosd e3 ->
          nosd (ml_if e1 e2 e3)
| nosd7 : forall x e, nosd e -> nosd (lam x e)
| nosd8 : forall e1 e2 e3, nosd e1 -> nosd e3 -> nosd (optc e1 e2 e3)
| nosd9 : forall e, nosd e -> nosd (some e).

Definition unsome_env (f:value->value) :
   list(string*value)-> list(string*value) :=
  fix ue (l:list(string*value)) : list(string*value) :=
  match l with
    nil => nil
  | (x,v)::tl => (x, f v)::ue tl
  end.

Fixpoint unsome_value (v:value) : value :=
  match v with
    closure x e r => closure x (unsome e) (unsome_env unsome_value r)
  | fclosure f x e r => fclosure f x (unsome e) (unsome_env unsome_value r)
  | vnone => vnone
  | vsome e => unsome_value e
  | e => e
  end.

Definition ant_exclude (v:value) :=
  match v with
    closure _ _ _ => False
  | fclosure _ _ _ _ => False
  | native _ => False
  | vnone => False
  | vsome _ => False
  | _ => True
  end.

Definition immediate_value (v:value) :=
  match v with
    vnum _ => true
  | vbool _ => true
  | _ => false
  end.

Inductive fc_clean : value -> Prop :=
  fc1 : forall x b r, fc_clean_env r -> fc_clean(closure x b r)
| fc2 : forall f x b r, fc_clean_env r -> fc_clean(fclosure f x b r)
| fc3 : forall f, (forall a b, immediate_value (f a b) = true) ->
            fc_clean (native f)
| fc4 : forall n, fc_clean (vnum n)
| fc5 : forall b, fc_clean (vbool b)
| fc6 : fc_clean (vnone)
| fc7 : forall v, fc_clean' v -> fc_clean(vsome v)
with fc_clean' : value -> Prop :=
  fcp1 : forall x b r, fc_clean_env r -> fc_clean'(closure x b r)
| fcp3 : forall f, (forall a b, immediate_value (f a b) = true) ->
            fc_clean' (native f)
| fcp4 : forall n, fc_clean' (vnum n)
| fcp5 : forall b, fc_clean' (vbool b)
| fcp6 : fc_clean' (vnone)
| fcp7 : forall v, fc_clean' v -> fc_clean'(vsome v)
with fc_clean_env : list(string*value) -> Prop :=
  fce1 : fc_clean_env nil
| fce2 : forall x v tl, fc_clean v -> fc_clean_env tl ->
         fc_clean_env ((x,v)::tl).

Inductive no_none : list(string*value) -> Prop :=
  ant1 : no_none nil
| ant2 : forall x v tl, ant_exclude v -> no_none tl ->
    no_none ((x,v)::tl)
| ant3 : forall x f y e r tl,
    no_none r -> no_none tl -> nosd e ->
    no_none ((x,fclosure f y e r)::tl)
| ant4 : forall x y e r tl,
    no_none r -> no_none tl -> nosd e ->
    no_none ((x,closure y e r)::tl)
| ant5 : forall x f tl,
    (forall a b, immediate_value (f a b)=true) ->
   no_none tl -> no_none ((x,native f)::tl)
| ant6 : forall x v tl,
   no_none ((x,v)::tl) -> no_none ((x,vsome v)::tl).
  
Inductive no_none_value : value -> Prop :=
  nnv1 : forall v, ant_exclude v -> no_none_value v
| nnv2 : forall f y e r, no_none r -> nosd e ->
             no_none_value (fclosure f y e r)
| nnv3 : forall y e r, no_none r -> nosd e -> no_none_value (closure y e r)
| nnv4 : forall f, (forall a b, immediate_value (f a b)=true) ->
          no_none_value (native f)
| nnv5 : forall v, no_none_value v -> no_none_value(vsome v).

Lemma immediate_no_none : forall v, immediate_value v = true -> no_none_value v.
intros v; case v; simpl; try (intros; discriminate); intros; 
 constructor; simpl; auto.
Qed.

Lemma no_none_value_no_none :
  forall x v tl, no_none tl -> no_none_value v -> no_none ((x,v)::tl).
intros x v t nn nnv; induction nnv.
apply ant2; solve[auto].
apply ant3; solve[auto].
apply ant4; solve[auto].
apply ant5; solve[auto].
apply ant6; solve[auto].
Qed.

Lemma no_none_none_value : forall x v l, no_none ((x,v)::l) -> no_none_value v.
assert (tmp :forall r, no_none r -> forall x v l, r = ((x,v)::l)->
                     no_none_value v).
induction 1.
intros; discriminate.
intros x' v' l q; injection q; intros; subst x' v'; clear q.
apply nnv1; auto.
intros x' v' l q; injection q; intros; subst x' v'; clear q.
apply nnv2; auto.
intros x' v' l q; injection q; intros; subst x' v'; clear q.
apply nnv3; auto.
intros x' v' l q; injection q; intros; subst x' v'; clear q.
apply nnv4; auto.
intros x' v' l q; injection q; intros; subst x' v'; clear q.
apply nnv5; eauto.
eauto.
Qed.

Lemma no_none_tail :
  forall x v l, no_none ((x,v)::l) -> no_none l.
assert (forall r, no_none r -> forall x v l, r=(x,v)::l-> no_none l).
induction 1; intros x' v' l q; (discriminate || injection q);
  intros; subst x' v' l; eauto.
eauto.
Qed.

Lemma nosd_terminate :
  forall r e v, ml_ds r e v -> no_none r -> nosd e -> no_none_value v.
induction 1; try (intros; constructor; simpl; solve[auto]).
intros nn nsd; assert (tmp : nosd e1 /\ nosd e2 /\ nosd e3)
  by (inversion nsd;auto); destruct tmp as [nsd1 [nsd2 nsd3]]; solve [auto].
intros nn nsd; assert (tmp : nosd e1 /\ nosd e2 /\ nosd e3)
  by (inversion nsd;auto); destruct tmp as [nsd1 [nsd2 nsd3]]; solve [auto].

intros nn nsd; inversion nsd.
intros nn nsd; assert (nsd1 : nosd e) by (inversion nsd; auto);
apply nnv5; solve[auto].
intros nn nsd; assert (tmp : nosd e1 /\ nosd e3) by (inversion nsd; auto);
destruct tmp as [nsd1 nsd3]; assert (tmp : no_none_value vnone) by auto;
inversion tmp; assert (tmp1 : ant_exclude vnone) by auto; case tmp1.
intros nn nsd; assert (tmp : nosd e1 /\ nosd e3) by (inversion nsd; auto);
destruct tmp as [nsd1 nsd3].
assert (tmp : no_none_value (closure x body r')) by auto; inversion_clear tmp.
assert (tmp' : ant_exclude (closure x body r')) by assumption; inversion tmp'.
apply IHml_ds3.
assert (tmp : no_none_value (vsome v')) by auto; inversion_clear tmp.
assert (tmp' : ant_exclude (vsome v')) by assumption; case tmp'.
apply no_none_value_no_none; auto.
assumption.

intros nn nsd; assert (tmp : nosd body) by (inversion nsd; auto);
apply nnv3; auto.

intros nn nsd; assert (tmp : nosd e1 /\ nosd e2);[
 inversion nsd; assert (tmp : nosd (lam x e1)) by auto; inversion tmp;
 auto | destruct tmp as [nsd1 nsd2]]; apply IHml_ds; auto;
apply ant3; auto.

intros nn _; apply no_none_none_value in nn; auto.
intros nn _; apply no_none_none_value in nn; inversion nn;
 [assert (tm:ant_exclude(fclosure f y body r')) by auto; case tm|
  apply nnv3;auto]; apply no_none_value_no_none; auto.
intros nn; apply no_none_tail in nn; auto.

intros nn nsd; assert (tmp : nosd e1 /\ nosd e2) by (inversion_clear nsd; auto);
 destruct tmp as [nsd1 nsd2]; 
 assert (tmp : no_none_value (closure x body r')) by auto; inversion_clear tmp;
 [assert (tmp :ant_exclude (closure x body r')) by auto; case tmp |
  apply IHml_ds3; auto; apply no_none_value_no_none; auto].
intros nn nsd; assert (nsd1 : nosd (app fsym e1)) by (inversion nsd; auto);
assert (tmp : no_none_value (native f)) by (inversion_clear nsd1;  auto);
inversion_clear tmp;[assert (tmp:ant_exclude (native f)) by auto; case tmp|
apply immediate_no_none; auto].

intros nn nsd; assert (nsd1 : nosd fsym) by (inversion nsd; auto).
assert (tmp : no_none_value (native f)) by auto;
inversion_clear tmp;[assert (tmp:ant_exclude (native f)) by auto; case tmp|
apply nnv3;[apply ant5; auto ;apply ant1| repeat constructor]].
Qed.

Lemma nono : ~no_none_value vnone.
intros H; inversion H; auto.
Qed.

Lemma fc_clean'_imp : forall v, fc_clean' v -> fc_clean v.
induction 1; try constructor; auto.
Qed.

Lemma fc_clean_value :
  forall r e v, ml_ds r e v -> fc_clean_env r -> fc_clean' v.
induction 1; try (constructor; solve[auto]); auto.
intros fcr; assert (IHml_ds2' := fcr);
apply IHml_ds2 in IHml_ds2'; simpl in IHml_ds2'.
apply IHml_ds3; simpl; simpl in IHml_ds1.
constructor.
apply fc_clean'_imp; apply IHml_ds1 in fcr; inversion fcr; auto.
inversion IHml_ds2'; auto.
intros fcr; apply IHml_ds; constructor; auto; constructor; auto.
intros fcr; inversion fcr; assert (H':fc_clean v) by auto;generalize H;
inversion H'; try (simpl; intros; discriminate); constructor; auto.
intros fcr; inversion fcr; assert (t:fc_clean (fclosure f y body r')) by auto;
inversion t; constructor; auto; constructor; auto.
intros fcr; inversion fcr; auto.
intros fcr;assert (fcr':=fcr);apply IHml_ds2 in fcr; apply IHml_ds1 in fcr'; 
 inversion fcr';apply IHml_ds3; constructor; auto;apply fc_clean'_imp; auto.
intros fcr; apply IHml_ds1 in fcr; inversion fcr; 
 assert (t:forall a b, immediate_value (f a b)=true) by auto;
 generalize (t n1 n2);clear t; case (f n1 n2); simpl; try(intros;discriminate);
constructor.
intros fcr; constructor; auto; constructor; constructor; 
apply IHml_ds1 in  fcr; inversion fcr; auto.
Qed.

Lemma fc_clean_is_fclosure : forall v, 
   fc_clean' v -> is_fclosure(unsome_value v) = false.
induction v; simpl; auto.
intro H; inversion H.
intros fc; inversion fc; auto.
Qed.

Lemma unsome_complete :
  forall r e v, ml_ds r e v -> no_none r -> fc_clean_env r ->
      nosd e -> ml_ds (unsome_env unsome_value r) (unsome e) (unsome_value v).
induction 1.
simpl; intros; apply dnum.
simpl; intros; apply dbool.

simpl; intros ant fc nsd;
assert (tmp : nosd e1 /\ nosd e2 /\ nosd e3) by (inversion nsd; auto);
destruct tmp as [nsd1 [nsd2 nsd3]]; apply dif_t; auto.

simpl; intros ant fc nsd;
assert (tmp : nosd e1 /\ nosd e2 /\ nosd e3) by (inversion nsd; auto);
destruct tmp as [nsd1 [nsd2 nsd3]]; apply dif_f; auto.

simpl; intros ant fc nsd; apply dnone.
simpl; intros ant fc nsd;
assert (tmp : nosd e) by (inversion nsd; auto); solve[auto].

simpl; intros ant fc nsd;
assert (tmp: nosd e1 /\ nosd e3) by (inversion nsd; auto);
destruct tmp as [nsd1 nsd3]; case nono;
apply (nosd_terminate  r e1 vnone H ant nsd1).

simpl; intros ant fc nsd;
assert (tmp: nosd e1 /\ nosd e3) by (inversion nsd; auto);
destruct tmp as [nsd1 nsd3].
apply dapp1 with (x:=x)(body:=(unsome body))
  (r':=unsome_env unsome_value r')(v2:=unsome_value v').
apply IHml_ds2; auto.
apply IHml_ds1; auto.
 assert (tmp': nosd body /\ no_none r') by
 (assert (tmp: no_none_value (closure x body r')) 
  by (apply nosd_terminate with (1:=H0); auto); 
  inversion_clear tmp;
    [assert (tmp':ant_exclude(closure x body r')) by auto; case tmp' | auto]);
 destruct tmp' as [nsdb nnr'].
apply IHml_ds3; auto.
assert (tmp : no_none_value v') by 
 (assert (tmp : no_none_value (vsome v')) 
  by (apply nosd_terminate with (1:=H); auto);
  inversion_clear tmp;
   [assert (tmp: ant_exclude (vsome v')) by auto ; case tmp|auto]);
 apply no_none_value_no_none; auto; apply nnv5;
 apply nosd_terminate with (1:=H); auto.
simpl.
assert (H' : fc_clean' (closure x body r')) 
 by (apply fc_clean_value in H0; auto); inversion H'.
constructor; auto.
apply fc_clean'_imp; apply fc_clean_value in H; auto; inversion H; auto.
intros ant fc nsd; assert (nsdb : nosd body) by (inversion nsd; auto);
 simpl; apply dlam.

simpl; intros ant fc nsd; assert (tmp : nosd e1 /\ nosd e2) by
 (inversion nsd; assert (tmp : nosd (lam x e1)) by auto; inversion tmp; auto);
 destruct tmp as [nsd1 nsd2];
apply drec; apply IHml_ds; auto; try(apply ant3; solve[auto]); constructor;
  auto;  constructor auto.

intros ant fc _; simpl; apply dvar1; apply fc_clean_is_fclosure;
inversion fc; assert (H':fc_clean v) by auto;inversion H';
try (constructor; solve[auto]); subst v0; subst v; discriminate H.

intros ant fc nsd; simpl; solve [constructor].
intros ant fc nsd; simpl; constructor; auto;
apply no_none_tail in ant; inversion fc; apply IHml_ds; auto.
simpl; intros ant fc nsd;
  assert (tmp:nosd e1 /\ nosd e2) by (inversion nsd; auto); 
  destruct tmp as [nsd1 nsd2];
  apply dapp1 with (v2 := unsome_value v2) (r':=unsome_env unsome_value r')
   (x:=x) (body := unsome body).
apply IHml_ds1; auto.
apply IHml_ds2; auto.
assert (tmp: no_none_value (closure x body r'))
 by (eapply nosd_terminate; eauto); 
 inversion_clear tmp;[assert (tmp:ant_exclude (closure x body r')) by auto;
   inversion tmp | ].
assert (nnv : no_none_value v2) by (eapply nosd_terminate; eauto).
assert (fc2 : fc_clean v2)
   by (apply fc_clean'_imp; eapply fc_clean_value; eauto).
assert (fcc : fc_clean' (closure x body r'))
  by (eapply fc_clean_value; eauto); inversion fcc.
apply IHml_ds3; auto; try (apply no_none_value_no_none; auto);
constructor; auto.

simpl; intros ant fc nsd; assert (tmp : nosd fsym /\ nosd e1 /\ nosd e2) by
 (inversion nsd; assert (tmp: nosd(app fsym e1)) by auto; inversion tmp; auto);
 destruct tmp as [nsd1 [nsd2 nsd3]].
replace (unsome_value (f n1 n2)) with (f n1 n2).
replace (native f) with (unsome_value (native f)) by auto.
apply dapp_native with (n1:= n1) (n2 := n2).
apply IHml_ds1; auto.
apply IHml_ds2; auto.
apply IHml_ds3; auto.
assert (tmp : no_none_value (native f)) 
 by (eapply nosd_terminate; eauto);inversion_clear tmp;
 [assert (tmp: ant_exclude(native f)) by auto; case tmp | 
  cut (immediate_value (f n1 n2)=true);[case(f n1 n2);simpl;
         intros; try discriminate; auto | auto]] .
simpl; intros ant fc nsd; assert (tmp : nosd fsym /\ nosd e1) by
  (inversion nsd; auto); destruct tmp as [nsd1 nsd2].
apply dapp_native1.
replace (native f) with (unsome_value (native f)) by auto; auto.
replace (vnum n1) with (unsome_value (vnum n1)) by auto; auto.
Qed.