Require Import Coq.Arith.Peano_dec.
Require Import Coq.Structures.OrderedType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Ensembles.
Require Import Ascii.
Require Import Coq.ZArith.Znat.
Require Import Coq.Program.Equality.
Require Import Tactics.
Require Import Keys.
Require Import Definitions2.
Require Import Nameless2.
Require Import CorrectnessLemmas.
Require Import Environment.
Require Import Heap.

Module TypeSoundness.

  Import Heap.
  Import Environment.

Lemma subst_rho_natural :
  forall rho, subst_rho rho Ty2_Natural = Ty2_Natural.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e Ty2_Natural) with Ty2_Natural.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_boolean :
  forall rho, subst_rho rho Ty2_Boolean = Ty2_Boolean.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e Ty2_Boolean) with Ty2_Boolean.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_unit :
  forall rho, subst_rho rho Ty2_Unit = Ty2_Unit.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e  Ty2_Unit) with  Ty2_Unit.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_effect :
  forall rho, subst_rho rho Ty2_Effect = Ty2_Effect.
Proof.
  unfold subst_rho. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_in_type k e  Ty2_Effect) with  Ty2_Effect.
    rewrite IHthis2 by assumption.
    reflexivity.
    unfold subst_in_type, open_var, close_var.
    simpl. reflexivity.
Qed.

Lemma subst_rho_rgn_const :
  forall rho c, fold_subst_rgn rho (Rgn2_Const true true c) = (Rgn2_Const true true c).
Proof.
  intros rho c.
  unfold  fold_subst_rgn. unfold R.fold. unfold R.Raw.fold.
  destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_rgn k (Rgn2_Const true false e) (Rgn2_Const true true c)) with (Rgn2_Const true true c).
    rewrite IHthis2 by assumption.
    reflexivity.
    simpl. reflexivity.
Qed.

Lemma subst_rho_index :
  forall rho n, fold_subst_rgn rho (Rgn2_BVar true true n) = (Rgn2_BVar true true n).
Proof.
  intros rho n.
  unfold  fold_subst_rgn. unfold R.fold. unfold R.Raw.fold.
  destruct rho. simpl. induction this.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    replace (subst_rgn k (Rgn2_Const true false e) (Rgn2_BVar true true n)) with (Rgn2_BVar true true n).
    rewrite IHthis2 by assumption.
    reflexivity.
    simpl. reflexivity.
Qed.

Lemma fold_eps_leaf :
forall eff is_bst,
  eff = (fun sa : StaticAction2 =>
           exists sa' : StaticAction2, eff sa' /\
                                       fold_subst_sa {| R.this := R.Raw.Leaf Region; R.is_bst := is_bst |} sa' = sa).
Proof.
 intros eff is_bst.
 apply Extensionality_Ensembles;
      unfold Same_set, Included; split; intros x H.
      * unfold In in *.
        exists x. intuition. unfold fold_subst_sa. destruct x; unfold fold_subst_rgn, subst_rgn; f_equal.
      * unfold In in *.  destruct H as [sa [? ?]].
        assert ( fold_subst_sa {| R.this := R.Raw.Leaf Region; R.is_bst := is_bst |} sa = sa)
          by (unfold fold_subst_sa, fold_subst_rgn, subst_rgn; simpl; destruct sa; subst; f_equal).
        rewrite H1 in H0. now subst.
Qed.

Lemma fold_eps_node :
  forall eff k t e this1 this2
         (Hl : R.Raw.bst this1)
         (Hr : R.Raw.bst this2)
         (is_bst : R.Raw.bst (R.Raw.Node this1 k e this2 t)),
    fold_subst_eps {| R.this := this2; R.is_bst := Hr |}
     (subst_eps k (Rgn2_Const true false e)
        (fold_subst_eps {| R.this := this1; R.is_bst := Hl |} eff)) =
   fold_subst_eps
     {| R.this := R.Raw.Node this1 k e this2 t; R.is_bst := is_bst |} eff.
Proof.
  intros eff k t e this1 this2 Hl Hr is_bst.
  apply Extensionality_Ensembles;
  unfold Same_set, Included; split; intros x H; unfold In in *.
  - unfold fold_subst_eps in *.
    destruct H as [sa [[sa' [[sa'' [H1 H2]] H3]] H4]].
    exists sa''. intuition. subst.
    unfold fold_subst_sa, subst_sa; destruct sa''; f_equal.
  - unfold fold_subst_eps in *.
    destruct H as [sa [H1 H2]].
    exists (subst_sa k (Rgn2_Const true false e) (fold_subst_sa {| R.this := this1; R.is_bst := Hl |} sa)).
    split.
    + unfold subst_eps.
      exists (fold_subst_sa {| R.this := this1; R.is_bst := Hl |} sa).
      intuition. exists sa. intuition.
    + destruct sa; rewrite <- H2; simpl; f_equal.
Qed.

Lemma subst_rho_arrow :
  forall rho tyr1 eff1 tyr2 eff2 tyr3,
    subst_rho rho (Ty2_Arrow tyr1 eff1 tyr2 eff2 tyr3) = Ty2_Arrow (subst_rho rho tyr1) (fold_subst_eps rho eff1) (subst_rho rho tyr2)
                                                                   (fold_subst_eps rho eff2) (subst_rho rho tyr3) .
Proof.
  unfold subst_rho.
  unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this; intros tyr1 eff1 tyr2 eff2 tyr3.
  - f_equal; unfold fold_subst_eps; apply fold_eps_leaf.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    rewrite IHthis1 with (is_bst:=Hl) by assumption. f_equal.
    unfold subst_in_type; simpl.
    rewrite IHthis2 with (is_bst:=Hr) by assumption. f_equal.
    + apply fold_eps_node.
    + apply fold_eps_node.
Qed.

Lemma subst_rho_tyref : forall rho r ty,subst_rho rho (Ty2_Ref r ty) =  Ty2_Ref (fold_subst_rgn rho r) (subst_rho rho ty).
Proof.
  unfold subst_rho, fold_subst_rgn. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this; intros r ty.
  - reflexivity.
  - inversion is_bst; subst.
    rewrite IHthis1 by assumption.
    unfold subst_in_type, open_var, close_var; simpl.
    rewrite IHthis2 by assumption.
    unfold subst_in_type, open_var, close_var. simpl.
    reflexivity.
Qed.

Lemma subst_rho_forallrgn  :
  forall rho eff rty,
    subst_rho rho (Ty2_ForallRgn eff rty) = Ty2_ForallRgn (fold_subst_eps rho eff) (subst_rho rho rty).
Proof.
  unfold subst_rho, fold_subst_eps. unfold R.fold. unfold R.Raw.fold.
  intro rho. destruct rho. simpl. induction this; intros eff rty.
  - f_equal; unfold fold_subst_eps; apply fold_eps_leaf.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    rewrite IHthis1 with (is_bst:=Hl) by assumption. f_equal.
    unfold subst_in_type; simpl.
    rewrite IHthis2 with (is_bst:=Hr) by assumption. f_equal.
    apply fold_eps_node.
Qed.

Lemma subst_rho_fvar_1:
  forall rho x,
    (exists v, fold_subst_rgn rho (Rgn2_FVar true true x) = Rgn2_Const true true v) \/ fold_subst_rgn rho (Rgn2_FVar true true x) = Rgn2_FVar true true x.
Proof.
  intro rho. destruct rho. induction this; intros x.
  - unfold fold_subst_rgn, R.fold, R.Raw.fold; simpl. right. reflexivity.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    replace (fold_subst_rgn {| R.this := R.Raw.Node this1 k e this2 t; R.is_bst := is_bst |} (Rgn2_FVar true true x))
    with
    (fold_subst_rgn {| R.this := this2; R.is_bst := Hr |}
                    (subst_rgn k (Rgn2_Const true false e)
                               (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true x)))
    ) by (unfold fold_subst_rgn, R.fold, R.Raw.fold in *; reflexivity).
    destruct (IHthis1 Hl x).
    + destruct H as [v ?].
      left. exists v.
      rewrite H.
      replace (subst_rgn k (Rgn2_Const true false e) (Rgn2_Const true true v)) with (Rgn2_Const true true v) by (simpl; reflexivity).
      apply subst_rho_rgn_const.
    + rewrite H.
      unfold subst_rgn.
      destruct (RMapP.eq_dec k x); subst; simpl.
      * left. exists e.
        apply subst_rho_rgn_const.
      * apply IHthis2.
Qed.

Module RMapOrdProp := FMapFacts.OrdProperties R.

Lemma subst_rho_fvar_2:
  forall rho x v,
   find_R (Rgn2_FVar true false x) rho = Some v ->
   fold_subst_rgn rho (Rgn2_FVar true true x) = Rgn2_Const true true v.
Proof.
  intro rho.
  destruct rho.
  induction this; intros x v H.
  - unfold fold_subst_rgn, R.fold, R.Raw.fold; simpl.
    inversion H.
  - assert (Hl: R.Raw.bst this1) by (inversion is_bst; auto).
    assert (Hr: R.Raw.bst this2) by (inversion is_bst; auto).
    replace (fold_subst_rgn {| R.this := R.Raw.Node this1 k e this2 t; R.is_bst := is_bst |} (Rgn2_FVar true true x))
    with
    (fold_subst_rgn {| R.this := this2; R.is_bst := Hr |}
                    (subst_rgn k (Rgn2_Const true false e)
                               (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true x)))
    ) by (unfold fold_subst_rgn, R.fold, R.Raw.fold in *; reflexivity).
    apply  RMapP.find_mapsto_iff in H.

    inversion H; subst.
    + (* x = k *)
      apply RMapP.find_mapsto_iff in H.

      unfold R.find, R.Raw.find in H. simpl in H.
      destruct (AsciiVars.compare k k).
      * unfold AsciiVars.lt in l. omega.
      *  unfold AsciiVars.eq in e0.
         apply R.Raw.InRoot with (l:= R.Raw.empty nat) (r:=R.Raw.empty nat) (e:=e) (h:=t) in e0.
         inversion e0; subst.
         {  admit. }
         {  inversion H1. }
         {  inversion H1. }
      *  unfold AsciiVars.lt in l. omega.

      (*replace (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true k) )
      with (Rgn2_FVar true true k) by admit.
      simpl. destruct (RMapP.eq_dec k k).
      * rewrite subst_rho_rgn_const. reflexivity.
      * contradict n. reflexivity. *)
    + apply R.Raw.Proofs.find_1 in H1; auto.
      apply IHthis1 with (is_bst := Hl) in H1. rewrite H1. simpl.
      rewrite subst_rho_rgn_const. reflexivity.
    + apply R.Raw.Proofs.find_1 in H1; auto.
      assert (R.Raw.In x this2) by (apply R.Raw.Proofs.find_iff in H1; [ eapply R.Raw.Proofs.MapsTo_In; eassumption | assumption]).
      apply IHthis2 with (is_bst := Hr) in H1.

      (* apply R.Raw.InRight with (l:= R.Raw.empty nat) (r:=this2) (h:=t) (e':=e) (y:=k) in H0.
      inversion H0; subst.
      {  admit. }
      { inversion H3. }
      { admit. } *)

      assert (Hthis1 : (fold_subst_rgn {| R.this := this1; R.is_bst := Hl |} (Rgn2_FVar true true x) =
                        Rgn2_FVar true true x)) by admit.
      rewrite Hthis1. simpl.
      assert (AsciiVars.lt k x) by admit.
      apply AsciiVars.lt_not_eq in H2.
      destruct (RMapP.eq_dec k x); subst; [contradict H0; auto | assumption].
Qed.

Lemma subst_rho_open_close_rgn :
  forall rho n w v' rho' r r0 x,
    lc_type_rgn r0 ->
    find_R w rho = Some v' ->
    fold_subst_rgn rho r = fold_subst_rgn rho' (closing_rgn_in_rgn2 n x r0) ->
    fold_subst_rgn rho' (opening_rgn_in_rgn2 n (Rgn2_Const true true v') (closing_rgn_in_rgn2 n x r0)) =
    fold_subst_rgn rho (opening_rgn_in_rgn2 n (mk_rgn_type w) r).
Proof.
  intros rho n w v' rho' r r0 x Hlc1 HF H.
  unfold rgn2_in_typ in r.
  unfold rgn2_in_typ in r0.
  unfold rgn2_in_exp in w.
  dependent induction r; dependent induction Hlc1; simpl in *.
  - repeat rewrite subst_rho_rgn_const in *. auto.
  - destruct (RMapP.eq_dec r0 x); subst; simpl in *.
    + rewrite subst_rho_index in H. rewrite subst_rho_rgn_const in H. inversion H.
    + auto.
  - auto.
  - destruct (RMapP.eq_dec r x); subst; simpl in *.
    + rewrite subst_rho_index in H.
      destruct (subst_rho_fvar_1 rho n0) as [[v H0] | H0];
      rewrite H0 in H; inversion H.
    + auto.
  - rewrite subst_rho_index in H. rewrite subst_rho_rgn_const in H. inversion H.
  - destruct (RMapP.eq_dec r x); subst; simpl in *.
    + repeat rewrite subst_rho_index in H. inversion H; subst.
      rewrite NPeano.Nat.eqb_refl.
      rewrite subst_rho_rgn_const.
      dependent induction w; simpl.
      * inversion HF; subst.
        rewrite subst_rho_rgn_const.
        reflexivity.
      * inversion HF. symmetry.
        apply subst_rho_fvar_2. now simpl.
    + rewrite subst_rho_index in H.
      destruct (subst_rho_fvar_1 rho' r) as [[v H0] | H0];
      rewrite H0 in H; inversion H.
Qed.

Lemma subst_rho_open_close_sa:
  forall rho n w v' rho' sa sa1 x,
    lc_type_sa sa ->
    find_R w rho = Some v' ->
    fold_subst_sa rho sa1 = fold_subst_sa rho' (closing_rgn_in_sa2 n x sa) ->
    fold_subst_sa rho' (opening_rgn_in_sa2 n (Rgn2_Const true true v') (closing_rgn_in_sa2 n x sa)) =
    fold_subst_sa rho (opening_rgn_in_sa2 n (mk_rgn_type w) sa1).
Proof.
  intros rho n w v' rho' sa sa1 x Hlc HF H.
  unfold fold_subst_sa.
  inversion Hlc; subst; induction sa1;
  unfold fold_subst_sa in H; inversion H; simpl in *;
  erewrite subst_rho_open_close_rgn; eauto.
Qed.

Lemma subst_rho_open_close_eps:
  forall rho n w v' rho' e e1 x,
    lc_type_eps e ->
    find_R w rho = Some v' ->
    fold_subst_eps rho e1 = fold_subst_eps rho' (closing_rgn_in_eps2 n x e) ->
    fold_subst_eps rho' (opening_rgn_in_eps2 n (Rgn2_Const true true v') (closing_rgn_in_eps2 n x e)) =
    fold_subst_eps rho (opening_rgn_in_eps2 n (mk_rgn_type w) e1).
Proof.
  intros rho n w v' rho' e e1 x  Hcl1 HF H.
  apply Extensionality_Ensembles.
  unfold Same_set, Included.
  split. intros; unfold In in *.
  - unfold fold_subst_eps.  unfold fold_subst_eps in H0.
    unfold opening_rgn_in_eps2, closing_rgn_in_eps2. unfold opening_rgn_in_eps2, closing_rgn_in_eps2 in H0.
    destruct H0 as [sa [[sa' [[sa'' [H2 H3]] H4]] H5]].
    subst.
    exists (opening_rgn_in_sa2 n (mk_rgn_type w) sa'').
    split.
    exists sa''. intuition. admit.
    symmetry.
    eapply subst_rho_open_close_sa.
    inversion Hcl1; subst. destruct (H0 sa''). assumption.
    assumption.
    unfold fold_subst_eps in H.
    apply equal_f with sa'' in H.
    assert ((exists sa' : StaticAction2,
         closing_rgn_in_eps2 n x e sa' /\ fold_subst_sa rho' sa' = sa'') -> (exists sa' : StaticAction2, e1 sa' /\ fold_subst_sa rho sa' = sa'')).
    intro. rewrite H. assumption.
Admitted.

Lemma subst_rho_open_close :
  forall rho w v' rho' x tyr0 tyr,
    lc_type tyr0 ->
    find_R w rho = Some v' ->
    subst_rho rho' (close_var x tyr0) = subst_rho rho tyr ->
    subst_rho rho' (open (mk_rgn_type (Rgn2_Const true false v')) (close_var x tyr0)) =
    subst_rho rho (open (mk_rgn_type w) tyr).
Proof.
  unfold open, close_var.
  intros rho w v' rho' x tyr0 tyr Hcl1 HF.
  generalize dependent 0.
  generalize dependent tyr. generalize dependent tyr0.
  induction tyr0; induction tyr; intros n;
  simpl;
  repeat (rewrite subst_rho_natural ||
                  rewrite subst_rho_boolean ||
                  rewrite subst_rho_unit ||
                  rewrite subst_rho_forallrgn ||
                  rewrite subst_rho_effect
         );
  try (solve [intro Z; inversion Z | intro Y; reflexivity | intro X; assumption |
              intros; rewrite subst_rho_tyref in H; inversion H |
              intros; rewrite subst_rho_arrow in H; inversion H ]).
  - intro. symmetry in H. rewrite  subst_rho_tyref in H.
    rewrite  subst_rho_tyref in H. inversion H as [ [HR1 HR2] ].
    repeat rewrite subst_rho_tyref. f_equal.
    + erewrite subst_rho_open_close_rgn; eauto. now inversion Hcl1.
    + erewrite IHtyr0; eauto. now inversion Hcl1.
  - intro. symmetry in H. rewrite  subst_rho_arrow in H.
    rewrite  subst_rho_tyref in H. now inversion H.
  - intro.  rewrite  subst_rho_tyref in H. rewrite  subst_rho_arrow in H. now inversion H.
  - repeat rewrite subst_rho_arrow. intro Z. inversion Z.
    f_equal.
    + rewrite <- IHtyr0_1; auto. now inversion Hcl1.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0_2; auto. now inversion Hcl1.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0_3; auto. now inversion Hcl1.
  - repeat rewrite subst_rho_forallrgn.
    intro Z; inversion Z.
     f_equal.
    + apply subst_rho_open_close_eps; [ now inversion Hcl1 | assumption | now inversion Z].
    + rewrite <- IHtyr0; auto. now inversion Hcl1.
Qed.

Lemma ty_sound_var :
  forall x v stty rho env ctxt t,
  TcEnv (stty, rho, env, ctxt) ->
  find_E x env = Some v -> find_T x ctxt = Some t ->
  TcVal (stty, v, subst_rho rho t).
Proof.
  intros x v stty rho env ctxt t HTcEnv FindEnv FindCtxt. (* Hclosed. *)
  inversion_clear HTcEnv as [? ? ? ? HBst HFwd HBack HTc].
  destruct (HFwd x v FindEnv) as [y FindEnv'].
  rewrite FindEnv' in FindCtxt. inversion FindCtxt; subst.
  eapply HTc; [eexact FindEnv | eexact FindEnv' ]. (*| assumption]. *)
Qed.

Lemma ty_sound_closure:
  forall stty rgns env rho ctxt f x ec ee tyx tyc effc effe,
    TcRho (rho, rgns) ->
    TcEnv (stty, rho, env, ctxt) ->
    TcExp (stty, ctxt, rgns,  Mu f x ec ee, Ty2_Arrow tyx effc tyc effe Ty2_Effect, Empty_Static_Action) ->
    TcVal (stty, Cls (env, rho,  Mu f x ec ee),  subst_rho rho (Ty2_Arrow tyx effc tyc effe Ty2_Effect)).
Proof.
  intros; econstructor; eassumption.
Qed.

Lemma ty_sound_region_closure:
  forall stty rgns env rho ctxt x er tyr effr,
    TcRho (rho, rgns) ->
    TcEnv (stty, rho, env,ctxt) ->
    TcExp (stty, ctxt, rgns, Lambda x er, Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr),  Empty_Static_Action) ->
    TcVal (stty, Cls (env, rho, Lambda x er), subst_rho rho (Ty2_ForallRgn (close_var_eff x effr) (close_var x tyr))).
Proof.
  intros. econstructor; eassumption.
Qed.

Lemma weakening_trans :
   forall stty stty' stty'',
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty = Some t -> ST.find (elt:=tau) l stty' = Some t) ->
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty' = Some t -> ST.find (elt:=tau) l stty'' = Some t) ->
     (forall (l : ST.key) (t : tau),
        ST.find (elt:=tau) l stty = Some t -> ST.find (elt:=tau) l stty'' = Some t).
Proof.
  intros stty stty' stty'' Weak Weak'.
  intros l t ?. apply Weak'. now apply Weak.
Qed.

Lemma bound_var_is_fresh :
  forall rho rgns x,
    TcRho (rho, rgns) -> not_set_elem rgns x -> ~ R.In (elt:=Region) x rho.
Proof.
  intros rho rgns x H1 H2.
  inversion H1; subst.
  unfold not_set_elem in H2. unfold Ensembles.Complement in H2.
  unfold not. intro.
  apply RMapP.in_find_iff in H.
  apply H2. (* double negation *)
  eapply H3; eassumption.
Qed.

Lemma ty_sound:
  forall e env rho hp hp' v dynamic_eff,
    (hp, env, rho, e) ⇓ (hp', v, dynamic_eff) ->
    forall stty ctxt rgns t static_eff,
      TcHeap (hp, stty) ->
      TcRho (rho, rgns) ->
      TcEnv (stty, rho, env, ctxt) ->
      TcExp (stty, ctxt, rgns, e, t, static_eff) ->
      exists stty',
        (forall l t', ST.find l stty = Some t' -> ST.find l stty' = Some t')
         /\ TcHeap (hp', stty')
         /\ TcVal (stty', v, subst_rho rho t).
Proof.
  intros e env rho hp hp'  v dynamic_eff D.
  dynamic_cases (dependent induction D) Case;
  intros stty ctxt rgns t static_eff Hhp Hrho Henv Hexp;
  inversion Hexp; subst.
  Case "cnt n".
    exists stty; (split; [| split]; auto). rewrite subst_rho_natural.
    econstructor; eassumption.
  Case "bool b".
    exists stty;  (split; [| split]; auto). rewrite subst_rho_boolean.
    econstructor; eassumption.
  Case "var x".
    exists stty; (split; [| split]; auto).
    eapply ty_sound_var; eassumption.
  Case "mu_abs".
    exists stty; (split; [| split]; auto).
    eapply ty_sound_closure; try (solve [eassumption]).
  Case "rgn_abs".
    exists stty;  (split; [| split]; auto).
    eapply ty_sound_region_closure; try (solve [eassumption]).
  Case "mu_app".
    edestruct IHD1 as [sttym [Weak1 [TcHeap1 TcVal_mu]]]; eauto.
    edestruct IHD2 as [sttya [Weaka [TcHeapa TcVal_arg]]]; eauto.
    eapply ext_stores__env; eauto. eapply ext_stores__exp. eassumption. eassumption.
    inversion TcVal_mu as [ | | | ? ? ? ? ? ? ?   TcRho_rho' TcEnv_env' TcExp_abs | | ] ; subst.
    inversion TcExp_abs as [ | |  | ? ? ? ? ? ? ? ? ? ? ? ? TcExp_ec TcExp_ee | |  | | | | | | | | | | | | | | | | | | ]; subst.
    rewrite <- H5 in TcVal_mu.
    do 2 rewrite subst_rho_arrow in H5. inversion H5.
    assert (SubstEq1: subst_rho rho' tyx = subst_rho rho tya) by assumption.
    assert (SubstEq2: subst_rho rho' tyc = subst_rho rho t) by assumption.
    rewrite <- SubstEq1 in TcVal_arg.
    unfold update_rec_E, update_rec_T in *.
    edestruct IHD3 as [sttyb [Weakb [TcHeapb TcVal_res]]]; eauto.
    apply update_env. apply update_env. eapply ext_stores__env; eauto.
    eapply ext_stores__val; eauto. eassumption.
    eapply ext_stores__exp; eauto.
    exists sttyb; intuition.
  Case "rgn_app".
    edestruct IHD1 as [sttyl [Weak1 [TcHeap1 TcVal_lam]]]; eauto.
    inversion TcVal_lam as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_lam | | ]; subst.
    inversion TcExp_lam as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
    edestruct IHD2 as [sttyr [Weak2 [TcHeap2 TcVal_res]]]; eauto using update_env, ext_stores__env, ext_stores__exp.
    apply update_rho. assumption. assumption. eapply extended_rho; eauto.
    exists sttyr; intuition.
    rewrite subst_rho_forallrgn in H6.
    rewrite subst_rho_forallrgn in H6.
    inversion H6.
    unfold update_R in TcVal_res.
    simpl in TcVal_res. rewrite subst_add_comm in TcVal_res.
    SCase "abstraction body is well typed".
    unfold subst_in_type in TcVal_res.
    rewrite SUBST_AS_CLOSE_OPEN in TcVal_res; auto.
    erewrite subst_rho_open_close in TcVal_res; eauto.
    SCase "bound variable is free".
    eapply bound_var_is_fresh; eauto.
  Case "eff_app".
    edestruct IHD1 as [sttym [Weak1 [TcHeap1 TcVal_mu]]]; eauto.
    edestruct IHD2 as [sttya [Weaka [TcHeapa TcVal_arg]]]; eauto using ext_stores__env, ext_stores__exp.
    inversion TcVal_mu as  [ | | | ? ? ? ? ? ? ? TcRho_rho' TcEnv_env' TcExp_abs | | ]; subst.
    inversion TcExp_abs as [ | | | | ? ? ? ? ? ? ? ? ? TcExp_eb | | | | | | | |  | | | | | | | | | | |  ]; subst.
    edestruct IHD3 as [sttyb [Weakb [TcHeapb TcVal_res]]]; eauto.
    SCase "Extended Env".
      apply update_env.
      SSCase "TcEnv". apply update_env.
        SSSCase "Extended". eapply ext_stores__env; eauto.
        SSSCase "Extended TcVal". rewrite <- H5 in TcVal_mu.  eapply ext_stores__val; eauto.
      SSCase "TcVal". do 2 rewrite subst_rho_arrow in H5.
          inversion H5.
          assert (SubstEq: subst_rho rho' tyx = subst_rho rho tya) by assumption.
          rewrite <- SubstEq in TcVal_arg.  eassumption.
    eapply ext_stores__exp; eauto.
    exists sttyb. intuition.
    rewrite subst_rho_effect. rewrite subst_rho_effect in TcVal_res.
    assumption.
  Case "cond_true".
    edestruct IHD1 as [sttyb [Weakb [TcHeapvb TcVal_e0]]]; eauto.
    edestruct IHD2 as [stty1 [Weak1 [TcHeapv1 TcVal_e1]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists stty1. intuition.
  Case "cond_false".
    edestruct IHD1 as [sttyb [Weakb [TcHeapvb TcVal_e0]]]; eauto.
    edestruct IHD2 as [stty2 [Weak2 [TcHeapv2 TcVal_e2]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists stty2. intuition.
  Case "new_ref e".
    destruct IHD with (stty := stty)
                      (ctxt := ctxt)
                      (rgns := rgns)
                      (t := t0)
                      (static_eff := veff)
      as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto.
    exists (update_ST ((r, l), subst_rho rho t0) sttyv); split; [ | split].
    SCase "Extended stores".
      intros k' t' STfind. destruct k' as [r' l'].
      destruct (eq_nat_dec r r'); destruct (eq_nat_dec l l'); subst.
      SSCase "New address must be fresh, prove by contradiction".
        apply Weakv in STfind.
        inversion_clear TcHeapv as [? ? ?  STfind_Hfind ?].
        destruct (STfind_Hfind (r', l') t' STfind) as [x F].
        assert (C : None = Some x) by (rewrite <- F; rewrite <- H0; reflexivity).
        discriminate.
      SSCase "Existing addresses are well-typed 1".
        apply ST_diff_key_2; [ simpl; intuition; apply n; congruence | now apply Weakv in STfind ].
      SSCase "Existing addresses are well-typed 2".
        apply ST_diff_key_2; [ simpl; intuition; apply n; congruence | now apply Weakv in STfind ].
      SSCase "Existing addresses are well-typed 3".
        apply ST_diff_key_2; [simpl; intuition; apply n; congruence | now apply Weakv ].
    SCase "Heap typeness".
      apply update_heap_fresh; eauto.
      remember (find_ST (r, l) sttyv) as to; symmetry in Heqto.
      destruct to as [ t | ].
      SSCase "New address must be fresh, prove by contradiction".
        inversion_clear TcHeapv as [? ? ? STfind_Hfind ?].
        destruct (STfind_Hfind (r, l) t Heqto) as [? ex].
        rewrite H0 in ex. discriminate.
      SSCase "Heap typeness is preserved".
         reflexivity.
    SCase "Loc is well-typed".
       simpl in H; inversion H; subst.
       rewrite subst_rho_tyref. unfold mk_rgn_type. rewrite subst_rho_rgn_const.
       econstructor. apply ST_same_key_1.
  Case "get_ref e".
    destruct IHD with (hp'0 := hp')
                      (v := Loc (Rgn2_Const true false s) l)
                      (stty := stty)
                      (rgns := rgns)
                      (ctxt := ctxt)
                      (t := Ty2_Ref (mk_rgn_type ((Rgn2_Const true false s))) t)
                      (static_eff := aeff)
                      (dynamic_eff := aacts)
    as [sttyv [Weakv [TcHeapv TcVal_v]]]; eauto.
    exists sttyv. split; [ | split].
    SCase "HeapTyping extends".
      apply Weakv.
    SCase "Heap is well typed".
      apply TcHeapv.
    SCase "Value is well-typed".
      inversion_clear TcHeapv as [? ? ? ? HeapTcVal]. eapply HeapTcVal; eauto.
      inversion TcVal_v; subst; simpl in H; inversion H; subst.
      rewrite subst_rho_tyref in H7. inversion H7. subst.
      assumption.
  Case "set_ref e1 e2".
    destruct IHD1 with (hp' := heap')
                       (v := Loc (Rgn2_Const true false s) l)
                       (stty := stty)
                       (ctxt := ctxt)
                       (rgns := rgns)
                       (t := Ty2_Ref (mk_rgn_type ((Rgn2_Const true false s))) t0)
                       (static_eff := aeff)
                       (dynamic_eff := aacts)
       as [sttya [Weaka [TcHeapa TcVal_a]]]; eauto.
    destruct IHD2 with (stty := sttya)
                       (ctxt := ctxt)
                       (rgns := rgns)
                       (t := t0)
                       (static_eff := veff)
      as [sttyv [Weakv [TcHeapv TcVal_v]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyv. split; [ | split].
    SCase "HeapTyping extends".
      eapply weakening_trans; eauto.
    SCase "New heap is well typed".
      apply update_heap_exists with (t:= subst_rho rho t0).
      { assumption. }
      { apply Weakv. inversion TcVal_a; subst.
        simpl in H; inversion H; subst.
        rewrite subst_rho_tyref in H4. inversion H4. subst.
        assumption. }
      { assumption. }
    SCase "Result value is well-typed".
      rewrite subst_rho_unit. constructor.
  Case "nat_plus x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "nat_minus x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "nat_times x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_natural. constructor.
  Case "bool_eq x y".
    edestruct IHD1 as [sttyx [Weakx [TcHeapvx TcVal_x]]]; eauto.
    edestruct IHD2 as [sttyy [Weaky [TcHeapvy TcVal_y]]];
      eauto using ext_stores__env, ext_stores__exp.
    exists sttyy. intuition. rewrite subst_rho_boolean. constructor.
  Case "alloc_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "read_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "write_abs".
    exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "read_conc".
    exists stty. intuition.
    assert (hp = hp') by (eapply EmptyTracePreservesHeap_1; eauto; reflexivity); now subst.
    rewrite subst_rho_effect. constructor.
  Case "write_conc".
    exists stty. intuition.
    assert (hp = hp') by (eapply EmptyTracePreservesHeap_1; eauto; reflexivity); now subst.
    rewrite subst_rho_effect. constructor.
  Case "eff_concat". exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "eff_top". exists stty. intuition. rewrite subst_rho_effect. constructor.
  Case "eff_empty". exists stty. intuition. rewrite subst_rho_effect. constructor.
Qed.

End TypeSoundness.


Require Import list_examples.

Definition head_code := Load::Ret::nil.

Inductive head_spec : Spec cfg :=
  head_claim : forall H x l, fun_claim head_spec
  "head" head_code
    1 (fun p => asP H (rep_list (x::l) p))
    1 (fun p => constraint (p = x) :* litP H).

Lemma head_proof : sound stack_step head_spec.
Proof. list_solver. Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_o_c.RPCF_rep_hom.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section id_rep.

Variable P : PCFPO_rep.

Definition id_rep_car c:
(forall t : type_type P,
  (retype_ipo (fun u : type_type P => u) (P c)) t ->
  (P (retype (fun u : type_type P => u) c)) t) :=
fun  t y =>
   match y with ctype _ z =>
     rlift P (@id_retype _ c) _ z end.

Obligation Tactic := idtac.

Program Instance id_rep_pos c:
ipo_mor_struct (a:=retype_ipo (fun u : type_type P => u) (P c))
  (b:=P (retype (fun u : type_type P => u) c)) (@id_rep_car c).
Next Obligation.
Proof.
  intros c t.
  unfold Proper;
  red.
  intros y z H;
  simpl in *.
  induction H.
  simpl.
  apply (rlift P (id_retype (V:=c))).
  auto.
Qed.

Definition id_rep_po c := Build_ipo_mor (id_rep_pos c).

Definition id_rep_c :
(forall c : ITYPE (type_type P),
  (RETYPE_PO (fun u : type_type P => u)) (P c) --->
  P ((RETYPE (fun u : type_type P => u)) c)) :=
      id_rep_po.

Program Instance RMon_id_s :
  gen_RMonad_Hom_struct (P:=P) (Q:=P)
   (G1:=RETYPE (fun u : type_type P => u))
   (G2:=RETYPE_PO (fun u : type_type P => u))
   (NNNT1 (fun u : type_type P => u)) id_rep_c.
Next Obligation.
Proof.
  simpl.
  intros V t y.
  destruct y as [t y];
  simpl.
  rew (rlift_rweta P).
Qed.
Next Obligation.
Proof.
  simpl.
  intros V W f t z.
  destruct z as [t z];
  simpl.
  rew (rlift_rkleisli (M:=P)).
  rew (rkleisli_rlift (M:=P)).
  apply (rkl_eq P).
  simpl.
  auto.
Qed.

Definition RMon_id := Build_gen_RMonad_Hom RMon_id_s.

Lemma id_arrow_dist:
forall u v : type_type P,
  (fun u0 : type_type P => u0) (u ~~> v) =
  (fun u0 : type_type P => u0) u ~~> (fun u0 : type_type P => u0) v.
Proof.
  simpl.
  reflexivity.
Qed.

Program Instance PCFPO_id_struct : PCFPO_rep_Hom_struct
   (P:=P) (R:=P)
   (f:=fun u => u) (fun u => eq_refl) id_arrow_dist RMon_id.
Next Obligation.
Proof.
  simpl.
  intros c y.
  intros.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (CondB (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (
  (arrow_dist_ct4 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
               (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Bool Bool Bool Bool))).
     simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (CondN (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
  (arrow_dist_ct4 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
           (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Bool Nat Nat Nat)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (Pred (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
   (arrow_dist_ct2 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
        (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Nat Nat)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (Zero (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
    (arrow_dist_ct2 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
        (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Nat Bool)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (Succ (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _
    (arrow_dist_ct2 (Uar:=type_arrow (p:=P)) (U'ar:=type_arrow (p:=P))
     (g:=fun u : type_type P => u) id_arrow_dist
      (f:=type_mor P) (f':=type_mor P)
     (fun u : TY => eq_refl) Nat Nat)).
  simpl;
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (ffff (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (tttt (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros t c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (bottom t (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros m c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (nats m (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros r s c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (app r s (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (id_arrow_dist r s)).
  simpl.
  auto.
Qed.
(*
Next Obligation.
Proof.
  simpl.
  intros r s c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (abs r s (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (id_arrow_dist r s)).
  simpl.
  apply f_equal.
  rew (rklkl P).
  apply (rkl_eq P).
  simpl.
  intros t z.
  rew (retakl P).
  destruct z as [t z | ];
  simpl.
  rew (rlift_rweta P).
  auto.
Qed.
*)
Next Obligation.
Proof.
  simpl.
  intros t c y.
  unfold rlift.
  simpl.
  rewrite (UIP_refl _ _ (id_arrow_dist t t)).
  simpl.
  rew (rmod_hom_rmkl  (rec t (PCFPO_rep_struct:=P))).
Qed.
Next Obligation.
Proof.
  simpl.
  intros u v c y.
  unfold rlift.
  rerew  (rmod_hom_rmkl  (abs u v (PCFPO_rep_struct:=P))).
  rewrite (UIP_refl _ _ (id_arrow_dist u v)).
  simpl.
  apply f_equal.
  rew (rklkl P).
  apply (rkl_eq P).
  simpl.
  intros t z.
  rew (retakl P).
  destruct z as [t z | ];
  simpl.
  rew (rlift_rweta P).
  auto.
Qed.

Definition PCFPO_id := Build_PCFPO_rep_Hom PCFPO_id_struct.

End id_rep.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^511 - 481
Base: 22 + 5/23
***)

Definition curve : CurveParameters :=
  {|
    sz := 23%nat;
    base := 22 + 5/23;
    bitwidth := 32;
    s := 2^511;
    c := [(1, 481)];
    carry_chains := Some [seq 0 (pred 23); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


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 O E Eprime A B C Aprime Bprime : Universe, ((wd_ O Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ Aprime O /\ (wd_ Bprime O /\ (wd_ O E /\ (wd_ E Eprime /\ (wd_ A Aprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Aprime /\ (col_ O Eprime Bprime /\ col_ O Eprime C)))))))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Check pattern-unification on evars in apply unification *)

Axiom app : forall tau tau':Type, (tau -> tau') -> tau -> tau'.

Axiom copy : forall tau:Type, tau -> tau -> Prop.
Axiom copyr : forall tau:Type, tau -> tau -> Prop.
Axiom copyf : forall tau:Type, tau -> tau -> Prop.
Axiom eq : forall tau:Type, tau -> tau -> Prop.
Axiom subst : forall tau tau':Type, (tau -> tau') -> tau -> tau' -> Prop.

Axiom copy_atom : forall tau:Type, forall t t':tau, eq tau t t' -> copy tau t t'.
Axiom copy_fun: forall tau tau':Type, forall t t':(tau->tau'),
(forall x:tau, copyr tau x x->copy tau' (t x) (t' x))
->copy (tau->tau') t t'.

Axiom copyr_atom : forall tau:Type, forall t t':tau, copyr tau t t' -> eq tau t t'.
Axiom copyr_fun: forall tau tau':Type, forall t t':(tau->tau'),
copyr (tau->tau') t t'
->(forall x y:tau, copy tau x y->copyr tau' (t x) (t' y)).

Axiom copyf_atom : forall tau:Type, forall t t':tau, copyf tau t t' -> eq tau t t'.
Axiom copyf_fun: forall tau tau':Type, forall t t':(tau->tau'),
copyr (tau->tau') t t'
->(forall x y:tau, forall z1 z2:tau',
(copy tau x y)->
(subst tau tau' t x z1)->
(subst tau tau' t' y z2)->
copyf tau' z1 z2).

Axiom eqappg: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',forall t':tau',
( ((subst tau tau' t q t') /\ (eq tau' t' r))
->eq tau' (app tau tau' t q) r).

Axiom eqappd: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',
forall t':tau', ((subst tau tau' t q t') /\ (eq tau' r t'))
->eq tau' r (app tau tau' t q).

Axiom substcopy: forall tau tau':Type, forall t:tau->tau', forall q:tau, forall r:tau',
(forall x:tau, (copyf tau x q) -> (copy tau' (t x) r))
->subst tau tau' t q r.

Ltac EtaLong := (apply copy_fun;intros;EtaLong)|| apply copy_atom.
Ltac Subst := apply substcopy;intros;EtaLong.
Ltac Rigid_aux := fun A => apply A|| Rigid_aux (copyr_fun _ _ _ _ A).
Ltac Rigid := fun A => apply copyr_atom; Rigid_aux A.

Theorem church0: forall i:Type, exists X:(i->i)->i->i,
copy ((i->i)->i->i) (fun f:i->i => fun x:i=>f (X f x)) (fun f:i->i=>fun x:i=>app i i (X f) (f x)).
intros.
esplit.
EtaLong.
eapply eqappd;split.
Subst.
apply copyf_atom.
Show Existentials.
apply H1.


Declare ML Module "coq-paramcoq.plugin".

Ltac destruct_reflexivity :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail
  end.

Ltac destruct_construct x :=
    (destruct x; [ constructor 1 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail)
 || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail).

Ltac unfold_cofix := intros; match goal with
 [ |- _ = ?folded ] =>
    let x := fresh "x" in
    let typ := type of folded in
    (match folded with _ _ => pattern folded | _ => pattern folded at 2 end);
    match goal with [ |- ?P ?x ] =>
    refine (let rebuild : typ -> typ := _ in
            let path : rebuild folded = folded := _ in
            eq_rect _ P _ folded path) end;
    [ intro x ; destruct_construct x; fail
    | destruct folded; reflexivity
    | reflexivity]; fail
end.

Ltac destruct_with_nat_arg_pattern x :=
  pattern x;
  match type of x with
   | ?I 0 => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun p => _ p
     | S n => fun _  => unit end q) := _ in gen 0 x)
   | ?I (S ?n) => refine (let gen : forall m (q : I m),
     (match m return I m -> Type with
         0 => fun _  => unit
     | S n => fun p => _ p end q) := _ in gen (S n) x)
  end; intros m q; destruct q.

Ltac destruct_reflexivity_with_nat_arg_pattern :=
  intros ; repeat match goal with
    | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail
  end.

Global Parametricity Tactic := ((destruct_reflexivity; fail)
                            || (unfold_cofix; fail)
                            || (destruct_reflexivity_with_nat_arg_pattern; fail)
                            ||  auto).

Require Import ProofIrrelevance. (* for opaque terms *)

Set Allow StrictProp.  (* TODO: use SProp instead of ProofIrrelevance *)

Parametricity Module Logic.
Parametricity Module Datatypes.
Parametricity Module Specif.

Parametricity Module Decimal.
Parametricity Module Hexadecimal.
Parametricity Module Number.
Parametricity Module Nat.

Parametricity Module Peano.

Parametricity Module Wf.
Parametricity Module Tactics.

Export Logic_R Datatypes_R Specif_R Nat_R Peano_R Wf_R Tactics_R.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export prog.
Require Export cvterm.
Require Export per_props2.

Lemma nuprl_mkc_not {o} :
  forall lib (a b : @CTerm o) eq,
    nuprl lib a b eq
    -> nuprl lib (mkc_not a) (mkc_not b) (fun t t' => forall a a', eq a a' -> False).
Proof.
  introv n.
  apply CL_func.
  unfold per_func.
  exists eq (fun (a a' : CTerm) (e : eq a a') (t t' : @CTerm o) => False); dands.

  - unfold type_family.
    eexists; eexists; eexists; eexists; eexists; eexists;
    dands; auto; spcast; try (fold nuprl).

    unfold mkc_not.
    rw <- @fold_mkc_fun.
    apply computes_to_valc_refl.
    apply iscvalue_mkc_function.

    unfold mkc_not.
    rw <- @fold_mkc_fun.
    apply computes_to_valc_refl.
    apply iscvalue_mkc_function.

    auto.

    introv e.
    allrw @csubst_mk_cv.
    apply CL_approx.
    unfold per_approx.
    eexists; eexists; eexists; eexists; dands; auto; spcast;
    try (rw @mkc_void_eq_mkc_false; rw @mkc_false_eq);
    try (apply @computes_to_valc_refl; apply @iscvalue_mkc_approx).
    introv; split; intro k; repnd; sp; spcast.
    apply not_axiom_approxc_bot in k; sp.

  - sp.
Qed.

Lemma fold_less {o} :
  forall a b c d : @NTerm o,
    oterm (NCan (NCompOp CompOpLess)) [nobnd a, nobnd b, nobnd c, nobnd d]
    = mk_less a b c d.
Proof. sp. Qed.

Lemma mkc_less_than_comp1 {o} :
  forall lib (a b : @CTerm o) n m,
    computes_to_valc lib a (mkc_integer n)
    -> computes_to_valc lib b (mkc_integer m)
    -> (n < m)%Z
    -> computes_to_valc lib (mkc_less_than a b) mkc_true.
Proof.
  introv comp1 comp2 h.
  rw @mkc_less_than_eq.
  destruct_cterms.
  allunfold @computes_to_valc; allsimpl.
  allunfold @computes_to_value; repnd; dands; auto.
  pose proof (reduce_to_prinargs_comp
                lib CompOpLess
                x0 x
                [nobnd mk_true, nobnd mk_false]
                (mk_integer n)
                (mk_integer m)) as r.
  repeat (autodimp r hyp).
  { unfold computes_to_value; dands; auto. }
  { unfold iswfpk; eauto 3 with slow. }
  allrw @fold_nobnd.
  allrw @fold_less.
  eapply reduces_to_trans; eauto.
  apply reduces_to_if_step.
  csunf; simpl.
  dcwf q; allsimpl.
  unfold compute_step_comp; simpl.
  boolvar; auto; try omega.
Qed.

Lemma mkc_less_than_comp2 {o} :
  forall lib (a b : @CTerm o) n m,
    computes_to_valc lib a (mkc_integer n)
    -> computes_to_valc lib b (mkc_integer m)
    -> (m <= n)%Z
    -> computes_to_valc lib (mkc_less_than a b) mkc_false.
Proof.
  introv comp1 comp2 h.
  rw @mkc_less_than_eq.
  destruct_cterms.
  allunfold @computes_to_valc; allsimpl.
  allunfold @computes_to_value; repnd; dands; auto.
  pose proof (reduce_to_prinargs_comp
                lib CompOpLess
                x0 x
                [nobnd mk_true, nobnd mk_false]
                (mk_integer n)
                (mk_integer m)) as r.
  repeat (autodimp r hyp).
  { unfold computes_to_value; dands; auto. }
  { unfold iswfpk; eauto 3 with slow. }
  allrw @fold_nobnd.
  allrw @fold_less.
  eapply reduces_to_trans; eauto.
  apply reduces_to_if_step.
  csunf; simpl.
  dcwf q; allsimpl.
  unfold compute_step_comp; simpl.
  boolvar; auto; try omega.
Qed.

Lemma nuprl_mkc_true {o} :
  forall lib, @nuprl o lib
                     mkc_true
                     mkc_true
                     (fun t t' => t ===>(lib) mkc_axiom # t' ===>(lib) mkc_axiom).
Proof.
  introv.
  apply CL_approx.
  rw @mkc_true_eq.
  unfold per_approx.
  eexists; eexists; eexists; eexists; dands; spcast.
  apply computes_to_valc_refl; apply iscvalue_mkc_approx.
  apply computes_to_valc_refl; apply iscvalue_mkc_approx.
  sp.
  introv; split; sp; spcast.
  apply approxc_refl.
Qed.

Lemma nuprl_computes_left {o} :
  forall lib (t1 t2 t3 : @CTerm o) eq,
    nuprl lib t1 t2 eq
    -> computes_to_valc lib t3 t1
    -> nuprl lib t3 t2 eq.
Proof.
  introv n c.
  apply @nuprl_value_respecting_left with (t1 := t1); auto.
  apply cequivc_sym.
  apply computes_to_valc_implies_cequivc; auto.
Qed.

Lemma nuprl_computes_right {o} :
  forall lib (t1 t2 t3 : @CTerm o) eq,
    nuprl lib t1 t2 eq
    -> computes_to_valc lib t3 t2
    -> nuprl lib t1 t3 eq.
Proof.
  introv n c.
  apply @nuprl_value_respecting_right with (t2 := t2); auto.
  apply cequivc_sym.
  apply computes_to_valc_implies_cequivc; auto.
Qed.

Lemma nuprl_tnat {o} :
  forall lib,
  @nuprl o
    lib
    mkc_tnat
    mkc_tnat
    (fun (t t' : @CTerm o) =>
       { _ : equality_of_int lib t t'
                             &
                             inhabited
                             (fun _ _ : @CTerm o =>
                                forall u v : @CTerm o,
                                  (forall k : Z,
                                     computes_to_valc lib t (mkc_integer k) ->
                                     if (k <? 0)%Z
                                     then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                     else False) -> False)}).
Proof.
  introv.
  rw @mkc_tnat_eq.
  apply CL_set; fold (@nuprl o).
  unfold per_set.
  exists (@equality_of_int o lib).
  exists
    (fun (a a' : @CTerm o)
         (e : equality_of_int lib a a')
         (t t' : @CTerm o) =>
       forall (u v : @CTerm o),
         (forall k,
            computes_to_valc lib a (mkc_integer k)
            -> if (k <? 0)%Z
               then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
               else False)
         -> False);
    dands; auto.

  - unfold type_family.
    eexists; eexists; eexists; eexists; eexists; eexists;
    dands; auto; spcast; try (fold nuprl).

    + apply computes_to_valc_refl; apply iscvalue_mkc_set.

    + apply computes_to_valc_refl; apply iscvalue_mkc_set.

    + apply nuprl_int.

    + introv e.
      allrw @mkcv_le_substc.
      allrw @mkcv_zero_substc.
      allrw @mkc_var_substc.
      allrw @mkc_le_eq.
      unfold equality_of_int in e; exrepnd; spcast.

      apply CL_func.
      unfold per_func.
      exists (fun t t' : @CTerm o =>
                if (k <? 0)%Z
                then t ===>(lib) mkc_axiom # t' ===>(lib) mkc_axiom
                else False).
      exists (fun (a a' : @CTerm o) (e : if (k <? 0)%Z
                            then a ===>(lib) mkc_axiom # a' ===>(lib) mkc_axiom
                            else False) (t t' : @CTerm o) => False).
      dands; auto.

      * unfold type_family.
        eexists; eexists; eexists; eexists; eexists; eexists;
        dands; auto; spcast; try (fold nuprl).

        unfold mkc_not.
        rw <- @fold_mkc_fun.
        apply computes_to_valc_refl.
        apply iscvalue_mkc_function.

        unfold mkc_not.
        rw <- @fold_mkc_fun.
        apply computes_to_valc_refl.
        apply iscvalue_mkc_function.

        remember ((k <? 0)%Z); symmetry in Heqb; destruct b.

        apply Z.ltb_lt in Heqb.

        pose proof (mkc_less_than_comp1 lib a mkc_zero k 0) as h1; repeat (autodimp h1 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_zero, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        pose proof (mkc_less_than_comp1 lib a' mkc_zero k 0) as h2; repeat (autodimp h2 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_zero, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        apply nuprl_value_respecting_left with (t1 := mkc_true).
        apply nuprl_value_respecting_right with (t2 := mkc_true).
        apply nuprl_mkc_true.
        apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp.
        apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp.

        apply Z.ltb_ge in Heqb.

        pose proof (mkc_less_than_comp2 lib a mkc_zero k 0) as h1; repeat (autodimp h1 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_zero, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        pose proof (mkc_less_than_comp2 lib a' mkc_zero k 0) as h2; repeat (autodimp h2 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_zero, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        apply nuprl_computes_left with (t1 := mkc_false); auto.
        apply nuprl_computes_right with (t2 := mkc_false); auto.
        rw @mkc_false_eq.
        apply CL_approx.
        unfold per_approx.
        eexists; eexists; eexists; eexists; dands; auto; spcast.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        introv; split; intro j; repnd; sp; spcast.
        apply not_axiom_approxc_bot in j; auto.

        introv e; simphyps.
        allrw @csubst_mk_cv.
        rw @mkc_void_eq_mkc_false; rw @mkc_false_eq.
        apply CL_approx.
        unfold per_approx.
        eexists; eexists; eexists; eexists; dands; auto; spcast.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        sp; split; intro j; repnd; sp; spcast.
        apply not_axiom_approxc_bot in j; auto.

      * intros; split; intro j; introv m.

        apply j with (u := a0) (v := a'0); auto.
        introv c.
        pose proof (computes_to_valc_eq lib a (mkc_integer k) (mkc_integer k0)) as e;
          repeat (autodimp e hyp).
        inversion e; subst; GC; sp.

        pose proof (m k) as l; autodimp l hyp.
        apply j in l; sp.

  - introv.
    split; intro k; exrepnd.
    exists v; sp.
    exists e; sp.
Qed.

Lemma tnat_type {o} : forall lib, @type o lib mkc_tnat.
Proof.
  introv.
  unfold type, tequality.
  pose proof @nuprl_tnat as h.
  exists
    (fun (t t' : @CTerm o) =>
       { _ : equality_of_int lib t t'
                             &
                             inhabited
                             (fun _ _ : @CTerm o =>
                                forall u v : @CTerm o,
                                  (forall k : Z,
                                     computes_to_valc lib t (mkc_integer k) ->
                                     if (k <? 0)%Z
                                     then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                     else False) -> False)}); sp.
Qed.

Lemma computes_to_valc_tuni {o} :
  forall lib (t : @CTerm o) k,
    (0 <= k)%Z
    -> computes_to_valc lib t (mkc_integer k)
    -> computes_to_valc lib (mkc_tuni t) (mkc_uni (Z.to_nat k)).
Proof.
  introv le c.
  destruct_cterms.
  allunfold @computes_to_valc; allsimpl.
  allunfold @computes_to_value; repnd; dands; auto; try (apply isvalue_mk_uni).
  apply reduces_to_trans with (b := mk_tuni (mk_integer k)).
  apply reduces_to_prinarg; auto.
  apply reduces_to_if_step.
  csunf; simpl.
  unfold compute_step_tuni; simpl.
  destruct (Z_le_gt_dec 0 k); auto; omega.
Qed.

Lemma ccomputes_to_valc_tuni {o} :
  forall lib (t : @CTerm o) k,
    (0 <= k)%Z
    -> t ===>(lib) (mkc_integer k)
    -> (mkc_tuni t) ===>(lib) (mkc_uni (Z.to_nat k)).
Proof.
  introv le c.
  spcast.
  destruct_cterms.
  allunfold @computes_to_valc; allsimpl.
  allunfold @computes_to_value; repnd; dands; auto; try (apply isvalue_mk_uni).
  apply reduces_to_trans with (b := mk_tuni (mk_integer k)).
  apply reduces_to_prinarg; auto.
  apply reduces_to_if_step.
  csunf; simpl.
  unfold compute_step_tuni; simpl.
  destruct (Z_le_gt_dec 0 k); auto; omega.
Qed.

(*

  We could also have defined this type using 0 < y.
  I used 1 <= y because the proofs will be similar to the ones for tnat.

 *)
Definition mk_tnatp {o} := @mk_set o mk_int nvary (mk_le mk_one (mk_var nvary)).

Lemma isprogram_mk_one {o} :
  @isprogram o mk_one.
Proof.
  repeat constructor; simpl; sp.
Qed.
Hint Immediate isprogram_mk_one.

Lemma isprog_mk_one {o} :
  @isprog o mk_one.
Proof.
  rw @isprog_eq.
  apply isprogram_mk_one.
Qed.
Hint Immediate isprog_mk_one.

Lemma isprog_tnatp {o} : @isprog o mk_tnatp.
Proof.
  rw <- @isprog_set_iff.
  dands; eauto 3 with slow.
  rw @isprog_vars_le; dands; eauto 3 with slow.
Qed.

Definition mkc_tnatp {o} : @CTerm o := exist isprog mk_tnatp isprog_tnatp.

Definition mkc_one {o} : @CTerm o := exist isprog mk_one isprog_mk_one.

Definition mkcv_one {o} (vs : list NVar) : @CVTerm o vs := mk_cv vs mkc_one.

Lemma mkc_tnatp_eq {o} :
  @mkc_tnatp o = mkc_set mkc_int nvary (mkcv_le [nvary] (mkcv_one [nvary]) (mkc_var nvary)).
Proof.
  apply cterm_eq; simpl; sp.
Qed.

Lemma mkcv_one_substc {o} :
  forall v (t : @CTerm o),
    substc t v (mkcv_one [v]) = mkc_one.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; sp.
Qed.

Lemma nuprl_tnatp {o} :
  forall lib,
  nuprl
    lib
    mkc_tnatp
    mkc_tnatp
    (fun (t t' : @CTerm o) =>
       { _ : equality_of_int lib t t'
                             &
                             inhabited
                             (fun _ _ : @CTerm o =>
                                forall u v : @CTerm o,
                                  (forall k : Z,
                                     computes_to_valc lib t (mkc_integer k) ->
                                     if (k <? 1)%Z
                                     then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                     else False) -> False)}).
Proof.
  introv.
  rw @mkc_tnatp_eq.
  apply CL_set; fold (@nuprl o).
  unfold per_set.
  exists (@equality_of_int o lib).
  exists
    (fun (a a' : @CTerm o)
         (e : equality_of_int lib a a')
         (t t' : @CTerm o) =>
       forall (u v : @CTerm o),
         (forall k,
            computes_to_valc lib a (mkc_integer k)
            -> if (k <? 1)%Z
               then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
               else False)
         -> False);
    dands; auto.

  - unfold type_family.
    eexists; eexists; eexists; eexists; eexists; eexists;
    dands; auto; spcast; try (fold nuprl).

    + apply computes_to_valc_refl; apply iscvalue_mkc_set.

    + apply computes_to_valc_refl; apply iscvalue_mkc_set.

    + apply nuprl_int.

    + introv e.
      allrw @mkcv_le_substc.
      allrw @mkcv_one_substc.
      allrw @mkc_var_substc.
      allrw @mkc_le_eq.
      unfold equality_of_int in e; exrepnd; spcast.

      apply CL_func.
      unfold per_func.
      exists (fun t t' : @CTerm o =>
                if (k <? 1)%Z
                then t ===>(lib) mkc_axiom # t' ===>(lib) mkc_axiom
                else False).
      exists (fun (a a' : @CTerm o) (e : if (k <? 1)%Z
                            then a ===>(lib) mkc_axiom # a' ===>(lib) mkc_axiom
                            else False) (t t' : @CTerm o) => False).
      dands; auto.

      * unfold type_family.
        eexists; eexists; eexists; eexists; eexists; eexists;
        dands; auto; spcast; try (fold nuprl).

        unfold mkc_not.
        rw <- @fold_mkc_fun.
        apply computes_to_valc_refl.
        apply iscvalue_mkc_function.

        unfold mkc_not.
        rw <- @fold_mkc_fun.
        apply computes_to_valc_refl.
        apply iscvalue_mkc_function.

        remember ((k <? 1)%Z); symmetry in Heqb; destruct b.

        apply Z.ltb_lt in Heqb.

        pose proof (mkc_less_than_comp1 lib a mkc_one k 1) as h1; repeat (autodimp h1 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_one, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        pose proof (mkc_less_than_comp1 lib a' mkc_one k 1) as h2; repeat (autodimp h2 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_one, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        apply nuprl_value_respecting_left with (t1 := mkc_true).
        apply nuprl_value_respecting_right with (t2 := mkc_true).
        apply nuprl_mkc_true.
        apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp.
        apply cequivc_sym; apply computes_to_valc_implies_cequivc; sp.

        apply Z.ltb_ge in Heqb.

        pose proof (mkc_less_than_comp2 lib a mkc_one k 1) as h1; repeat (autodimp h1 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_one, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        pose proof (mkc_less_than_comp2 lib a' mkc_one k 1) as h2; repeat (autodimp h2 hyp); try omega.
        unfold computes_to_valc; simpl; unfold mk_zero, mk_nat; simpl.
        apply computes_to_value_isvalue_refl; apply isvalue_mk_integer.

        apply nuprl_computes_left with (t1 := mkc_false); auto.
        apply nuprl_computes_right with (t2 := mkc_false); auto.
        rw @mkc_false_eq.
        apply CL_approx.
        unfold per_approx.
        eexists; eexists; eexists; eexists; dands; auto; spcast.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        introv; split; intro j; repnd; sp; spcast.
        apply not_axiom_approxc_bot in j; auto.

        introv e; simphyps.
        allrw @csubst_mk_cv.
        rw @mkc_void_eq_mkc_false; rw @mkc_false_eq.
        apply CL_approx.
        unfold per_approx.
        eexists; eexists; eexists; eexists; dands; auto; spcast.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        apply computes_to_valc_refl; apply iscvalue_mkc_approx.
        sp; split; intro j; repnd; sp; spcast.
        apply not_axiom_approxc_bot in j; auto.

      * intros; split; intro j; introv m.

        apply j with (u := a0) (v := a'0); auto.
        introv c.
        pose proof (computes_to_valc_eq lib a (mkc_integer k) (mkc_integer k0)) as e;
          repeat (autodimp e hyp).
        inversion e; subst; GC; sp.

        pose proof (m k) as l; autodimp l hyp.
        apply j in l; sp.

  - introv.
    split; intro k; exrepnd.
    exists v; sp.
    exists e; sp.
Qed.

Lemma tnatp_type {o} : forall lib, @type o lib mkc_tnatp.
Proof.
  introv.
  unfold type, tequality.
  pose proof @nuprl_tnatp as h.
  exists
    (fun (t t' : @CTerm o) =>
       { _ : equality_of_int lib t t'
                             &
                             inhabited
                             (fun _ _ : @CTerm o =>
                                forall u v : @CTerm o,
                                  (forall k : Z,
                                     computes_to_valc lib t (mkc_integer k) ->
                                     if (k <? 1)%Z
                                     then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                     else False) -> False)}); sp.
Qed.

Definition reducek_pair {o} lib (t1 t2 : @NTerm o) (k : Z) (n : nat) :=
    reduces_in_atmost_k_steps lib t1 (mk_integer k) n
  # reduces_in_atmost_k_steps lib t2 (mk_integer k) n.

Definition equality_of_int_p_2 {o} lib (n m : @NTerm o) :=
  {x : Z # nat , reducek_pair lib n m (fst x) (snd x)}.

Definition equality_of_int_p_2_c {o} lib (n m : @CTerm o) :=
  equality_of_int_p_2 lib (get_cterm n) (get_cterm m).

Lemma equality_of_int_imp1 {o} :
  forall lib (n m : @CTerm o),
    equality_of_int lib n m
    <-> equality_of_int_p_2_c lib n m.
Proof.
  introv; split.
  - introv e.
    unfold equality_of_int in e; exrepnd; spcast.
    allunfold @computes_to_valc; allsimpl.
    allunfold @computes_to_value; repnd.
    allunfold @reduces_to; exrepnd.
    allunfold @reduces_in_atmost_k_steps.
    pose proof (no_change_after_value2 lib
                  (get_cterm n) k1 (mk_integer k) e2 e1 (Peano.max k1 k0)) as h1.
    autodimp h1 hyp; try (apply max_prop1).
    pose proof (no_change_after_value2 lib
                (get_cterm m) k0 (mk_integer k) e4 e0 (Peano.max k1 k0)) as h2.
    autodimp h2 hyp; try (apply max_prop2).
    exists ((k,Peano.max k1 k0)); simpl; sp.
    unfold reducek_pair; sp.
  - introv e.
    unfold equality_of_int.
    unfold equality_of_int_p_2_c, equality_of_int_p_2, reducek_pair in e.
    exrepnd; allsimpl.
    exists x0; dands; spcast;
    unfold computes_to_valc, computes_to_value; simpl;
    dands; try (apply isvalue_mk_integer);
    exists x; auto.
Qed.

Lemma compute_step_dec {o} :
  forall lib (t : @NTerm o),
    {u : NTerm $ compute_step lib t = csuccess u}
    [+]
    !{u : NTerm $ compute_step lib t = csuccess u}.
Proof.
  introv.
  remember (compute_step lib t); destruct c.
  - left.
    exists n; sp.
  - right; intro k; exrepnd; inversion k0.
Qed.

(*
Lemma reduces_in_atmost_k_steps_dec {o} :
  forall lib (pc : dec_consts o) k (t1 t2 : @NTerm o),
    reduces_in_atmost_k_steps lib t1 t2 k [+] !(reduces_in_atmost_k_steps lib t1 t2 k).
Proof.
  induction k; introv.

  - rw @reduces_in_atmost_k_steps_0.
    pose proof (deq_nterm pc t1 t2) as h; sp.

  - rw @reduces_in_atmost_k_steps_S.
    pose proof (compute_step_dec lib t1) as h.
    dorn h.

    + exrepnd.
      pose proof (IHk u t2) as j.
      dorn j.

      * left.
        exists u; sp.

      * right.
        intro c; exrepnd.
        rw h0 in c1; inversion c1; subst; sp.

    + right; intro j; exrepnd.
      apply h.
      exists u; sp.
Qed.
*)

Lemma deq_nterm_int {p} :
  forall (t : @NTerm p) z, {t = mk_integer z} + {t <> mk_integer z}.
Proof.
  introv.
  nterm_ind1 t as [v1|f1 ind|o1 lbt1 Hind] Case; intros.

  - Case "vterm".
    right; intro k; inversion k.

  - Case "sterm".
    right; intro k; inversion k.

  - Case "oterm".
    destruct o1; try (complete (right; intro k; inversion k)).
    destruct c; try (complete (right; intro k; inversion k)).
    destruct lbt1; try (complete (right; intro k; inversion k)).
    assert ({z < z0} + {z > z0} + {z = z0})%Z as h by (apply Z_dec).
    destruct h as [ h | h ]; subst.
    destruct h as [ h | h ]; sp; right; sp; inversion H; omega.
    left; sp.
Qed.

Lemma reduces_in_atmost_k_steps_int_dec {o} :
  forall lib k (t : @NTerm o) z,
    reduces_in_atmost_k_steps lib t (mk_integer z) k
    [+]
    !(reduces_in_atmost_k_steps lib t (mk_integer z) k).
Proof.
  induction k; introv.

  - rw @reduces_in_atmost_k_steps_0.
    pose proof (deq_nterm_int t z) as h; sp.

  - rw @reduces_in_atmost_k_steps_S.
    pose proof (compute_step_dec lib t) as h.
    dorn h.

    + exrepnd.
      pose proof (IHk u z) as j.
      dorn j.

      * left.
        exists u; sp.

      * right.
        intro c; exrepnd.
        rw h0 in c1; inversion c1; subst; sp.

    + right; intro j; exrepnd.
      apply h.
      exists u; sp.
Qed.

Lemma reducek_pair_dec {o} :
  forall lib (t1 t2 : @NTerm o) z n,
    reducek_pair lib t1 t2 z n [+] !(reducek_pair lib t1 t2 z n).
Proof.
  introv.
  unfold reducek_pair.
  pose proof (reduces_in_atmost_k_steps_int_dec lib n t1 z) as h1.
  pose proof (reduces_in_atmost_k_steps_int_dec lib n t2 z) as h2.
  dorn h1; dorn h2.
  - left; sp.
  - right; sp.
  - right; sp.
  - right; sp.
Qed.

(*

  The following is an adaptation of:
     http://coq.inria.fr/stdlib/Coq.Logic.ConstructiveEpsilon.html
  This is required to prove equality_of_int_imp_t without using
  the indefinite_description axiom.

*)

Inductive before_witness (P : Z -> nat -> Prop) (k : nat) : Prop :=
  | stop_pos : forall (z n : nat), k = z + n -> P (Z.of_nat z) n -> before_witness P k
  | stop_neg : forall z n, k = z + n -> P (Z.opp (Z.of_nat z)) n -> before_witness P k
  | next : before_witness P (S k) -> before_witness P k.

Fixpoint O_witness
         (P : Z -> nat -> Prop)
         (k : nat) : before_witness P k -> before_witness P 0 :=
  match k return (before_witness P k -> before_witness P 0) with
    | 0 => fun b => b
    | S n => fun b => O_witness P n (next P n b)
  end.

Definition inv_before_witness :
  forall (P : Z -> nat -> Prop) (k : nat),
    before_witness P k
    -> (forall z n : nat, k = z + n -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)
    -> before_witness P (S k) :=
  fun P k b =>
    match b
          in before_witness _ _
          return (forall z n, k = z + n -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)
                 -> before_witness P (S k) with
      | stop_pos _ _ z n e p => fun f => match fst (f z n e) p with end
      | stop_neg _ _ z n e p => fun f => match snd (f z n e) p with end
      | next _ _ b => fun _ => b
    end.

Lemma leS:
  forall n m : nat, n <= S m -> n <= m [+] n = S m.
Proof.
  introv; revert n.
  induction m; simpl; introv e.
  - destruct n; sp.
    destruct n; sp.
    provefalse.
    inversion e as [|x h].
    inversion h.
  - apply leb_correct in e.
    destruct n; allsimpl.
    + left; omega.
    + apply leb_complete in e.
      apply IHm in e; dorn e.
      left; omega.
      right; omega.
Qed.

(* This is the crux of linear_search *)
Lemma P_search :
  forall (P : Z -> nat -> Prop)
         (dec : forall z n, P z n [+] !P z n)
         (k : nat),
    {x : Z # nat & P (fst x) (snd x)}
    [+]
    (forall z n : nat, k = (z + n)%nat -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n).
Proof.
  intros P dec k.

  assert (forall k z,
            {x : Z # nat & P (fst x) (snd x)}
              [+]
              (forall n : nat, n <= k -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)) as hyp1.
  clear k.
  introv.
  induction k.
  pose proof (dec (Z.of_nat z) 0) as h.
  dorn h.
  left; exists (Z.of_nat z,0); simpl; sp.
  pose proof (dec (Z.opp (Z.of_nat z)) 0) as j.
  dorn j.
  left; exists (Z.opp (Z.of_nat z),0); simpl; sp.
  right; introv e.
  assert (n = 0) by omega; subst; simpl; sp.
  dorn IHk.
  left; auto.
  pose proof (dec (Z.of_nat z) (S k)) as h.
  dorn h.
  left; exists (Z.of_nat z,S k); simpl; sp.
  pose proof (dec (Z.opp (Z.of_nat z)) (S k)) as j.
  dorn j.
  left; exists (Z.opp (Z.of_nat z),S k); simpl; sp.
  right; introv e; simpl.
  apply leS in e.
  dorn e.
  apply IHk in e; sp.
  subst; sp.

  assert (forall k n,
            {x : Z # nat & P (fst x) (snd x)}
              [+]
              (forall z : nat, z <= k -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)) as hyp2.
  clear k.
  introv.
  induction k.
  pose proof (dec 0%Z n) as h.
  dorn h.
  left; exists (0%Z,n); simpl; sp.
  right; introv e.
  assert (z = 0) by omega; subst; simpl; sp.
  dorn IHk.
  left; auto.
  pose proof (dec (Z.of_nat (S k)) n) as h.
  dorn h.
  left; exists (Z.of_nat (S k),n); simpl; sp.
  pose proof (dec (Z.opp (Z.of_nat (S k))) n) as j.
  dorn j.
  left; exists (Z.opp (Z.of_nat (S k)),n); simpl; sp.
  right; introv e; simpl.
  apply leS in e.
  dorn e.
  apply IHk in e; sp.
  subst; sp.

  assert ({x : Z # nat & P (fst x) (snd x)}
            [+]
            (forall z n : nat, z <= k -> n <= k -> ~ P (Z.of_nat z) n # ~ P (Z.opp (Z.of_nat z)) n)) as hyp.
  induction k.
  pose proof (dec 0%Z 0) as h.
  dorn h.
  left; exists (0%Z,0); simpl; sp.
  right; introv e1 e2.
  assert (z = 0) by omega; assert (n = 0) by omega; subst; simpl; sp.
  dorn IHk.
  left; auto.
  pose proof (hyp1 (S k) (S k)) as h1.
  dorn h1.
  left; auto.
  pose proof (hyp2 (S k) (S k)) as h2.
  dorn h2.
  left; auto.
  right; introv e1 e2.
  apply leS in e1.
  apply leS in e2.
  dorn e1; dorn e2; subst.
  apply IHk; auto.
  apply h2; auto.
  apply h1; auto.
  apply h1; sp.

  dorn hyp.
  left; auto.
  right.
  introv e; subst.
  apply hyp; omega.
Qed.

Fixpoint linear_search
      (P : Z -> nat -> Prop)
      (dec : forall z n, P z n [+] !P z n)
      (k : nat)
      (b : before_witness P k) : {x : Z # nat | P (fst x) (snd x)} :=
  match P_search P dec k with

    | inl p => sig_of_sigT p
    | inr a => linear_search P dec (S k) (inv_before_witness P k b a)
  end.

Definition constructive_indefinite_ground_description_nat {o}
           lib (t1 t2 : @CTerm o) :
  equality_of_int_p_2_c lib t1 t2
  -> {x : Z # nat | reducek_pair lib (get_cterm t1) (get_cterm t2) (fst x) (snd x)}.
Proof.
  introv pex.
  apply linear_search with (k := 0).
  apply reducek_pair_dec; auto.
  unfold equality_of_int_p_2_c, equality_of_int_p_2 in pex; auto.
  exrepnd; allsimpl.
  apply O_witness with (k := Z.abs_nat x0 + x).
  pose proof (Zabs.Zabs_dec x0) as h.
  dorn h.
  - apply stop_pos with (z := Z.abs_nat x0) (n := x); auto.
    rw h in pex0.
    rw Znat.Zabs2Nat.id_abs; auto.
  - apply stop_neg with (z := Z.abs_nat x0) (n := x); auto.
    rw h in pex0.
    rw Znat.Zabs2Nat.id_abs; auto.
Qed.

(*

   Thanks to constructive_indefinite_ground_description_nat,
   the following proof does not need the indefinite_description axiom

 *)

Definition equality_of_int_t {o} lib (n m : @CTerm o) :=
  {k : Z | n ===>(lib) (mkc_integer k)
         # m ===>(lib) (mkc_integer k)}.

Lemma equality_of_int_imp_t {o} :
  forall lib (n m : @CTerm o),
    equality_of_int lib n m
    -> equality_of_int_t lib n m.
Proof.
  introv e.
  apply equality_of_int_imp1 in e.
  apply constructive_indefinite_ground_description_nat in e; auto.
  exrepnd; allsimpl.
  unfold equality_of_int_t.
  unfold reducek_pair in e0; repnd.
  exists x0; dands; spcast;
  unfold computes_to_valc, computes_to_value; simpl;
  dands; try (apply isvalue_mk_integer);
  exists x; auto.
Qed.

(*
Here is the alternative that uses the indefinite_description axiom.

Axiom indefinite_description :
  forall (A : Type) (P : A -> Prop),
    ex P -> sig P.

Lemma equality_of_int_imp_t :
  forall n m,
    equality_of_int n m
    -> equality_of_int_t n m.
Proof.
  introv e.
  unfold equality_of_int in e.
  unfold equality_of_int_t.
  apply indefinite_description; auto.
Qed.
*)

Definition equality_of_int_tt {o} lib (n m : @CTerm o) :=
  {k : Z & computes_to_valc lib n (mkc_integer k)
         # computes_to_valc lib m (mkc_integer k)}.

Lemma equality_of_int_imp_tt {o} :
  forall lib (n m : @CTerm o),
    equality_of_int lib n m
    -> equality_of_int_tt lib n m.
Proof.
  introv e.
  apply equality_of_int_imp1 in e.
  apply constructive_indefinite_ground_description_nat in e; auto.
  exrepnd; allsimpl.
  unfold equality_of_int_tt.
  unfold reducek_pair in e0; repnd.
  exists x0; dands; spcast;
  unfold computes_to_valc, computes_to_value; simpl;
  dands; try (apply isvalue_mk_integer);
  exists x; auto.
Qed.

Lemma tuni_fun {o} :
  forall lib (v : NVar),
    @type o lib (mkc_function mkc_tnat v (mkcv_tuni [v] (mkc_var v))).
Proof.
  introv.
  unfold type, tequality.
  eexists.
  apply CL_func.
  unfold per_func.

  exists
    (fun t t' : @CTerm o =>
       { _ : equality_of_int lib t t'
                             &
                             inhabited
                             (fun _ _ : @CTerm o =>
                                forall u v : @CTerm o,
                                  (forall k : Z,
                                     computes_to_valc lib t (mkc_integer k) ->
                                     if (k <? 0)%Z
                                     then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                     else False) -> False)}).

  exists (fun (a a' : @CTerm o)
              (e : { _ : equality_of_int lib a a'
                                         &
                                         inhabited
                                         (fun _ _ : @CTerm o =>
                                            forall u v : @CTerm o,
                                              (forall k : Z,
                                                 computes_to_valc lib a (mkc_integer k) ->
                                                 if (k <? 0)%Z
                                                 then u ===>(lib) mkc_axiom # v ===>(lib) mkc_axiom
                                                 else False) -> False)})
              (t t' : @CTerm o) =>
            (exists eqa, close lib (univi lib (Z.to_nat (proj1_sig (equality_of_int_imp_t lib a a' (projT1 e)))))
                               t t' eqa)).

  dands; auto.

  - unfold type_family.
    eexists; eexists; eexists; eexists; eexists; eexists;
    dands; auto; spcast; try (fold nuprl).
    apply computes_to_valc_refl; apply iscvalue_mkc_function.
    apply computes_to_valc_refl; apply iscvalue_mkc_function.
    apply nuprl_tnat.
    introv; simpl in e; exrepnd.
    allrw @mkcv_tuni_substc.
    allrw @mkc_var_substc.
    unfold equality_of_int in v0; exrepnd.
    unfold inhabited in e0; exrepnd.

    pose proof (Z_lt_le_dec k 0) as oo; dorn oo.

    + pose proof (e1 mkc_axiom mkc_axiom) as h.

      autodimp h hyp; tcsp.
      introv c.
      spcast.
      pose proof (computes_to_valc_eq lib a (mkc_integer k) (mkc_integer k0)) as e;
        repeat (autodimp e hyp).
      symmetry in e; inversion e; subst; GC.

      remember ((k <? 0)%Z); symmetry in Heqb; destruct b.
      sp; spcast; apply @computes_to_value_isvalue_refl; simpl; sp.
      apply Z.ltb_ge in Heqb; omega.

    + pose proof (ccomputes_to_valc_tuni lib a k) as c1; repeat (autodimp c1 hyp); try omega.
      pose proof (ccomputes_to_valc_tuni lib a' k) as c2; repeat (autodimp c2 hyp); try omega.
      destruct c1 as [c1].
      destruct c2 as [c2].
      apply nuprl_computes_left with (t1 := mkc_uni (Z.to_nat k)); auto.
      apply nuprl_computes_right with (t2 := mkc_uni (Z.to_nat k)); auto.

      remember (Z.to_nat k) as m.
      apply CL_init.

      exists (S m).
      simpl; left; dands.
      spcast; apply computes_to_value_isvalue_refl; simpl; apply isvalue_mk_uni.
      spcast; apply computes_to_value_isvalue_refl; simpl; apply isvalue_mk_uni.

      introv.

      remember (equality_of_int_imp_t lib a a'
                 (ex_intro
                    (fun k0 : Z =>
                     a ===>(lib) (mkc_integer k0) # a' ===>(lib) (mkc_integer k0))
                    k (v0, v1))); clear Heqe.
      unfold equality_of_int_t in e; exrepnd; simpl.
      spcast.

      pose proof (computes_to_valc_eq lib a (mkc_integer k) (mkc_integer k0)) as e.
      repeat (autodimp e hyp); inversion e; subst; GC.
      sp.

  - introv.
    apply t_iff_refl.
Qed.

Lemma computes_to_valc_implies_hasvaluec {o} :
  forall lib (a b : @CTerm o), computes_to_valc lib a b -> hasvaluec lib a.
Proof.
  introv c.
  unfold computes_to_valc in c.
  unfold hasvaluec, hasvalue.
  exists (get_cterm b); auto.
Qed.

Lemma types_converge {o} :
  forall lib (t : @CTerm o), type lib t -> chaltsc lib t.
Proof.
  introv n.
  unfold type, tequality, nuprl in n; exrepnd.
  induction n0
    as [ h | h | h | h | h
         | h | h | h | h | h
         | h | h | h | h | h
         | h | h | h | h | h
         | h | h | h | h | h
         | h | h | h | h ];
    allunfold_per; uncast; allapply @computes_to_valc_implies_hasvaluec;
    try (complete (spcast; auto)).
  inversion h as [i u].
  rw @univi_exists_iff in u; exrepnd.
  spcast.
  apply computes_to_valc_implies_hasvaluec in u2; auto.
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


(* 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                                                     *)

(****************************************************************************)
(*                          Signes Project                                  *)
(*                            2002-2003                                     *)
(*                           Houda ANOUN                                    *)
(*                          Pierre Casteran                                 *)
(*                           LaBRI/INRIA                                    *)
(****************************************************************************)

(* Formalisation of the axiomatic presentation
  of Lambek calculus . cf.Moortgat *)

Global Set Asymmetric Patterns.
Set Implicit Arguments.
Unset Strict Implicit.

Section CTL_def.

 (* atomic formulae *)

 (* The set of formulae built on Atoms ; we shall put an infix syntax
    in a near future *)

 Inductive Form (Atoms : Set) : Set :=
   | At : Atoms -> Form Atoms
   | Slash : Form Atoms -> Form Atoms -> Form Atoms
   | Dot : Form Atoms -> Form Atoms -> Form Atoms
   | Backslash : Form Atoms -> Form Atoms -> Form Atoms.

(* The arrow relationship and its extensions (like associativity,
  commutativity  etc. )
   Please notice that this relationship has sort Set in order to
   consider derivations as data structures ; for some applications
   which need propositions (such as completeness proofs) one needs
   to coerce a data type like (arrow X A B) into the proposition
   (weak (arrow X A B)).
*)

 Definition arrow_extension :=
   forall Atoms : Set, Form Atoms -> Form Atoms -> Set.

 Definition add_extension (E1 E2 : arrow_extension) : arrow_extension :=
   fun At A B => (E1 At A B + E2 At A B)%type.

 Definition extends (X X' : arrow_extension) :=
   forall (At : Set) (A B : Form At), X At A B -> X' At A B.

 Definition no_extend : forall X : arrow_extension, extends X X.
  unfold extends in |- *; auto.
 Defined.

 Definition add_extend_l :
   forall X X' : arrow_extension, extends X (add_extension X X').
  intros; unfold add_extension, extends in |- *.
  left; auto.
 Qed.

 Definition add_extend_r :
   forall X X' : arrow_extension, extends X' (add_extension X X').
  intros; unfold add_extension, extends in |- *.
  right; auto.
 Qed.

 Definition extends_trans :
   forall X Y Z : arrow_extension, extends X Y -> extends Y Z -> extends X Z.
 intros X Y Z.
 unfold extends in |- *; auto.
 Defined.
(* most popular extensions *)

Inductive NL (Atoms : Set) (A B : Form Atoms) : Set :=.

Inductive NLP (Atoms : Set) : Form Atoms -> Form Atoms -> Set :=
    Comm_intro : forall A B : Form Atoms, NLP (Dot A B) (Dot B A).

Inductive L (Atoms : Set) : Form Atoms -> Form Atoms -> Set :=
  | L_lr : forall A B C : Form Atoms, L (Dot A (Dot B C)) (Dot (Dot A B) C)
  | L_rl : forall A B C : Form Atoms, L (Dot (Dot A B) C) (Dot A (Dot B C)).

Definition LP : arrow_extension := add_extension NLP L.

Lemma NL_X : forall X : arrow_extension, extends NL X.
Proof.
  unfold extends in |- *; simple induction 1.
Qed.

Hint Resolve NL_X: ctl.

Lemma NLP_LP : extends NLP LP.
Proof.
 unfold extends, LP in |- *; left; assumption.
Qed.

Lemma L_LP : extends L LP.
Proof.
 unfold extends, LP in |- *; right; assumption.
Qed.

(* An inductive datatype for (arrow X A B) *)
Variable Atoms : Set.

Section arrow_def.
 Variable X : arrow_extension.

 Inductive arrow (Atoms : Set) : Form Atoms -> Form Atoms -> Set :=
   | one : forall A : Form Atoms, arrow A A
   | comp : forall A B C : Form Atoms, arrow A B -> arrow B C -> arrow A C
   | beta :
       forall A B C : Form Atoms, arrow (Dot A B) C -> arrow A (Slash C B)
   | beta' :
       forall A B C : Form Atoms, arrow A (Slash C B) -> arrow (Dot A B) C
   | gamma :
       forall A B C : Form Atoms,
       arrow (Dot A B) C -> arrow B (Backslash A C)
   | gamma' :
       forall A B C : Form Atoms,
       arrow B (Backslash A C) -> arrow (Dot A B) C
   | arrow_plus : forall A B : Form Atoms, X A B -> arrow A B.

 Hint Resolve one comp beta gamma arrow_plus: ctl.

 (* some derived rules for (arrow X) *)

 Definition Dot_mono_right :
   forall A B B' : Form Atoms, arrow B' B -> arrow (Dot A B') (Dot A B).
  intros A B B' H.
  apply gamma'.
  apply comp with B.
  assumption.
  apply gamma.
  apply one.
 Defined.

 Definition Dot_mono_left :
   forall A B A' : Form Atoms, arrow A' A -> arrow (Dot A' B) (Dot A B).
  intros A B A' H.
  apply beta'.
  apply comp with A; auto.
  apply beta.
  apply one.
 Defined.

 Definition Dot_mono :
   forall A B C D : Form Atoms,
   arrow A C -> arrow B D -> arrow (Dot A B) (Dot C D).
 intros A B C D H H0.
 apply comp with (Dot C B).
 apply Dot_mono_left.
 assumption.
 apply Dot_mono_right; assumption.
Defined.

 Definition Slash_mono_left :
   forall C B C' : Form Atoms, arrow C' C -> arrow (Slash C' B) (Slash C B).
  intros C B C' H.
  apply beta.
  apply comp with C'.
  apply beta'.
  apply one.
  auto.
 Defined.

 Definition Slash_antimono_right :
   forall C B B' : Form Atoms, arrow B' B -> arrow (Slash C B) (Slash C B').
  intros C B B' H.
  apply beta; apply gamma'.
  apply comp with B.
  assumption.
  apply gamma.
  apply beta'.
  apply one.
 Defined.

 Definition Backslash_antimono_left :
   forall A C A' : Form Atoms,
   arrow A A' -> arrow (Backslash A' C) (Backslash A C).
  intros A C A' H.
  apply gamma.
  apply beta'.
  apply comp with A'.
  assumption.
  apply beta.
  apply gamma'.
  apply one.
 Defined.

 Definition Backslash_mono_right :
   forall A C C' : Form Atoms,
   arrow C' C -> arrow (Backslash A C') (Backslash A C).
  intros A C C' H.
  apply gamma.
  apply comp with C'.
  apply beta'.
  apply beta.
  apply gamma'.
  apply one.
  assumption.
 Defined.

End arrow_def.

Hint Resolve one comp beta gamma arrow_plus: ctl.

Definition mono_X :
  forall X X' : arrow_extension,
  extends X X' -> forall A B : Form Atoms, arrow X A B -> arrow X' A B.
 simple induction 2.
 apply one.
 intros.
 eapply comp.
 eauto.
 auto.
 intros.
 apply beta.
 assumption.
 intros.
 apply beta'.
 auto.
 intros.
 apply gamma.
 assumption.
 intros.
 apply gamma'; assumption.
 intros; constructor 7.
 auto.
Defined.

Section weaken.
(* coercion to Prop *)

 Inductive weak (A : Set) : Prop :=
     weak_intro : forall a : A, weak A.

(* weak combinators for arrow
*)

  Lemma weak_one :
   forall (X : arrow_extension) (A : Form Atoms), weak (arrow X A A).
 Proof.
  intros; split.
  apply one.
 Qed.

 Hint Resolve weak_one: ctl.

 Lemma weak_comp :
  forall (X : arrow_extension) (A B C : Form Atoms),
  weak (arrow X A B) -> weak (arrow X B C) -> weak (arrow X A C).
 Proof.
  intros X A B C H H0.
  case H; case H0.
  split.
  apply comp with B; auto.
 Qed.

 Hint Resolve weak_comp: ctl.

 Lemma weak_beta :
  forall (X : arrow_extension) (A B C : Form Atoms),
  weak (arrow X (Dot A B) C) -> weak (arrow X A (Slash C B)).
 Proof.
  intros X A B C H.
  case H.
  split.
  apply beta; auto.
 Qed.

 Hint Resolve weak_beta: ctl.

 Lemma weak_beta' :
  forall (X : arrow_extension) (A B C : Form Atoms),
  weak (arrow X A (Slash C B)) -> weak (arrow X (Dot A B) C).
 Proof.
  intros X A B C H.
  case H.
  split.
  apply beta'; auto.
 Qed.

 Lemma weak_gamma :
  forall (X : arrow_extension) (A B C : Form Atoms),
  weak (arrow X (Dot A B) C) -> weak (arrow X B (Backslash A C)).
 Proof.
  intros X A B C H.
  case H.
  split.
  apply gamma; auto.
 Qed.

 Hint Resolve weak_gamma: ctl.

 Lemma weak_gamma' :
  forall (X : arrow_extension) (A B C : Form Atoms),
  weak (arrow X B (Backslash A C)) -> weak (arrow X (Dot A B) C).
 Proof.
  intros X A B C H.
  case H.
  split.
  apply gamma'; auto.
 Qed.

 Lemma weak_arrow_plus :
  forall (X : arrow_extension) (A B : Form Atoms),
  X _ A B -> weak (arrow X A B).
 Proof.
  split.
  apply arrow_plus; auto.
 Qed.

 Hint Resolve weak_gamma: ctl.

 Lemma weak_Dot_mono :
  forall (A B C D : Form Atoms) (X : arrow_extension),
  weak (arrow X A C) ->
  weak (arrow X B D) -> weak (arrow X (Dot A B) (Dot C D)).
 Proof.
 intros A B C D X H H0.
 case H.
 case H0.
 intros.
 split.
 apply Dot_mono; auto.
Qed.

 Lemma weak_Dot_mono_right :
  forall (X : arrow_extension) (A B B' : Form Atoms),
  weak (arrow X B' B) -> weak (arrow X (Dot A B') (Dot A B)).
 Proof.
  intros X A B B' H.
  case H.
  split.
  apply Dot_mono_right; auto.
 Qed.

 Lemma weak_Dot_mono_left :
  forall (X : arrow_extension) (A B A' : Form Atoms),
  weak (arrow X A' A) -> weak (arrow X (Dot A' B) (Dot A B)).
 Proof.
  intros X A B A' H.
  case H; split.
  apply Dot_mono_left; auto.
 Qed.

 Lemma weak_Slash_mono_left :
  forall (X : arrow_extension) (C B C' : Form Atoms),
  weak (arrow X C' C) -> weak (arrow X (Slash C' B) (Slash C B)).
 Proof.
  intros X C B C' H.
  case H; split.
  apply Slash_mono_left; auto.
 Qed.

 Lemma weak_Slash_antimono_right :
  forall (X : arrow_extension) (C B B' : Form Atoms),
  weak (arrow X B' B) -> weak (arrow X (Slash C B) (Slash C B')).
 Proof.
  intros X C B B' H.
  case H; split.
  apply Slash_antimono_right; auto.
 Qed.

 Lemma weak_Backslash_antimono_left :
  forall (X : arrow_extension) (A C A' : Form Atoms),
  weak (arrow X A A') -> weak (arrow X (Backslash A' C) (Backslash A C)).
 Proof.
  intros X A C A' H.
  case H; split.
  apply Backslash_antimono_left; auto.
 Qed.

 Lemma weak_Backslash_mono_right :
  forall (X : arrow_extension) (A C C' : Form Atoms),
  weak (arrow X C' C) -> weak (arrow X (Backslash A C') (Backslash A C)).
 Proof.
  intros X A C C' H.
  case H; split.
  apply Backslash_mono_right; auto.
 Qed.

End weaken.

(* combinators  pi and alpha *)

 Definition pi :
   forall X : arrow_extension,
   extends NLP X -> forall A B : Form Atoms, arrow X (Dot A B) (Dot B A).
  intros X H A B.
  apply arrow_plus.
  apply H.
  split.
 Defined.

 Definition pi_NLP : forall A B : Form Atoms, arrow NLP (Dot A B) (Dot B A).
  apply pi.
  apply no_extend.
 Defined.

 Definition pi_LP : forall A B : Form Atoms, arrow LP (Dot A B) (Dot B A).
  apply pi.
  unfold LP in |- *.
  apply add_extend_l.
 Defined.

 Definition alpha :
   forall X : arrow_extension,
   extends L X ->
   forall A B C : Form Atoms, arrow X (Dot A (Dot B C)) (Dot (Dot A B) C).
  intros X H A B C.
  apply arrow_plus.
  apply H.
  left.
 Defined.

 Definition alpha_L :
   forall A B C : Form Atoms, arrow L (Dot A (Dot B C)) (Dot (Dot A B) C).
  apply alpha.
  apply no_extend.
 Defined.

 Definition alpha_LP :
   forall A B C : Form Atoms, arrow LP (Dot A (Dot B C)) (Dot (Dot A B) C).
  apply alpha.
  unfold LP in |- *; apply add_extend_r.
 Defined.

 Definition alpha' :
   forall X : arrow_extension,
   (forall A B : Form Atoms, L A B -> X _ A B) ->
   forall A B C : Form Atoms, arrow X (Dot (Dot A B) C) (Dot A (Dot B C)).
  intros X H A B C.
  apply arrow_plus.
  apply H.
  right.
 Defined.

 Definition alpha'_L :
   forall A B C : Form Atoms, arrow L (Dot (Dot A B) C) (Dot A (Dot B C)).
  apply alpha'.
  auto.
 Defined.

 Definition alpha'_LP :
   forall A B C : Form Atoms, arrow LP (Dot (Dot A B) C) (Dot A (Dot B C)).
  apply alpha'.
  unfold LP, add_extension in |- *; auto.
 Defined.

End CTL_def.

Implicit Arguments Dot [Atoms].
Implicit Arguments Slash [Atoms].
Implicit Arguments Backslash [Atoms].

Hint Resolve one comp beta gamma arrow_plus: ctl.

Hint Resolve weak_one weak_comp weak_beta weak_gamma: ctl.

Hint Resolve NL_X L_LP NLP_LP: ctl.


(**

    This file is an modificaion/extention of gc exercise from References.v
    of Software Foundation (Pierce 2012).
    It implements a toy gc (mark and compact), which is based on [2] (page
    602-603) and also explained in [3] (chapter 3).

<<

   [1] Benjamin C. Pierce, Chris Casinghino, Michael Greenberg
           C\v{a}t\v{a}lin Hri\c{t}cu, Vilhelm Sjoberg and Brent Yorgey.
           Software Foundations. http://www.cis.upenn.edu/~bcpierce/sf
           July 2012.
   [2] Knuth, Donald E. The Art of Computer Programming, Vol. 1: Fundamental
           Algorithms. Addision-Wesley. Reading, MA. 1969.
   [3] Jones, Richard, Antony Hosking, and Eliot Moss. Garbage Collector
           Handbook: The Art of Automatic Memory Management. CRC Press.
           Boca Raton. 2012.

>>
*)

  Require Export dual.MyLib.
  Require Export Recdef.
  Require Export Bool.
  Require Export List.
  Require Export Arith.
  Require Export Arith.EqNat.  (* Contains [beq_nat], among other things *)

  (** Types *)

  Inductive ty : Type :=
  | ty_nat   : ty
  | ty_arrow : ty -> ty -> ty
  | ty_unit  : ty
  | ty_ref   : ty -> ty.

  (* ################################### *)

  (** [Module id] from Software Foundation 2012, Imp.v

   *)

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

    Definition beq_id X1 X2 :=
      match (X1, X2) with
          (Id n1, Id n2) => beq_nat n1 n2
      end.

    Theorem beq_id_refl :
      forall X,
        true = beq_id X X.
    Proof.
      intros. destruct X.
      apply beq_nat_refl.
    Qed.

    Theorem beq_id_eq :
      forall i1 i2,
        true = beq_id i1 i2 -> i1 = i2.
    Proof.
      intros i1 i2 H.
      destruct i1 as [n1]; destruct i2 as [n2].
      unfold beq_id in H.
      rewrite (beq_nat_true n1 n2); auto.
    Qed.

    Theorem beq_id_false_not_eq :
      forall i1 i2,
        beq_id i1 i2 = false -> i1 <> i2.
    Proof.
      intros i1 i2 H.
      destruct i1 as [n1]; destruct i2 as [n2].
      unfold beq_id in H.
      generalize dependent n2.
      generalize dependent n1.
      induction n1; destruct n2; simpl; intro H; try discriminate.
      apply IHn1 in H.
      intro Contr; inversion Contr.
      apply H; auto.
    Qed.

    (** Coq Art, page 255 *)

    Definition eq_dec (A: Type) := forall x y: A, {x = y}+{x <> y}.
    Lemma eq_dec_nat: eq_dec nat. unfold eq_dec. auto with arith. Qed.

    Theorem not_eq_beq_id_false :
      forall i1 i2,
        i1 <> i2 -> beq_id i1 i2 = false.
    Proof.
      intros i1 i2 Neq.
      destruct i1 as [n1]; destruct i2 as [n2].
      unfold beq_id.
      destruct (eq_dec_nat n1 n2).
      - subst n1.
        apply False_ind.
        now apply Neq.
      - now apply Nat.eqb_neq.
    Qed.

    Theorem beq_id_sym:
      forall i1 i2,
        beq_id i1 i2 = beq_id i2 i1.
    Proof.
      intros i1 i2.
      destruct i1 as [n1]; destruct i2 as [n2].
      unfold beq_id.
      apply Nat.eqb_sym.
    Qed.
  (** [] *)

  (** Terms *)

  Inductive tm  : Type :=
  | tm_var    : id -> tm
  | tm_app    : tm -> tm -> tm
  | tm_abs    : id -> ty -> tm -> tm
  | tm_nat    : nat -> tm
  | tm_succ   : tm -> tm
  | tm_pred   : tm -> tm
  | tm_add    : tm -> tm -> tm
  | tm_mult   : tm -> tm -> tm
  | tm_if0    : tm -> tm -> tm -> tm
  | tm_unit   : tm
  | tm_ref    : tm -> tm
  | tm_deref  : tm -> tm
  | tm_assign : tm -> tm -> tm
  | tm_loc    : nat -> tm.

  (** IDs *)

  Definition _a := Id 1001.
  Definition _b := Id 1002.
  Definition _c := Id 1003.
  Definition _d := Id 1004.
  Definition _e := Id 1005.
  Definition _f := Id 1006.
  Definition _g := Id 1007.
  Definition _h := Id 1008.
  Definition _i := Id 1009.
  Definition _j := Id 1010.
  Definition _k := Id 1011.
  Definition _l := Id 1012.
  Definition _m := Id 1013.
  Definition _n := Id 1014.
  Definition _o := Id 1015.
  Definition _p := Id 1016.
  Definition _q := Id 1017.
  Definition _r := Id 1018.
  Definition _s := Id 1019.
  Definition _t := Id 1020.
  Definition _u := Id 1021.
  Definition _v := Id 1022.
  Definition _w := Id 1023.
  Definition _x := Id 1024.
  Definition _y := Id 1025.
  Definition _z := Id 1026.

  (* ################################### *)
  (** Values and Substitution *)

  Inductive value : tm -> Prop :=
  | v_abs  : forall x T t,
               value (tm_abs x T t)
  | v_nat : forall n,
              value (tm_nat n)
  | v_unit :
      value tm_unit
  | v_loc : forall l,
              value (tm_loc l).

  Hint Constructors value.

  (** From Software Foundation Imp.v.
   *)

  Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
    match t with
      | tm_var x'       => if beq_id x x' then s else t
      | tm_app t1 t2    => tm_app (subst x s t1) (subst x s t2)
      | tm_abs x' T t1  => if beq_id x x' then t else tm_abs x' T (subst x s t1)
      | tm_nat n        => t
      | tm_succ t1      => tm_succ (subst x s t1)
      | tm_pred t1      => tm_pred (subst x s t1)
      | tm_add t1 t2    => tm_add (subst x s t1) (subst x s t2)
      | tm_mult t1 t2   => tm_mult (subst x s t1) (subst x s t2)
      | tm_if0 t1 t2 t3 => tm_if0 (subst x s t1) (subst x s t2) (subst x s t3)
      | tm_unit         => t
      | tm_ref t1       => tm_ref (subst x s t1)
      | tm_deref t1     => tm_deref (subst x s t1)
      | tm_assign t1 t2 => tm_assign (subst x s t1) (subst x s t2)
      | tm_loc _        => t
    end.

  (* ###################################################################### *)

  Definition tm_seq t1 t2 := tm_app (tm_abs _x ty_unit t2) t1.

  Definition cell := (prod bool tm).

  Definition store := list cell.

  Notation "'|' m '|'" := (length m) (at level 50).

  Definition isLive (c: cell) := (fst c).
  Definition isFree (c: cell) := negb (isLive c).

  Lemma isLive_neg_isFree:
    forall c, isLive c = negb (isFree c).
  Proof.
    intro c. unfold isLive, isFree.
    now rewrite negb_involutive.
  Qed.

  Definition store_lookup (n:nat) (st:store): tm :=
    (snd (nth n st (false, tm_unit))).

  Definition store_lookup_cell (n:nat) (st:store): (bool * tm) :=
    (nth n st (false, tm_unit)).

  Fixpoint replace {A:Type} (n:nat) (x:A) (l:list (bool * A)) : list (bool * A) :=
    match l with
      | nil    => nil
      | h :: t =>
        match n with
          | O    => ((fst h), x) :: t
          | S n' => h :: replace n' x t
        end
    end.

  (** *** Fixpoint: [clearMarks]

      This function is used to initialize the memory when program is to start.
      Afterwords, [gc] clears the memory when finishing relocation.
   **)

  Fixpoint clearMark(c: cell) : cell :=
    match c with
      | (live, data) => (false, data)
    end.

  Fixpoint clearMarks(s: store) : store :=
    match s with
      | nil => []
      | e::s' => (clearMark e)::clearMarks s'
    end.

  Functional Scheme clearMarks_ind := Induction for clearMarks Sort Prop.

  Fixpoint findFree (m: store) (acc: store) :=
    match m with
      | [] => None
      | x::xs => if (isFree x) then Some (acc, x, xs)
                 else findFree xs (acc++[clearMark x])
    end.
  Functional Scheme findFree_ind := Induction for findFree Sort Prop.

  Fixpoint findFreeX_aux (m acc: store) (offset: nat):=
    match m with
      | [] => None
      | x::xs => if (isFree x) then Some (acc, offset, xs)
                 else findFreeX_aux xs (acc++[clearMark x]) (S offset)
    end.
  Functional Scheme findFreeX_aux_ind := Induction for findFreeX_aux Sort Prop.

  Definition findFreeX (m acc: store) := findFreeX_aux m acc 0.

  (*
  Definition findFreeX (m acc: store) :=
    let fix f (m acc: store) (offset: nat):=
        match m with
          | [] => None
          | x::xs => if (isFree x) then Some (acc, offset, xs)
                     else f xs (acc++[clearMark x]) (S offset)
        end
    in f m acc 0.
  *)

  Lemma findFree_reduces_list:
    forall m acc acc' x xs,
      findFree m acc = Some (acc',x,xs) -> |xs| < |m|.
  Proof.
    intros m acc.
    functional induction (findFree m acc); intros * FF; inversion FF.
    - simpl. omega.
    - apply IHo in FF.
      simpl.
      apply lt_trans with (m:=|xs|); auto.
  Qed.

  Require Export dual.MyLib.
  Require Import dual.cata.

  Fixpoint lastVal {A: Type} (m: list A) (d: A) :=
    match m with
      | [] => d
      | x::xs => lastVal xs x
    end.

  Definition delLast {A: Type} (m: list A) :=
    match rev_tr m [] with
      | [] => []
      | x::xs => rev_tr xs []
    end.

  Lemma delLast_len:
    forall {A: Type} (y: A) (ys: list A),
   |delLast (y :: ys) | < |y :: ys |.
  Proof.
    intros.
    unfold delLast.
    rewrite <- rev__rev_tr.
    Check rev_length.
    name_term xxs (rev (y::ys)) REV_YYS.
    rewrite <- REV_YYS.
    destruct xxs as [| x xs].
    - simpl. auto with arith.
    - rewrite <- rev__rev_tr.
      assert (XXS_YYS: |x::xs| = |y::ys|).
      {
        rewrite REV_YYS.
        apply rev_length.
      }
      rewrite <- XXS_YYS.
      assert (REV_XXS: |rev xs| = |xs|) by apply rev_length.
      rewrite REV_XXS.
      simpl.
      auto with arith.
  Qed.

  Function scanLive (m: store) (acc: store) {measure length m} :=
    match m with
      | [] => None
      | y::ys => let x := lastVal m y in
                 let sx := delLast m in
                 if (isLive x) then Some (sx, x, acc)
                 else scanLive sx (x::acc)
    end.
  Proof.
    intros.
    apply delLast_len.
  Qed.

  Functional Scheme scanLive_ind := Induction for scanLive Sort Prop.

  Lemma scanLive_reduces_list:
    forall m acc sx x acc',
      scanLive m acc = Some (sx, x, acc') -> |sx| < |m|.
  Proof.
    intros m acc.
    functional induction (scanLive m acc); intros * FF; inversion FF.
    - apply delLast_len.
    - apply IHo in FF.
      apply lt_trans with (m:= |delLast (y :: ys) |); auto.
      apply delLast_len.
  Qed.

  Function relocate_tr (m acc_l acc_r: store) (L: nat) {measure length m}:=
    match findFree m [] with
      | None => (acc_l ++ m ++ acc_r, L)
      | Some (m_l, _, m_r) =>
        match scanLive m_r [] with
          | None => (acc_l ++ m ++ acc_r, L)
          | Some (m_m, y, m_r) =>
            let L' := L + |m_l| in
            relocate_tr m_m (acc_l ++ m_l ++ [y]) ([(false, tm_nat L')]++ m_r ++ acc_r) (L' + 1)
        end
    end.
  Proof.
    intros.
    apply findFree_reduces_list in teq.
    apply scanLive_reduces_list in teq2.
    apply lt_trans with (m:=(|m_r|)); assumption.
  Qed.