Load "include/ops_header.v".

Require annotated_recs_c annotated_recs_s.
Require Import annotated_recs_v.

(* Shorter name space for elements in annotated_recs_[c|u|v] *)
Module c.
Include annotated_recs_c.
End c.

(* Remember that u shares the same annihilators as s. *)
Module u.
Include annotated_recs_s.
End u.

Module v.
Include annotated_recs_v.
End v.

Section AnnOfV.

Variable c : int -> int -> rat.
Variable u : int -> int -> rat.

Variable c_ann : c.Ann c.
Let c_Sn := c.Sn_ c_ann.
Let c_Sk := c.Sk_ c_ann.

Variable u_ann : u.Ann u.

Let u_Sn2 := u.Sn2_ u_ann.
Let u_SnSk := u.SnSk_ u_ann.
Let u_Sk2 := u.Sk2_ u_ann.

Let v n k := c n k * u n k.

Lemma v_Sk2 : Sk2 v.
Proof.
rewrite /Sk2 /precond.Sk2.
move=> n k ?.
rewrite /v.
do 1! (rewrite u_Sk2; last by rewrite /annotated_recs_s.precond.Sk2; lia).
set u1 := u _ _.
set u2 := u _ _.
do 3! (rewrite c_Sk; last by rewrite /c.precond.Sk; lia).
set c1 := c _ _.
rewrite
  /c.Sk_cf0_0 /annotated_recs_s.Sk2_cf0_0 /annotated_recs_s.Sk2_cf0_1
  /Sk2_cf0_0 /Sk2_cf0_1 !int.shift2R.
by field; ring_lia.
Qed.

Lemma v_SnSk : SnSk v.
Proof.
rewrite /SnSk /precond.SnSk.
move=> n k ?.
rewrite /v.
do 1! (rewrite u_SnSk; last by rewrite /annotated_recs_s.precond.SnSk; lia).
set u1 := u _ _.
set u2 := u _ _.
set u3 := u _ _. (* set u4 := u _ _.*)
do 2! (rewrite c_Sn; last by rewrite /c.precond.Sn; lia).
do 1! (rewrite c_Sk; last by rewrite /c.precond.Sk; lia).
set c1 := c _ _.
(* set c2 := c _ _. *)
rewrite /c.Sn_cf0_0 /c.Sk_cf0_0 !int.shift2R.
rewrite /annotated_recs_s.SnSk_cf0_0 /annotated_recs_s.SnSk_cf1_0.
rewrite  /annotated_recs_s.SnSk_cf0_1 /SnSk_cf0_0 /SnSk_cf1_0 /SnSk_cf0_1.
by field; ring_lia.
Qed.

Lemma v_Sn2 : Sn2 v.
Proof.
rewrite /Sn2 /precond.Sn2.
move=> n k ?.
rewrite /v.
do 1! (rewrite u_Sn2; last by rewrite /annotated_recs_s.precond.Sn2; lia).
set u1 := u _ _.
set u2 := u _ _.
set u3 := u _ _.
do 3! (rewrite c_Sn; last by rewrite /c.precond.Sn; lia).
do 1! (rewrite c_Sk; last by rewrite /c.precond.Sk; lia).
set c1 := c _ _.
(* set c2 := c _ _.*)
rewrite /c.Sn_cf0_0 /c.Sk_cf0_0 !int.shift2R.
rewrite /Sn2_cf0_0 /Sn2_cf1_0 /Sn2_cf0_1.
rewrite /annotated_recs_s.Sn2_cf0_0 /annotated_recs_s.Sn2_cf1_0.
rewrite /annotated_recs_s.Sn2_cf0_1.
by field; ring_lia.
Qed.

End AnnOfV.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Functor.
Require Import Category.Functor.Bifunctor.
Require Import Category.Functor.Opposite.
Require Import Category.Construction.Product.
Require Import Category.Construction.Opposite.

Generalizable All Variables.

Class Wedge `(F : C^op ∏ C ⟶ D) := {
  wedge_obj : D;

  wedge_map {x : C} : wedge_obj ~{D}~> F (x, x);

  ump_wedges {x y : C} (f : x ~{C}~> y) :
    bimap[F] id f ∘ wedge_map ≈ bimap[F] (op f) id ∘ wedge_map
}.

Coercion Wedge_to_obj `(F : C^op ∏ C ⟶ D) (W : Wedge F) : D :=
  @wedge_obj _ _ _ W.

Notation "wedge_map[ C ]" := (@wedge_map _ _ _ C _)
  (at level 9, format "wedge_map[ C ]") : category_scope.

Definition Cowedge `(F : C^op ∏ C ⟶ D) := @Wedge (C^op) (D^op) (F^op).


Require Import Nijn.Prelude.
Require Import Nijn.Syntax.Signature.
Require Import Nijn.Syntax.Signature.SubstitutionLemmas.
Require Import Coq.Program.Equality.

(** * Lemmas on the rewriting relation *)

(** ** Beta reduction is reflected under weakening *)
Lemma is_BaseTm_wkTm
      {B : Type}
      {F : Type}
      {ar : F -> ty B}
      {C1 C2 : con B}
      (w : wk C1 C2)
      {A : ty B}
      {t : tm ar C2 A}
      (Ht : is_BaseTm t)
  : is_BaseTm (wkTm t w).
Proof.
  induction t ; try contradiction.
  apply I.
Qed.

Definition wWeakened
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           (w : wk C1 C2)
           {A : ty B}
           (t : tm ar C1 A)
  : Type
  := { t' : tm ar C2 A | wkTm t' w = t  }.

Definition term_of
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           {w : wk C1 C2}
           {A : ty B}
           {t : tm ar C1 A}
           (p : wWeakened w t)
  : tm ar C2 A.
Proof.
  destruct p as [x e].
  exact x.
Defined.

Definition term_of_eq
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           {w : wk C1 C2}
           {A : ty B}
           {t : tm ar C1 A}
           (p : wWeakened w t)
  : wkTm (term_of p) w = t.
Proof.
  destruct p as [x e].
  exact e.
Defined.

Definition wkTm_red_lam_help
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           (w : wk C1 C2)
           {A1 A2 A' : ty B}
           (t : tm ar C2 A')
           (f : tm ar (A1 ,, C1) A2)
           (p : A' = (A1 ⟶ A2))
           (q : wkTm (transport _ p t) w = λ f)
  : { t' : tm ar (A1 ,, C2) A2 | transport _ p t = λ t' }.
Proof.
  destruct t ; try (subst ; simpl in * ; discriminate).
  - enough (is_BaseTm (λ f)) by contradiction.
    rewrite <- q.
    apply is_BaseTm_wkTm.
    apply transport_BaseTm.
    apply I.
  - dependent destruction p ; simpl.
    exists t.
    reflexivity.
Qed.

Definition wkTm_red_lam
           {B : Type}
           {F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           (w : wk C1 C2)
           {A1 A2 : ty B}
           (t : tm ar C2 (A1 ⟶ A2))
           (f : tm ar (A1 ,, C1) A2)
           (q : wkTm t w = λ f)
  : { t' : tm ar (A1 ,, C2) A2 | t = λ t' }.
Proof.
  exact (wkTm_red_lam_help w t f eq_refl q).
Qed.

Proposition wkTm_red_step
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            {w : wk C1 C2}
            {A : ty B}
            {t1 t2 : tm ar C1 A}
            (p : wWeakened w t1)
            (r : t1 ∼>β t2)
  : { q : wWeakened w t2 & term_of p ∼>β term_of q }.
Proof.
  revert p.
  revert w.
  revert C2.
  induction r ; intros C2 w p.
  - destruct p as [t' p].
    destruct t' ; simpl in * ; try discriminate.
    assert (p1 := App_eq_Ty p).
    assert (p2 := App_eq_fst p).
    assert (p3 := App_eq_snd p).
    dependent destruction p.
    simpl in *.
    specialize (IHr _ _ (exist _ t'1 p2)).
    destruct IHr as [q Hq].
    destruct q as [v q].
    unshelve eexists.
    + unshelve eexists.
      * refine (v · t'2).
      * simpl.
        subst.
        reflexivity.
    + simpl.
      apply App_l.
      assumption.
  - destruct p as [t' p].
    destruct t' ; simpl in * ; try discriminate.
    assert (p1 := App_eq_Ty p).
    assert (p2 := App_eq_fst p).
    assert (p3 := App_eq_snd p).
    dependent destruction p.
    simpl in *.
    specialize (IHr _ _ (exist _ t'2 p3)).
    destruct IHr as [q Hq].
    destruct q as [v q].
    unshelve eexists.
    + unshelve eexists.
      * refine (t'1 · v).
      * simpl.
        subst.
        reflexivity.
    + simpl.
      apply App_r.
      assumption.
  - destruct p as [t' p].
    destruct (wkTm_red_lam w t' f1 p) as [x e].
    subst.
    pose (q' := Lam_eq p).
    specialize (IHr _ (Keep A1 w) (exist _ _ q')).
    destruct IHr as [z Hz].
    destruct z as [z Hz'].
    unshelve eexists.
    + unshelve eexists.
      * refine (λ z).
      * simpl.
        rewrite  Hz'.
        reflexivity.
    + simpl.
      apply CLam.
      assumption.
  - induction r.
    simpl in *.
    destruct p as [t' p].
    destruct t' ; simpl in * ; try discriminate.
    assert (p1 := App_eq_Ty p).
    subst.
    assert (p2 := App_eq_fst p).
    assert (p3 := App_eq_snd p).
    rewrite (UIP (App_eq_Ty p) eq_refl) in p2.
    rewrite (UIP (App_eq_Ty p) eq_refl) in p3.
    simpl in *.
    destruct (wkTm_red_lam w t'1 f p2) as [x' e].
    subst.
    simpl in *.
    unshelve eexists.
    + unshelve eexists.
      * exact (x' [ beta_sub t'2 ]).
      * abstract
          (rewrite <- (Lam_eq p2) ;
           rewrite !wkTm_is_subTm ;
           rewrite !subTm_comp ;
           f_equal ;
           simpl ; cbn ;
           rewrite Sub_id_left ;
           f_equal ;
           unfold beta_sub ;
           simpl ;
           rewrite dropSub_is_compSubWk ;
           rewrite <- compSub_compWkSub ;
           simpl ; cbn;
           rewrite compWkSub_id ;
           rewrite Sub_id_right ;
           reflexivity).
    + simpl.
      apply CStep.
      apply Beta.
Qed.

Proposition wkTm_red
            {B : Type}
            {F : Type}
            {ar : F -> ty B}
            {C1 C2 : con B}
            (w : wk C1 C2)
            {A : ty B}
            {t1 t2 : tm ar C1 A}
            (p : wWeakened w t1)
            (r : t1 ∼>β+ t2)
  : { q : wWeakened w t2 & term_of p ∼>β+ term_of q }.
Proof.
  induction r as [ ? ? r | ? ? ? r1 IHr1 r2 IHr2].
  - pose (wkTm_red_step p r) as H.
    destruct H as [q Hq].
    exists q.
    apply betaRed_step.
    exact Hq.
  - specialize (IHr1 p).
    destruct IHr1 as [q Hq].
    specialize (IHr2 q).
    destruct IHr2 as [q' Hq'].
    exists q'.
    exact (beta_Trans Hq Hq').
Qed.

(** ** Beta reduction *)
Definition betaRed_step_Wk
           {B F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           {A : ty B}
           {t1 t2 : tm ar C2 A}
           (w : wk C1 C2)
           (p : t1 ∼>β t2)
  : wkTm t1 w ∼>β wkTm t2 w.
Proof.
  revert w.
  revert C1.
  induction p ; intros C1 w ; simpl.
  - exact (App_l _ (IHp _ w)).
  - exact (App_r _ (IHp _ w)).
  - exact (CLam (IHp _ (Keep A1 w))).
  - apply CStep.
    induction r.
    rewrite !wkTm_is_subTm.
    rewrite subTm_comp.
    unfold beta_sub.
    rewrite <- beta_sub_help.
    rewrite <- subTm_comp.
    apply Beta.
Qed.

Definition betaRed_Wk
           {B F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           {A : ty B}
           {t1 t2 : tm ar C2 A}
           (w : wk C1 C2)
           (p : t1 ∼>β+ t2)
  : wkTm t1 w ∼>β+ wkTm t2 w.
Proof.
  revert w.
  revert C1.
  induction p ; intros C1 w ; simpl.
  - apply betaRed_step.
    apply betaRed_step_Wk.
    exact r.
  - exact (beta_Trans (IHp1 C1 w) (IHp2 C1 w)).
Qed.

(** Rewriting is closed under substitution *)
Definition betaRed_step_sub
           {B F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           {A : ty B}
           {t1 t2 : tm ar C2 A}
           (s : sub ar C1 C2)
           (p : t1 ∼>β t2)
  : t1 [ s ] ∼>β t2 [ s ].
Proof.
  revert s.
  revert C1.
  induction p ; intros C1 s ; simpl.
  - exact (App_l _ (IHp _ s)).
  - exact (App_r _ (IHp _ s)).
  - exact (CLam (IHp _ (keepSub A1 s))).
  - apply CStep.
    induction r.
    simpl.
    pose (Beta (f [ keepSub A1 s ]) (x [ s ])) as p.
    unfold beta_sub in *.
    assert (f [ keepSub A1 s ] [ idSub C1 _ && x [ s ] ]
            =
            f [ idSub C _ && x ] [ s ])
      as H.
    {
      rewrite subTm_comp.
      unfold keepSub.
      rewrite dropSub_is_compSubWk.
      simpl ; cbn.
      rewrite <- compSub_compWkSub.
      simpl ; cbn.
      rewrite compWkSub_id.
      rewrite Sub_id_right.
      rewrite subTm_comp.
      simpl ; cbn.
      rewrite Sub_id_left.
      reflexivity.
    }
    rewrite H in p.
    exact p.
Qed.

Definition betaRed_sub
           {B F : Type}
           {ar : F -> ty B}
           {C1 C2 : con B}
           {A : ty B}
           {t1 t2 : tm ar C2 A}
           (s : sub ar C1 C2)
           (p : t1 ∼>β+ t2)
  : t1 [ s ] ∼>β+ t2 [ s ].
Proof.
  revert s.
  revert C1.
  induction p ; intros C1 s ; simpl.
  - apply betaRed_step.
    apply betaRed_step_sub.
    exact r.
  - exact (beta_Trans (IHp1 C1 s) (IHp2 C1 s)).
Qed.

(** ** Rewriting in an AFS *)

Import AFSNotation.

(** Rewriting is closed under weakening *)
Definition Rew_Wk
           {B F : Type}
           {X : afs B F}
           {C1 C2 : con B}
           {A : ty B}
           {t1 t2 : tm X C2 A}
           (w : wk C1 C2)
           (p : t1 ∼> t2)
  : wkTm t1 w ∼> wkTm t2 w.
Proof.
  revert w.
  revert C1.
  induction p ; intros C1 w ; simpl.
  - apply rew_step.
    revert C1 w.
    induction r ; intros C1 w.
    + exact (App_l _ (IHr _ w)).
    + exact (App_r _ (IHr _ w)).
    + exact (CLam (IHr _ (Keep A1 w))).
    + apply CStep.
      induction r.
      * induction b.
        rewrite !wkTm_is_subTm.
        rewrite subTm_comp.
        unfold beta_sub.
        rewrite <- beta_sub_help.
        rewrite <- subTm_comp.
        apply AFSBeta.
        apply Beta.
      * rewrite !wkTm_is_subTm.
        rewrite !subTm_comp.
        apply AFSRew.
  - exact (rew_Trans (IHp1 C1 w) (IHp2 C1 w)).
Qed.

(** Rewriting is closed under substitution *)
Definition Rew_sub
           {B F : Type}
           {X : afs B F}
           {C1 C2 : con B}
           {A : ty B}
           {t1 t2 : tm X C2 A}
           (s : sub _ C1 C2)
           (p : t1 ∼> t2)
  : t1 [ s ] ∼> t2 [ s ].
Proof.
  revert s.
  revert C1.
  induction p ; intros C1 s ; simpl.
  - apply rew_step.
    revert C1 s.
    induction r ; intros C1 s.
    + exact (App_l _ (IHr _ s)).
    + exact (App_r _ (IHr _ s)).
    + exact (CLam (IHr _ (keepSub A1 s))).
    + apply CStep.
      induction r.
      * induction b.
        simpl.
        apply AFSBeta.
        pose (Beta (subTm f (keepSub A1 s)) (subTm x s)) as p.
        unfold beta_sub in *.
        assert (f [ keepSub A1 s ] [ idSub C1 (arity X) && x [ s ] ]
                =
                f [ idSub C (arity X) && x ] [ s ])
          as H.
        {
          rewrite subTm_comp.
          unfold keepSub.
          rewrite dropSub_is_compSubWk.
          simpl ; cbn.
          rewrite <- compSub_compWkSub.
          simpl ; cbn.
          rewrite compWkSub_id.
          rewrite Sub_id_right.
          rewrite subTm_comp.
          simpl ; cbn.
          rewrite Sub_id_left.
          reflexivity.
        }
        rewrite H in p.
        exact p.
      * rewrite !subTm_comp.
        apply AFSRew.
  - exact (rew_Trans (IHp1 C1 s) (IHp2 C1 s)).
Qed.


Require Import Language
    StateTransformerConstructions.
Require Import Tactics.
Require Import Relations SetoidClass.

(* Setoid with extensional equivalence *)
Program Instance extensional_setoid {A B} : Setoid (A -> B).

Lemma fun_equiv {A B} (x y : A -> B) (a : A) : x == y -> x a = y a.
 firstorder.
Qed.

(* pointwise partial function overwriting *)
Definition pw_over {A B} (f1 f2 : A -> option B) (a : A) :=
  match f1 a with
  | Some b => Some b
  | None => f2 a
  end.

Instance pw_over_morphism {A B} : Proper (equiv ==> equiv ==> equiv) (pw_over (A:=A) (B:=B)).
 repeat intro.
 cbv.
 rewrite (H a), (H0 a).
 destruct (y a); reflexivity.
Qed.

(* Heaps -- well actually stores -- are parametrised
   by two types: the type of variables and the type
   of non-address values.  Equality for the former
   must be decidable.
 *)
Module Type HeapTypes.
  Parameter Var Other : Set.
  Axiom Var_eq_dec : forall (x y : Var), {x = y} + {x <> y}.
End HeapTypes.

(* A basic instance of HeapTypes with only one
   non-location value (effectively null)
 *)
Module BasicHeapTypes <: HeapTypes.
  Definition Var := nat.
  Proposition Var_eq_dec : forall (x y : Var), {x = y} + {x <> y}.
   decide equality.
  Qed.
  Definition Other := unit.
End BasicHeapTypes.

Module MHeaps (Import ht : HeapTypes).
  (* Locations are the naturals *)
  Definition Loc := nat.
  Lemma Loc_eq_dec : forall (x y : Loc), {x = y} + {x <> y}.
   decide equality.
  Qed.
  (* Values are locations or others *)
  Inductive Val : Type :=
    | loc_val : Loc -> Val
    | oth_val : Other -> Val
  .
  (* Stores consist of finite partial heap and
     a variable environment.  We use an explicit
     bound to ensure finiteness.
   *)
  Record store := {
    heap : Loc -> option Val;
    vars : Var -> option Val;
    heapBound : nat;
    heapFree : forall m, heapBound <= m -> heap m = None
  }.

  Instance store_equivalence : Equivalence
    (fun s1 s2 => heap s1 == heap s2 /\ vars s1 == vars s2).
   intuition; repeat intro; rewr intuition.
  Qed.

  (* Stores form a setoid *)
  Instance store_setoid : Setoid store :=
   { equiv := fun s1 s2 => heap s1 == heap s2 /\ vars s1 == vars s2 }.

  (* The projections are morphisms *)
  Instance heap_morphism : Proper (equiv ==> equiv) heap.
   repeat intro.
   destruct H.
   rewr trivial.
  Qed.

  Instance heap_morphism2 : Proper (equiv ==> eq ==> eq) heap.
   repeat intro; subst.
   exact (heap_morphism _ _ H y0).
  Qed.

  Instance vars_morphism : Proper (equiv ==> equiv) vars.
   repeat intro.
   destruct H.
   rewr trivial.
  Qed.

  Instance vars_morphism2 : Proper (equiv ==> eq ==> eq) vars.
   repeat intro; subst.
   exact (vars_morphism _ _ H y0).
  Qed.

  (* Defining overwriting: use the max of the
     bounds as the new bound.
   *)
  Require Import Arith.
  Import Max.
  Lemma max_over_bound (s1 s2 : store) :
      forall m, max (heapBound s1) (heapBound s2) <= m ->
          (pw_over (heap s1) (heap s2)) m = None.
   intros.
   assert (heap s1 m = None).
    apply heapFree; eapply max_lub_l; eauto.
   unfold pw_over.
   rewrite H0.
   apply heapFree; eapply max_lub_r; eauto.
  Qed.

  Definition overwrite (s1 s2 : store) :=
   {|
      heap := pw_over (heap s1) (heap s2);
      vars := pw_over (vars s1) (vars s2);
      heapBound := max (heapBound s1) (heapBound s2);
      heapFree := max_over_bound s1 s2
   |}.

  (* A store with just a single variable *)
  Definition sngvar (x : Var) (v : Val) : Var -> option Val :=
    fun x' => if Var_eq_dec x x' then Some v else None.

  Definition svstore x v : store :=
   {|
     heap := fun _ => None;
     vars := sngvar x v;
     heapBound := 0;
     heapFree := fun (m : nat) (_ : 0 <= m) => eq_refl
   |}.

  (* A store with a single heap cell *)
  Definition sngloc (l : Loc) (v : Val) : Loc -> option Val :=
    fun l' => if Loc_eq_dec l l' then Some v else None.

  (* Bound will be location plus one *)
  Lemma sngloc_bound l v : forall l', S l <= l' -> sngloc l v l' = None.
   intros.
   cbv.
   destruct (Loc_eq_dec l l').
   subst.
   set (Le.le_Sn_n l').
   contradiction.
   trivial.
  Qed.

  Definition slstore l v : store :=
    {| heap := sngloc l v;
       vars := fun _ => None;
       heapBound := S l;
       heapFree := sngloc_bound l v |}.

End MHeaps.

(* So we can define functors, we want a type for the
   Heaps module.
 *)
Module Type THeaps (ht : HeapTypes).
  Include (MHeaps ht).
End THeaps.

(* The atomic commands for heap update *)
Module HeapAtomics (Import ht : HeapTypes) (Import hp : THeaps ht) .
  Inductive hAtomic : Set :=
   | hidat : hAtomic
   | assn : Var -> Var -> hAtomic
   | mut_val : Var -> Val -> hAtomic
   | mut_var : Var -> Var -> hAtomic
   | lu_var : Var -> Var -> hAtomic
   | mkref : Var -> Var -> hAtomic.
  Definition Atomic := hAtomic.
End HeapAtomics.

(* Module type for HeapAtomics *)
Module Type THeapAtomics
    (Import ht : HeapTypes)
    (Import hp : THeaps ht) <: Atomics.
  Include (HeapAtomics ht hp).
End THeapAtomics.

(* StateTransformers instance for the heap commands. *)
Module HeapStateTransformers
    (Import ht : HeapTypes)
    (Import hp : THeaps ht)
    (Import ha : THeapAtomics ht hp) <: StateTransformers ha.

  Definition idat := hidat.

  (* States are stores or fault *)
  Inductive state : Set :=
    | sOK : store -> state
    | sFAULT : state.

  Definition State := state.

  Definition state_equiv : relation State :=
    fun s1 s2 : state =>
      match s1 with
        | sOK s => match s2 with
           | sOK s0 => s == s0
           | sFAULT => False
           end
        | sFAULT => match s2 with
            | sOK _ => False
            | sFAULT => True
            end
      end.

  Instance state_setoid : Setoid State :=
    {| equiv := state_equiv |}.
   split; repeat intro; unfold state_equiv;
    repeat (match goal with [x : State |- _] => destruct x; simpl in *; intuition end);
    rewr intuition.
  Defined.

  Definition makefp_trans (t : ST (A:=State)) : relation state :=
    fun s s' => match s with
      | sFAULT => s' = sFAULT
      | _ => st_trans t s s'
     end.

  Existing Instance st_morph.

  Instance makefp_morph t : Proper (equiv ==> equiv ==> iff) (makefp_trans t).
   repeat intro.
   destruct x; destruct y; simpl; try rewr intuition.
   destruct x0; destruct y0; intuition; inversion H1.
  Qed.

  Definition STmakefp (t : ST (A:=State)) : ST (A:=State) :=
    {| st_trans := makefp_trans t |}.

  (* Interpretation of atomic commands *)
  Definition interp (a : Atomic) : ST (A:=State) :=
    match a with
    | hidat => stid
    | assn x y => STmakefp (STchoice (fun v => STgchoice (fun s =>
        (vars s y = v, STseq (STeguard (sOK s))
             (STmp match v with
                    | Some vv => sOK (overwrite (svstore x vv) s)
                    | _ => sFAULT
                   end)))))
    | mut_val x v =>
        STmakefp (STchoice (fun l => STgchoice (fun s =>
        (vars s x = l, STseq (STeguard (sOK s))
             (STmp match l with
                    | Some (loc_val ll) =>
                       match heap s ll with
                       | Some _ => sOK (overwrite (slstore ll v) s)
                       | _ => sFAULT end
                    | _ => sFAULT end)))))
    | mut_var x y =>
        STmakefp (STchoice (fun l => STchoice (fun v => (STgchoice (fun s =>
        (vars s x = l /\ vars s y = v, STseq (STeguard (sOK s))
             (STmp match l with
                    | Some (loc_val ll) =>
                       match heap s ll with
                       | Some _ =>
                        match v with
                        | Some vv => sOK (overwrite (slstore ll vv) s)
                        | _ => sFAULT end
                       | _ => sFAULT end
                    | _ => sFAULT end)))))))
    | lu_var y x =>
       STmakefp (STchoice (fun l => STgchoice (fun s =>
        (vars s x = l, STseq (STeguard (sOK s))
            (STmp match l with
                   | Some (loc_val ll) =>
                      match heap s ll with
                      | Some vl => sOK (overwrite (svstore y vl) s)
                      | _ => sFAULT end
                   | _ => sFAULT end)))))
    | mkref x y =>
       STmakefp (STchoice (fun v => STgchoice (fun s =>
        (vars s y = v, STseq (STeguard (sOK s))
            match v with
                   | Some vv => STgchoice (fun l =>
                     (heap s l = None, STmp (sOK
             (overwrite (svstore x (loc_val l)) (overwrite (slstore l vv) s)))))
                   | _ => STmp sFAULT
            end))))
    end.

  (* Identity atomic must have the identity interpretation *)
  Lemma idat_id : st_trans (interp idat) = equiv.
   reflexivity.
  Qed.

End HeapStateTransformers.

Module Type THeapStateTransformers
    (Import ht : HeapTypes)
    (Import hp : THeaps ht)
    (Import ha : THeapAtomics ht hp) <: StateTransformers ha.
Include (HeapStateTransformers ht hp ha).
End THeapStateTransformers.


Require Import Coq.Program.Equality.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.

Ltac clean_exists :=
  repeat match goal with
  | H: existT ?P ?p _ = existT ?P ?p _ |- _ =>
    apply Eqdep.EqdepTheory.inj_pair2 in H
         end;
  subst.

Lemma function_instantiation {X Y: Type} (f g: X -> Y) (x: X):
  f = g -> f x = g x
.
Proof.
  intros; now subst.
Qed.

Section ListAppend.
  Lemma map_app_lift {X Y: Type} (f: X -> Y) (lx: list X) (ly1 ly2: list Y):
    map f lx = ly1 ++ ly2 ->
    exists (lx1 lx2: list X),
      lx = lx1 ++ lx2 /\
      map f lx1 = ly1 /\
      map f lx2 = ly2
  .
  Proof.
    intros; revert lx H; induction ly1; intros.
    - rewrite app_nil_l in H.
      exists nil, lx.
      intuition.
    - destruct lx; simpl in H.
      + discriminate.
      + inversion H; subst.
        apply IHly1 in H2.
        destruct H2 as [lx1 [lx2 [? [? ?]]]].
        exists (x :: lx1), lx2; simpl.
        intuition congruence.
  Qed.

  Lemma app_match_left
    {X: Type}
    (l1 l2 l3 l4: list X)
  :
    length l1 = length l3 ->
    l1 ++ l2 = l3 ++ l4 ->
    l1 = l3
  .
  Proof.
    intros.
    apply (f_equal (firstn (length l1))) in H0.
    repeat rewrite firstn_app in H0.
    replace (length l1 - length l1) with 0%nat in H0 by lia.
    replace (length l1 - length l3) with 0%nat in H0 by lia.
    repeat rewrite firstn_O in H0.
    repeat rewrite app_nil_r in H0.
    rewrite H in H0 at 2.
    now repeat rewrite firstn_all in H0.
  Qed.

  Lemma app_match_right
    {X: Type}
    (l1 l2 l3 l4: list X)
  :
    length l1 = length l3 ->
    l1 ++ l2 = l3 ++ l4 ->
    l2 = l4
  .
  Proof.
    intros.
    apply (f_equal (skipn (length l1))) in H0.
    repeat rewrite skipn_app in H0.
    replace (length l1 - length l1) with 0%nat in H0 by lia.
    replace (length l1 - length l3) with 0%nat in H0 by lia.
    rewrite H in H0 at 2.
    repeat rewrite skipn_all in H0.
    repeat rewrite skipn_O in H0.
    now repeat rewrite app_nil_l in H0.
  Qed.
End ListAppend.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * [Proper] instances for propositional connectives.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

From Coq Require Import Program.Basics.
From Coq Require Import Program.Tactics.
From Mon Require Import SRelation.SMorphisms.

Local Obligation Tactic := try solve [simpl_relation | firstorder auto].

(** Standard instances for [not], [iff] and [impl]. *)

(** Logical negation. *)

Program Instance snot_s_impl_morphism :
  SProper (s_impl s--> s_impl) snot | 1.

Program Instance snot_siff_morphism :
  SProper (siff s++> siff) snot.

(** Logical conjunction. *)

Program Instance ssand_s_s_impl_morphism :
  SProper (s_impl s==> s_impl s==> s_impl) sand | 1.

Program Instance ssand_ssiff_morphism :
  SProper (siff s==> siff s==> siff) sand.

(** Logical disjunction. *)

Program Instance sor_s_impl_morphism :
  SProper (s_impl s==> s_impl s==> s_impl) sor | 1.

Program Instance sor_siff_morphism :
  SProper (siff s==> siff s==> siff) sor.

(** Logical s_implication [s_impl] is a morphism for logical equivalence. *)

Program Instance siff_siff_siff_s_impl_morphism : SProper (siff s==> siff s==> siff) s_impl.

(** Morphisms for quantifiers *)

Program Instance ex_siff_morphism {A : Type} : SProper (pointwise_srelation A siff s==> siff) (@Ex A).

Program Instance ex_s_impl_morphism {A : Type} :
  SProper (pointwise_srelation A s_impl s==> s_impl) (@Ex A) | 1.

Program Instance ex_flip_s_impl_morphism {A : Type} :
  SProper (pointwise_srelation A (flip s_impl) s==> flip s_impl) (@Ex A) | 1.

Program Instance all_siff_morphism {A : Type} :
  SProper (pointwise_srelation A siff s==> siff) (@All A).

Program Instance all_s_impl_morphism {A : Type} :
  SProper (pointwise_srelation A s_impl s==> s_impl) (@All A) | 1.

Program Instance all_flip_s_impl_morphism {A : Type} :
  SProper (pointwise_srelation A (flip s_impl) s==> flip s_impl) (@All A) | 1.

(* Acc Lemmas removed since Acc is not in SProp *)


Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Maps.
Require Import Imp.
Require Import Smallstep.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CPar : com -> com -> com.

Notation "'SKIP'" :=
  CSkip : cimp_scope.
Notation "x '::=' a" :=
  (CAss x a) (at level 60) : cimp_scope.
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity) : cimp_scope.
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity) : cimp_scope.
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (CIf b c1 c2) (at level 80, right associativity) : cimp_scope.
Notation "'PAR' c1 'WITH' c2 'END'" :=
  (CPar c1 c2) (at level 80, right associativity) : cimp_scope.

Local Open Scope cimp_scope.

Inductive cstep : (com * state)  -> (com * state) -> Prop :=
  | CS_AssStep : forall st i a a',
      a / st ==>a a' ->
      (i ::= a) / st ==> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st ==> SKIP / (t_update st i n)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st c1 c2,
      (IFB BTrue THEN c1 ELSE c2 FI) / st ==> c1 / st
  | CS_IfFalse : forall st c1 c2,
      (IFB BFalse THEN c1 ELSE c2 FI) / st ==> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b /st ==>b b' ->
          (IFB b THEN c1 ELSE c2 FI) / st
      ==> (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_While : forall st b c1,
          (WHILE b DO c1 END) / st
      ==> (IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st
  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st ==> c1' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1' WITH c2 END) / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st ==> c2' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1 WITH c2' END) / st'
  | CS_ParDone : forall st,
      (PAR SKIP WITH SKIP END) / st ==> SKIP / st
  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')) : cimp_scope.

Definition cmultistep := multi cstep.

Notation " t '/' st '==>*' t' '/' st' " :=
   (multi cstep  (t,st) (t',st'))
   (at level 40, st at level 39, t' at level 39) : cimp_scope.

Definition par_loop : com :=
  PAR
    Y ::= ANum 1
  WITH
    WHILE BEq (AId Y) (ANum 0) DO
      X ::= APlus (AId X) (ANum 1)
    END
  END.

Example par_loop_example_0:
  exists st',
       par_loop / empty_state  ==>* SKIP / st'
    /\ st' X = 0.
Proof.
  eapply ex_intro. split.
  unfold par_loop.
  eapply multi_step. apply CS_Par1.
    apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity. Qed.

Example par_loop_example_2:
  exists st',
       par_loop / empty_state ==>* SKIP / st'
    /\ st' X = 2.
Proof.
  eapply ex_intro. split.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.

  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfTrue.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_AssStep. apply AS_Plus.
  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
    apply CS_Ass.

  eapply multi_step. apply CS_Par1. apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity.
Qed.

Lemma par_body_n__Sn : forall n st,
  st X = n /\ st Y = 0 ->
  par_loop / st ==>* par_loop / (t_update st X (S n)).
Proof.
  (* FILL IN HERE *) Admitted.

Lemma par_body_n : forall n st,
  st X = 0 /\ st Y = 0 ->
  exists st',
    par_loop / st ==>*  par_loop / st' /\ st' X = n /\ st' Y = 0.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem par_loop_any_X:
  forall n, exists st',
    par_loop / empty_state ==>*  SKIP / st'
    /\ st' X = n.
Proof.
  intros n.
  destruct (par_body_n n empty_state).
    split; unfold t_update; reflexivity.

  rename x into st.
  inversion H as [H' [HX HY]]; clear H.
  exists (t_update st Y 1). split.
  eapply multi_trans with (par_loop,st). apply H'.
  eapply multi_step. apply CS_Par1. apply CS_Ass.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id. rewrite t_update_eq.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  apply multi_refl.

  rewrite t_update_neq. assumption. intro X; inversion X.
Qed.


Require Export Metalib.Metatheory.
Require Import LibTactics.

Require Import Definitions.
Require Import Infrastructure.
Require Import Lemmas.
Require Import Lia.

(* ********************************************************************** *)
(** Weakening (5) *)

Lemma typing_weakening : forall E F G P e T dir,
   typing (E ++ G) P e dir T ->
   wf_env (E ++ F ++ G) ->
   typing (E ++ F ++ G) P e dir T.
Proof with simpl_env;
eauto using
            wf_typ_from_wf_env_typ,
            wf_typ_weakening,
            consist_weakening.
 introv Typ. gen F.
 inductions Typ; introv Ok; eauto.
 - forwards*:  wf_typ_weakening H1.
 - pick fresh x and apply typ_abs.
   lapply (H x); [intros K | auto].
    rewrite <- app_assoc.
    apply (H0 x)...
  - apply typ_tabs with (L := ((((((((L \u fv_ee e) \u fv_tt A) \u dom E) \u dom G) \u dom F) \u
    fv_tt_env E) \u fv_tt_env G) \u fv_tt_env F) );intros.
    lapply (H a); [intros K | auto].
    rewrite <- app_assoc.
    apply (H0 a)...
  - eapply typ_tapp with (A1:= A1); eauto.
    apply* wf_typ_weakening.
  -
    apply* typ_consist.
    apply* consist_weakening.
Qed.

Lemma fv_in_dom: forall G P e dir T,
    typing G P e dir T -> fv_ee e [<=] dom G.
Proof.
  intros G P e dir T H.
  inductions H; simpl; try fsetdec.
  -
    apply binds_In in H0.
    fsetdec.
  -
    pick fresh x for (L \u dom (E) \u fv_ee e).
    assert (Fx : fv_ee (e open_ee_var x) [<=] dom (x ~: A ++ E)).
    { forwards*: H0 x. }
    simpl in Fx.
    assert (Fy : fv_ee e [<=] fv_ee (e open_ee_var x)) by
        eapply fv_ee_open_ee_lower.
    fsetdec.
  -
    pick fresh x for (L \u dom (E) \u fv_ee e).
    assert (Fx : fv_ee (open_te e (t_fvar x)) [<=] dom (x ~tvar ++ E)).
    { forwards*: H0 x. }
    simpl in Fx.
    assert (Fy : fv_ee e [<=] fv_ee (open_te e (t_fvar x))).
    eapply fv_ee_open_te_lower.
    fsetdec.
Qed.

Lemma tfv_in_dom_wft: forall E A,
 wf_typ E A ->
 fv_tt A [<=] dom E.
Proof.
  introv wf.
  inductions wf; simpl; try fsetdec.
  -
  apply binds_In in H.
    fsetdec.
  -
  pick fresh x for (L \u dom (E) \u fv_tt A).
  assert (Fx : fv_tt (open_tt A (t_fvar x)) [<=] dom (x ~tvar ++ E)).
  { forwards*: H0 x. }
  simpl in Fx.
  assert (Fy : fv_tt A [<=] fv_tt (open_tt A (t_fvar x))).
  eapply fv_tt_open_tt_lower.
  fsetdec.
Qed.

Lemma value_no_fv : forall P v dir T,
    typing nil P v dir T -> fv_ee v [<=] {}.
Proof.
  introv Typ.
  pose proof (fv_in_dom nil P v).
  intuition eauto.
Qed.

Lemma value_no_tfv : forall P v dir T,
    typing nil P v dir T -> fv_tt T [<=] {}.
Proof.
  introv Typ.
  forwards*:typing_regular Typ.
  inverts H. inverts H1.
  forwards*: tfv_in_dom_wft H2.
Qed.

Lemma subst_value : forall P v T dir z u,
    typing nil P v dir T -> subst_ee u z v = v.
Proof.
  intros P v dir T z u Typ.
  lets* Fv: value_no_fv Typ.
  forwards*: subst_ee_fresh.
  rewrite Fv.
  fsetdec.
Qed.

Lemma subst_value_ty : forall P v T dir z u,
    typing nil P v dir T -> subst_tt u z T = T.
Proof.
  intros P v dir T z u Typ.
  lets* Fv: value_no_tfv Typ.
  forwards*: subst_tt_fresh.
  rewrite Fv.
  fsetdec.
Qed.

Lemma length_less: forall l n,
 l < S n ->
 l = n \/ l < n.
Proof.
  introv les.
  inverts* les.
Qed.

Lemma nth_eq_last : forall A (l:list A) x d,
  nth (length l) (l ++ x::nil) d = x.
Proof.
  induction l; intros; [ auto | simpl; rewrite IHl; auto ].
Qed.

Lemma sto_ok_value: forall l mu,
 l < length mu ->
 sto_ok mu ->
 value ((store_lookup l mu)).
Proof.
  introv len ok. gen l.
  inductions ok; intros; try solve[inverts len];
  simpl in *.
  destruct l; simpl; eauto.
  forwards*: IHok l.
  lia.
Qed.

Lemma principle_typ_inf: forall P u A,
 value u ->
 typing empty P u Inf A ->
 principle_type u = A.
Proof.
  introv val typ.
  inverts* val; try solve[inverts* typ].
Qed.

Lemma inference_unique : forall G P e A1 A2,
    typing G P e Inf A1 ->
    typing G P e Inf A2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2.
  induction Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards*: binds_unique H0 H5. inverts* H1.
  - (* t_app *)
    forwards * : IHTy1_1 H5.
    inverts* H0. inverts* H;inverts* H2.
  - (* t_all *)
    forwards * : IHTy1 H7.
    inverts* H1. inverts* H0; inverts* H6.
  - forwards * : IHTy1 H2.
    inverts* H.
  - forwards * : IHTy1 H4.
    inverts* H0. inverts H;inverts* H1.
Qed.

(************************************************************************ *)
(** ** Substitution preserves typing (8) *)

Lemma typing_through_subst_ee : forall P U E F x dir T e u,
  typing (F ++ x ~ bind_typ U ++ E) P e dir T ->
  typing E P u Inf U ->
  typing (F ++ E) P (subst_ee x u e) dir T.
Proof with simpl_env;
           eauto 4 using wf_typ_strengthening,
                         wf_env_strengthening,
                         consist_strengthening.
Proof.
  introv TypT TypU.
  remember (F ++ x ~ bind_typ U ++ E) as E'.
  generalize dependent F.
  inductions TypT; intros F EQ; subst; simpl subst_ee...
  -
    destruct (x0 == x); try subst x0.
    +
    analyze_binds_uniq H0.
    injection BindsTacVal; intros; subst.
    rewrite_env (empty ++ F ++ E).
    apply typing_weakening...
    +
    analyze_binds H0.
    eauto using wf_env_strengthening.
    eauto using wf_env_strengthening.
  -
    pick fresh y and apply typ_abs.
    rewrite subst_ee_open_ee_var...
    rewrite <- app_assoc.
    apply H0...
  -
    pick fresh y.
    apply typ_tabs with (L := (((((((((((L \u singleton x) \u fv_te u) \u fv_te e) \u fv_ee u) \u fv_ee e) \u
    fv_tt U) \u fv_tt A) \u dom E) \u dom F) \u
    fv_tt_env E) \u fv_tt_env F));intros.
    rewrite subst_ee_open_te_var...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma consist_through_subst_tt : forall E F Y S T A,
  consist (F ++ Y ~tvar ++ E) S T ->
  wf_typ E A ->
  consist (map (subst_tb Y A) F ++ E) (subst_tt Y A S) (subst_tt Y A T).
Proof with simpl_env;
     eauto 4 using wf_typ_subst_tb, wf_env_subst_tb, wf_typ_weaken_head.
  introv SsubT PsubQ.
  remember (F ++ Y ~tvar ++ E) as G.
  generalize dependent F.
  induction SsubT; intros G EQ; subst; simpl subst_tt...
  -
    destruct (x == Y); subst.
    apply consist_refl...
    apply consist_refl...
    inverts* H0.
    analyze_binds H3...
    apply* wf_typ_var.
    assert (bind_tvar = subst_tb Y A bind_tvar).
    reflexivity. rewrite H0.
    assert(binds x (subst_tb Y A bind_tvar) (map (subst_tb Y A) G)).
    forwards: binds_map_2 BindsTac.
    apply H1.
    forwards: binds_app_2 H1.
    apply H2.
  -
    apply consist_dyn_l...
  -
    apply consist_dyn_r...
  -
    pick fresh X and apply consist_all...
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Y A) (X ~tvar ++ G) ++ E).
    apply H0...
Qed.

Lemma typing_through_subst_te : forall E F Z ph e T P mu dir,
  ph |== mu ->
  typing (F ++ Z~tvar ++ E) ph e dir T ->
  wf_typ E P ->
  typing (map (subst_tb Z P) F ++ E) ph (subst_te Z P e) dir (subst_tt Z P T).
Proof with simpl_env;
           eauto 6 using wf_env_subst_tb,
                         wf_typ_subst_tb,
                         consist_through_subst_tt.
 introv wel TypT TypU.
 remember (F ++ Z~tvar ++ E) as E'.
 generalize dependent F.
 inductions TypT; intros F EQ; subst; simpl subst_te; simpl subst_tt;
 try solve[inverts* H]...
 -
   apply typ_var...
   rewrite (map_subst_tb_id E Z P);
        [ | auto | eapply fresh_mid_tail; eauto ].
   analyze_binds H0...
   forwards*: wf_env_subst_tb H TypU.
   forwards*: wf_env_concat_left_inv H1.
  -
    forwards*: wf_env_subst_tb H TypU.
    forwards*: wf_typ_subst_tb H1 TypU.
    inverts wel. inverts H5.
    rewrite H6 in H0.
    forwards*: H7 H0.
    forwards*:subst_value_ty H5.
    rewrite <- H6 in H0.
    rewrite H8 in *.
    apply typ_loc; eauto.
  -
    pick fresh y and apply typ_abs.
    rewrite subst_te_open_ee_var...
    rewrite_env (map (subst_tb Z P) (y ~ bind_typ A ++ F) ++ E).
    apply H0...
  -
    pick fresh X.
    apply typ_tabs with (L := (union L
    (union (singleton Z)
       (union (fv_te e)
          (union (singleton Z)
             (union (fv_ee e)
                (union (singleton Z)
                   (union (fv_tt P)
                      (union (fv_tt A)
                         (union (dom E)
                            (union (dom F)
                               (union (fv_tt_env E) (fv_tt_env F)))))))))))) );intros.
    rewrite subst_te_open_te_var...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (a ~tvar ++ F) ++ E).
    apply H0...
  -
     rewrite subst_tt_open_tt...
    forwards*: IHTypT.
    inverts H0; simpl in *; eauto.
    eapply typ_tapp...
    eapply typ_tapp ...
Qed.

Lemma typing_subst_simpl_ee : forall P U E x T e u dir,
  typing (x ~ bind_typ U ++ E) P e dir T ->
  typing E P u Inf U ->
  typing E P (subst_ee x u e) dir T.
Proof.
    introv typ1 typ2.
    rewrite_env (nil++E).
    apply* typing_through_subst_ee.
Qed.

Lemma consist_subst_simpl : forall E Y S T A,
  consist (Y ~tvar ++ E) S T ->
  wf_typ E A ->
  consist (E) (subst_tt Y A S) (subst_tt Y A T).
Proof.
  introv con type.
  rewrite_env (map (subst_tb Y A) empty ++E).
  apply* consist_through_subst_tt.
Qed.

Lemma typing_subst_simpl_te : forall ph mu E Z e T P dir,
  ph |== mu ->
  typing (Z~tvar ++ E) ph e dir T ->
  wf_typ E P ->
  typing (E) ph (subst_te Z P e) dir (subst_tt Z P T).
Proof.
  introv wel typ1 typ2.
  rewrite_env (map (subst_tb Z P) empty ++E).
  apply* typing_through_subst_te.
Qed.

Lemma extends_lookup : forall l ST ST',
  l < length ST ->
  extends ST' ST ->
  store_Tlookup l ST' = store_Tlookup l ST.
Proof with auto.
  intros l ST.
  generalize dependent l.
  induction ST as [|a ST2]; intros l ST' Hlen HST'.
  - (* nil *) inversion Hlen.
  - (* cons *) unfold store_Tlookup in *.
    destruct ST'.
    + (* ST' = nil *) inversion HST'.
    + (* ST' = a' :: ST'2 *)
      inversion HST'; subst.
      destruct l as [|l'].
      * (* l = 0 *) auto.
      * (* l = S l' *) simpl. apply IHST2...
        simpl in Hlen; lia.
Qed.

Lemma extends_refl : forall E,
  extends E E.
Proof.
 intros_all~.
 inductions E; eauto.
Qed.

Lemma length_extends : forall l ST ST',
  l < length ST ->
  extends ST' ST ->
  l < length ST'.
Proof with eauto.
  intros. generalize dependent l. induction H0; intros l Hlen.
    - inversion Hlen.
    - simpl in *.
      destruct l; try lia.
        apply lt_n_S. apply IHextends. lia.
Qed.

Lemma extends_wf_typ: forall l P1 P2 E,
 l < length P1 ->
 extends P2 P1 ->
 wf_typ E (store_Tlookup l P1) ->
 wf_typ E (store_Tlookup l P2).
Proof.
  introv len ext wf. gen l E.
  inductions ext; intros; eauto;
  try solve[inverts len]; simpl in *.
  destruct l; simpl; eauto.
  forwards*: IHext l E. lia.
Qed.

Lemma store_weakening : forall G ST ST' t dir T,
  extends ST' ST ->
  typing G ST t dir T ->
  typing G ST' t dir T.
Proof with eauto.
  intros. induction H0; eauto.
  - (* T_Loc *)
    rewrite <- (extends_lookup _ _ ST')...
    apply typ_loc; eauto.
    eapply length_extends...
    forwards*: extends_wf_typ H2.
Qed.

Lemma extends_app : forall ST T,
  extends (ST ++ T) ST.
Proof.
  induction ST; intros T.
  auto.
  simpl. auto.
Qed.

Hint Resolve extends_refl extends_app store_weakening: core.

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

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

Lemma ptype_inf: forall mu P u A,
 P |== mu ->
 pvalue u ->
 typing empty P u Inf A ->
 ptype mu u A.
Proof.
  introv sto pval typ.
  inverts* typ; try solve[inverts* pval].
  inverts sto. inverts H3.
  rewrite H4 in H0.
  forwards*: H5 H0.
  forwards*: sto_ok_value H0 H2.
  forwards*: principle_typ_inf H3.
Qed.

Lemma TypedReduce_preservation: forall P mu v A v' B,
      P |== mu ->
     value v ->
     TypedReduce (v, mu) A ((r_e v'),mu) ->
     typing nil P v Chk B -> typing nil P v' Inf A.
Proof with auto.
  introv well val red typ.
  inductions red; eauto.
  -
    inverts typ. inverts H3.
    + inverts H7.
      forwards*: ptype_inf H4.
      forwards*: ptype_uniq H0 H5.
      inverts* well.
      subst*.
Qed.

Lemma TypedReduce_prv_value: forall v A v' mu,
    value v ->
    type A ->
    TypedReduce (v, mu) A ((r_e v'), mu) -> value v'.
Proof.
  introv Val type Red.
  inductions Red; eauto.
Qed.

Lemma TypeLists_prv_value: forall v A v' B mu,
 value v ->
 type A ->
 type B ->
 TypeLists (v,mu) (A :: B :: nil)%list ((r_e v'), mu)
     ->  value v'.
Proof with auto.
 introv val ty1 ty2 tlist.
 inverts tlist.
 inverts* H5. inverts* H7.
 forwards*: TypedReduce_prv_value H2.
 forwards*: TypedReduce_prv_value H3.
Qed.

Lemma TypeLists_preservation: forall v A0 A v' B mu P,
 P |== mu ->
 type A ->
 type B ->
 value v -> TypeLists (v,mu) (A :: B :: nil)%list ((r_e v'), mu)
     -> typing nil P v Chk A0 -> typing nil P v' Inf B.
Proof with auto.
 introv well ty1 ty2 val tlist typ.
 inverts tlist.
 inverts* H5. inverts* H7.
 forwards*: TypedReduce_prv_value H2.
 forwards*: TypedReduce_preservation H2.
 forwards*: TypedReduce_prv_value H3.
 forwards*: TypedReduce_preservation H3.
Qed.

Lemma sto_ok_app: forall st1 st2,
 sto_ok st1 ->
 sto_ok st2 ->
 sto_ok (st1 ++ st2).
Proof.
  introv ok1 ok2.
  inductions ok1; simpl; eauto.
Qed.

Lemma TypeLists3_preservation: forall v A0 A v' B mu P,
 P |== mu ->
 type A ->
 type B ->
 value v -> TypeLists (v,mu) (A :: t_dyn :: B :: nil)%list ((r_e v'), mu)
     -> typing nil P v Chk A0 -> typing nil P v' Inf B.
Proof with auto.
 introv well ty1 ty2 val tlist typ.
 inverts tlist.
 inverts* H5. inverts* H7. inverts H8.
 forwards*: TypedReduce_prv_value H2.
 forwards*: TypedReduce_preservation H2.
 forwards*: TypedReduce_prv_value H3.
 forwards*: TypedReduce_preservation H3.
 forwards*: TypedReduce_prv_value H4.
 forwards*: TypedReduce_preservation H4.
Qed.

Lemma TypeLists2_preservation: forall v A0 A v' B mu P,
 P |== mu ->
 type A ->
 type B ->
 value v -> TypeLists (v,mu) (A :: B :: nil)%list ((r_e v'), mu)
     -> typing nil P v Chk A0 -> typing nil P v' Inf B.
Proof with auto.
 introv well ty1 ty2 val tlist typ.
 inverts tlist.
 inverts* H5. inverts* H7.
 forwards*: TypedReduce_prv_value H2.
 forwards*: TypedReduce_preservation H2.
 forwards*: TypedReduce_prv_value H3.
 forwards*: TypedReduce_preservation H3.
Qed.

Lemma add_sym : forall m,
 1 + m = m + 1.
Proof.
  introv.
  inductions m; intros; eauto.
  simpl.
  rewrite <- IHm.
  simpl.
  reflexivity.
Qed.

Lemma store_well_typed_app : forall ST st t1 T1,
  value t1 ->
  sto_typing ST st ->
  typing nil  ST t1 Inf T1 ->
  sto_typing (ST ++ T1::nil) (st ++ t1::nil).
Proof with auto.
  intros.
  unfold sto_typing in *.
  destruct H0. destruct H2.
  rewrite app_length. simpl.
  rewrite app_length. simpl.
  split;eauto.
  - apply sto_ok_app;eauto.
  - (* types match. *)
    split;eauto.
    intros l Hl.
    unfold store_lookup, store_Tlookup.
    apply le_lt_eq_dec in Hl; destruct Hl as [Hlt | Heq].
    + (* l < length st *)
      rewrite !app_nth1; try solve[lia].
      * apply store_weakening with ST. apply extends_app.
        forwards*: H3. lia.
    + (* l = length st *)
      assert(1 + length st = S (length st)).
      simpl;eauto.
      rewrite add_sym in H4.
      rewrite H4 in *.
      injection Heq as Heq; subst.
      rewrite app_nth2; try lia.
      rewrite <- H2.
      rewrite minus_diag. simpl.
      apply store_weakening with ST...
      rewrite app_nth2; [|lia].
      rewrite minus_diag. simpl. assumption.
Qed.

Lemma length_replace : forall A n x (l:list A),
  length (replace n x l) = length l.
Proof with auto.
  intros A n x l. generalize dependent n.
  induction l; intros n.
    destruct n...
    destruct n...
      simpl. rewrite IHl...
Qed.

Lemma lookup_replace_eq : forall l t st,
  l < length st ->
  store_lookup l (replace l t st) = t.
Proof with auto.
  intros l t st.
  unfold store_lookup.
  generalize dependent l.
  induction st as [|t' st']; intros l Hlen.
  - (* st =  *)
   inversion Hlen.
  - (* st = t' :: st' *)
    destruct l; simpl...
    apply IHst'. simpl in Hlen. lia.
Qed.

Lemma replace_nil : forall A n (x:A),
  replace n x nil = nil.
Proof.
  destruct n; auto.
Qed.

Lemma lookup_replace_neq : forall l1 l2 t st,
  l1 <> l2 ->
  store_lookup l1 (replace l2 t st) = store_lookup l1 st.
Proof with auto.
  unfold store_lookup.
  induction l1 as [|l1']; intros l2 t st Hneq.
  - (* l1 = 0 *)
    destruct st.
    + (* st =  *) rewrite replace_nil...
    + (* st = _ :: _ *) destruct l2... contradict Hneq...
  - (* l1 = S l1' *)
    destruct st as [|t2 st2].
    + (* st =  *) destruct l2...
    + (* st = t2 :: st2 *)
      destruct l2...
      simpl; apply IHl1'...
Qed.

Lemma replace_sto_ok : forall l v st,
 l < length st ->
 value v ->
 sto_ok st ->
 sto_ok (replace l v st).
Proof.
  introv len val ok. gen l v.
  inductions ok; intros;
  try solve[inverts len];
  simpl in *.
  destruct l; simpl; eauto.
  apply sto_ok_push; auto.
  forwards*: IHok l val. lia.
Qed.

Lemma assign_pres_store_typing : forall ST st l t,
  l < length st ->
  value t ->
  sto_typing ST st ->
  typing nil ST t Inf (store_Tlookup l ST) ->
  sto_typing ST (replace l t st).
Proof with auto.
  introv  Hlen val HST Ht.
  inverts HST. inverts H0.
  unfold sto_typing.
  split.
  forwards*: replace_sto_ok Hlen val.
  split.
  rewrite length_replace...
  intros l' Hl'.
  destruct (l' == l).
  - (* l' = l *)
    inverts e.
    rewrite lookup_replace_eq...
  - (* l' <> l *)
    rewrite lookup_replace_neq...
    rewrite length_replace in Hl'.
    apply H2...
Qed.

Theorem preservation : forall P mu mu' e e' dir T,
  P |== mu ->
  typing nil P e dir T ->
  step (e,mu) ((r_e e'), mu') ->
  exists P',
  extends P' P /\
  typing nil P' e' dir T /\
  P' |== mu'.
Proof with eauto.
  introv well Typ Red. lets Typ': Typ. gen mu mu' e'.
  inductions Typ; introv well Red.
  - (* var *)
    inverts* Red; try solve[destruct F in H1; unfold fill in H1; inverts* H1];
    try solve[inverts* H6].
  - (* lit *)
    inverts* Red; try solve[destruct F in H0; unfold fill in H0; inverts* H0];
    try solve[inverts* H6].
    inverts* H6.
    exists* P; split*.
  -
    inverts* Red;
    try solve[destruct F in H0; unfold fill in H0;
    inverts* H0].
    inverts* H6.
    exists* P.
  -
    inverts* Red;
    try solve[destruct F in H2; unfold fill in H2;
    inverts* H2].
    exists* P; split*. split*.
    inverts well. inverts H3.
    rewrite H4 in H0.
    forwards*: H5 H0.
    forwards*: sto_ok_value H6.
    forwards*: principle_typ_inf H3.
    inverts H8.
    rewrite H10.
    apply typ_anno; eauto.
  - (* app *)
    inverts Red; try solve[inverts* H5].
    +
      destruct F; unfold fill in H0; inverts* H0; simpl in *.
      forwards*: IHTyp1 H5.
      inverts* H0.
      exists* x.
      forwards*: IHTyp2 H5.
      inverts* H0.
      exists* x.
    + inverts Typ1.
      inverts H7.
      inverts H3. inverts H1.
      inverts H8; inverts H.
      forwards*: TypeLists2_preservation H9.
      inverts H0.
      exists* P. split*. split*.
      apply~ typ_anno.
      apply typ_consist with (A := B1); eauto.
      apply~ typ_anno.
      pick_fresh x.
      rewrite* (@subst_ee_intro x).
      apply* typing_subst_simpl_ee.
      forwards*: TypeLists2_preservation H9.
      inverts H0. inverts H2.
      exists* P. split*. split*.
      apply~ typ_anno.
      apply typ_consist with (A := B1); eauto.
      apply~ typ_anno.
      pick_fresh x.
      rewrite* (@subst_ee_intro x).
      apply* typing_subst_simpl_ee.
  - (* abs *)
    inverts* Red; try solve[destruct F in H1; unfold fill in H1; inverts* H1].
    inverts* H7.
    exists* P.
  - (* anno *)
    inverts* Red; try solve[destruct F in H; unfold fill in H; inverts* H];
    try solve[inverts* H4].
    +
      forwards*: IHTyp H5.
      inverts* H.
    +
      forwards*: typing_regular Typ.
     forwards*: TypedReduce_preservation H6.
  - (* tabs *)
    inverts* Red;try solve[destruct F; unfold fill in H1; inverts* H1].
    inverts* H7.
    exists* P.
  - (* tapp *)
    inverts* Red; try solve[inverts* H6].
    +
    destruct F; unfold fill in H1; inverts* H1; simpl in *.
    forwards*: IHTyp H6.
    inverts* H1.
    +
    inverts Typ. inverts* H5. inverts* H2.
    inverts H3. inverts H5. inverts H6.
    inverts H7; inverts H1; inverts H0.
    *
    exists P. split*. split*.
    eapply typ_anno; eauto.
    apply typ_consist with (A := (open_tt A0 A)); eauto.
    pick_fresh Y.
    rewrite* (@subst_tt_intro Y).
    assert( (open_tt B A) = (subst_tt Y A (B open_tt_var Y))).
    rewrite* (@subst_tt_intro Y).
    rewrite H0.
    apply* consist_subst_simpl.
    eapply typ_anno; eauto.
    pick_fresh X.
    rewrite* (@subst_te_intro X).
    rewrite* (@subst_tt_intro X).
    apply* typing_subst_simpl_te.
    *
    exists P. split*. split*.
    eapply typ_anno; eauto.
    apply typ_consist with (A := (open_tt A0 A)); eauto.
    forwards*: wf_typ_open A H5.
    eapply typ_anno; eauto.
    pick_fresh X.
    rewrite* (@subst_te_intro X).
    rewrite* (@subst_tt_intro X).
    apply* typing_subst_simpl_te.
  - forwards*: IHTyp Red.
    lets(P'&extend&rtyp&rwell): H0.
    exists* P'.
  -
    inverts* Red; try solve[destruct F in H; unfold fill in H; inverts* H];
    try solve[inverts* H4].
    destruct F; unfold fill in H; simpl in *;inverts* H.
    forwards*: IHTyp H4.
    lets(P'&extend&rtyp&rwell): H.
    exists* P'.
    lets well': well.
    inverts well. inverts H0.
    exists*(P++A::nil).
    split*.
    split*.
    replace (t_ref A)
    with (t_ref (store_Tlookup (length mu) (P ++ A :: nil))).
    apply typ_loc; eauto.
    rewrite <- H1.
    rewrite app_length. simpl. lia.
    unfold store_Tlookup.
    rewrite <- H1.
    rewrite nth_eq_last; eauto.
    unfold store_Tlookup.
    rewrite <- H1.
    rewrite nth_eq_last; eauto.
    apply store_well_typed_app; assumption.
  - inverts* Red;
    try solve[inverts* H5].
    +
    destruct F; unfold fill in H0; simpl in *;inverts* H0.
    forwards*: IHTyp H5.
    lets(P'&extend&rtyp&rwell): H0.
    exists* P'.
    +
    inverts* Typ. inverts H4.
    inverts H1. inverts H5;
    inverts H. inverts H0.
    exists* P. split*. split*.
    apply typ_anno; eauto.
    inverts well. inverts H0.
    rewrite H1 in H6.
    forwards*: H2 H6.
    exists* P. split*. split*.
    apply typ_anno; eauto.
    inverts well. inverts H1.
    rewrite H2 in H6.
    forwards*: H5 H6.
  -
    inverts* Red;
    try solve[inverts* H5].
    +
    destruct F; unfold fill in H0; simpl in *;inverts* H0.
    forwards*: IHTyp1 H5.
    lets(P'&extend&rtyp&rwell): H0.
    exists* P'.
    forwards*: IHTyp2 H5.
    lets(P'&extend&rtyp&rwell): H0.
    inverts H3.
    exists* P'.
    +
    inverts Typ1. inverts H3. inverts H1.
    lets well':well.
    inverts well. inverts H2.
    rewrite H7 in H4.
    forwards*: H10 H4.
    exists P. split*. split*.
    forwards*: length_replace l0 v2' mu.
    forwards*: typing_regular Typ2.
    forwards*: principle_typ_inf H2.
    forwards*: sto_ok_value l0 H5.
    rewrite <- H14 in H11.
    forwards*: type_from_wf_typ A.
    forwards*: type_from_wf_typ H11.
    inverts H9; inverts* H.
    --
    inverts H15. inverts H0.
    forwards: TypeLists_preservation well' H9 H16 H8; auto.
    apply Typ2.
    rewrite H14 in H.
    forwards*: assign_pres_store_typing H.
    forwards*: TypeLists_prv_value H8.
    --
    forwards: TypeLists_preservation well' H15 H16 H8; auto.
    apply Typ2.
    rewrite H14 in H.
    forwards*: assign_pres_store_typing H.
    forwards*: TypeLists_prv_value H8.
Qed.

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

Lemma FL_decidable:forall A,
 FL A \/ not(FL A).
Proof.
  introv.
  inductions A; try solve[right;unfold not;intros nt; inverts* nt];
  try solve[left*].
Qed.

Lemma pvalue_ss_s: forall u,
 pvalue u -> ssvalue u \/ svalue u.
Proof.
  introv pval.
  inductions pval; eauto.
Qed.

Lemma TypedReduce_progress: forall P v B A mu,
   P |== mu ->
   wf_typ empty A ->
    value v -> typing nil P v Inf B ->
    exists r, TypedReduce (v,mu) A (r, mu).
Proof.
  introv well ty Val Typ.
  inverts Val. inverts Typ.
  - inverts H4.
    forwards*: ptype_inf H2.
    destruct(consist_decidable nil A0 A); eauto.
    inverts* H4.
Qed.

Lemma Typelist3_progress: forall P v B A mu,
    P |== mu ->
    wf_typ empty A ->
    wf_typ empty B ->
    value v -> typing nil P v Chk A ->
    exists r, TypeLists (v,mu) (A :: t_dyn :: B :: nil)%list (r,mu).
Proof.
  introv well ty1 ty2 Val Typ.
  inverts Typ.
  forwards*: TypedReduce_progress A Val H0. inverts H1.
  destruct x; eauto.
  forwards*: TypedReduce_preservation H2.
  forwards*: TypedReduce_prv_value H2.
  forwards*: TypedReduce_progress t_dyn H1. inverts H4.
  destruct x; eauto.
  forwards*: TypedReduce_preservation H5.
  forwards*: TypedReduce_prv_value H5.
  forwards*: TypedReduce_progress B H6 H4. inverts H7.
  destruct x; eauto.
Qed.

Lemma Typelist_progress: forall P v B0 B A mu,
    P |== mu ->
    wf_typ empty A ->
    wf_typ empty B ->
    value v -> typing nil P v Inf B0 ->
    exists r, TypeLists (v,mu) (A :: B :: nil)%list (r, mu).
Proof.
  introv well ty1 ty2 Val Typ.
  forwards*: TypedReduce_progress A Val Typ. inverts H.
  destruct x; eauto.
  forwards*: TypedReduce_preservation H0.
  forwards*: TypedReduce_prv_value H0.
  forwards*: TypedReduce_progress B H1 H. inverts H2.
  destruct x; eauto.
Qed.

Lemma fill_appl : forall e1 e2,
  (e_app e1 e2) = (fill (appCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma fill_appr : forall e1 e2,
  (e_app e1 e2) = (fill (appCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma fill_setl : forall e1 e2,
  (e_set e1 e2) = (fill (setCtxL e2) e1).
Proof.
  intros. eauto.
Qed.

Lemma fill_setr : forall e1 e2,
  (e_set e1 e2) = (fill (setCtxR e1) e2).
Proof.
  intros. eauto.
Qed.

Lemma fill_ref : forall e,
  (e_ref e) = (fill (refCtx) e).
Proof.
  intros. eauto.
Qed.

Lemma fill_get : forall e,
  (e_get e) = (fill (getCtx) e).
Proof.
  intros. eauto.
Qed.

Lemma fill_tapp : forall e1 A,
  (e_tapp e1 A) = (fill (tappCtx A) e1).
Proof.
  intros. eauto.
Qed.

Lemma pvalue_decidable: forall e,
 expr e -> pvalue e \/ not (pvalue e).
Proof.
  introv exp.
  inductions exp; try
  solve[right; unfold not; intros nt; inverts* nt];
  try solve[left*].
Qed.

Lemma value_decidable: forall e,
 expr e -> value e \/ not (value e).
Proof.
  introv exp.
  inductions exp; try
  solve[right; unfold not; intros nt; inverts* nt].
  forwards*: pvalue_decidable exp.
  inverts* H0; try
  solve[right; unfold not; intros nt; inverts* nt].
Qed.

Lemma pattern_type_abs: forall A B,
 type A ->
 pattern_abs A B ->
 type B.
Proof.
  introv ty pa.
  inverts* pa; eauto.
Qed.

Lemma pattern_type_all: forall A B,
 type A ->
 pattern_all A B ->
 type B.
Proof.
  introv ty pa.
  inverts pa.
  inverts ty.
  pick fresh x and apply type_all; eauto.
  pick fresh x and apply type_all; eauto.
Qed.

Lemma pattern_type_ref: forall A B,
 type A ->
 pattern_ref A B ->
 type B.
Proof.
  introv ty pa.
  inverts* pa; eauto.
Qed.

Lemma progress : forall P mu e dir T,
  P |== mu ->
  typing nil P e dir T ->
  value e \/ exists r mu', step (e, mu) (r, mu').
Proof.
  introv wel Typ.
  lets Typ': Typ.
  inductions Typ;
    try solve [left*];
    try solve [right*];
    try solve [inverts* wel];
    try solve [inverts* H0]; eauto.
  -
    right.
    lets* [Val1 | [e1' Red1]]: IHTyp1.
    lets* [Val2 | [e2' Red2]]: IHTyp2.
    +
    inverts Val1. inverts Typ1.
    inverts H5.
    forwards*: ptype_inf H3.
    destruct(consist_decidable empty A0 (t_arrow t_dyn t_dyn)); eauto.
    inverts H5.
    *
    inverts* H0; try solve[inverts* H4;inverts* H7].
    forwards*: typing_regular H3. destructs~ H0.
    inverts H3. inverts H9.
    forwards*: pattern_type_abs H.
    lets wel': wel.
    inverts wel.
    forwards*: typing_regular Typ2. destructs~ H11.
    inverts Typ2.
    forwards*: Typelist_progress wel' H15 H12 H18.
    inverts H19.
    destruct x; eauto.
    *
    inverts H; inverts H2;
    try solve[exfalso; apply H7; eauto].
    inverts wel.
    exists*.
    +
    inverts* Red2.
    rewrite fill_appr.  destruct e2'; exists*.
    +
    inverts* Red1.
    rewrite fill_appl. destruct e1'; exists*.
  -
    right.
    inverts wel.
    forwards*: typing_regular Typ'.
    exists*.
  -
    forwards*: IHTyp Typ. inverts H.
    +
    inverts Typ.
    forwards*: TypedReduce_progress A mu H1.
    inverts wel.
    inverts* H2.
    +
    destruct(value_decidable (e_anno e A)); eauto.
    inverts wel.
    inverts* H0. inverts* H3.
    destruct x; eauto.
  -
    right.
    inverts wel.
    forwards*: typing_regular Typ'.
    exists*.
  -
    right.
    lets* [Val | [e' Red]]: IHTyp.
    +
    inverts Val. inverts Typ.
    inverts H6.
    forwards: ptype_inf wel H4. auto.
    assert(wf_typ empty (t_all t_dyn)).
    pick fresh x and apply wf_typ_all; eauto.
    destruct(consist_decidable empty A0 (t_all t_dyn)); auto.
    inverts H7.
    *
    inverts H1; try solve[inverts H5;inverts* H9].
    forwards*: typing_regular H4. destructs~ H1.
    inverts H4. inverts H11.
    forwards*: pattern_type_all H0.
    *
    forwards*: typing_regular H4. destructs~ H7.
    inverts H0; inverts H3;
    try solve[exfalso; apply H9; eauto].
    inverts H11.
    exfalso; apply H9.
    pick fresh x.
    apply consist_all with (L :=union L
    (union L0
       (union (fv_te u)
          (union (fv_ee u)
             (union (fv_tt A) (union (fv_tt B) (fv_tt A1))))))); intros;eauto.
    exists.
    eapply step_tappd; eauto.
    +
    inverts Red.
    rewrite fill_tapp.  destruct e'; exists*.
  -
    right.
    lets* [Val | [e' Red]]: IHTyp.
    + inverts* wel.
    +
    inverts* Red.
    rewrite fill_ref.  destruct e'; exists*.
  -
    right.
    lets* [Val | [e' Red]]: IHTyp.
    +
    inverts Val; inverts Typ.
    inverts H5.
    forwards*: ptype_inf H3.
    destruct(consist_decidable empty A0 (t_ref t_dyn)); eauto.
    inverts H5.
    *
    inverts* H0; try solve[inverts* H4;inverts* H7].
    forwards*: typing_regular H3. destructs~ H0.
    inverts H3. inverts H8.
    forwards*: pattern_type_ref H.
    inverts wel.
    exists. apply step_get; eauto.
    *
    inverts H; inverts H2;
    try solve[exfalso; apply H7; eauto].
    inverts wel.
    exists*.
    +
    inverts Red.
    rewrite fill_get. destruct e'; exists*.
  -
   right.
   lets* [Val1 | [e1' Red1]]: IHTyp1.
   lets* [Val2 | [e2' Red2]]: IHTyp2.
   +
     inverts Typ1; inverts Val1.
     inverts H0.
    forwards*: ptype_inf H2.
    destruct(consist_decidable empty A0 (t_ref t_dyn)); eauto.
    inverts H5.
    *
    inverts* H3; try solve[inverts* H2;inverts* H7].
    forwards*: typing_regular H2. destructs~ H3.
    inverts H2. inverts H8.
    forwards*: pattern_type_ref H.
    lets wel': wel.
    inverts wel.
    inverts H9. rewrite H13 in *.
    forwards*: sto_ok_value H8.
    inverts Typ2.
    forwards*: consist_regular H16.
    destructs~ H18.
    forwards*: Typelist_progress wel' H20 H14 H17.
    inverts H21.
    inverts H0.
    destruct x; eauto.
    exists.
    eapply step_set; eauto.
    *
    inverts H; inverts H1;
    try solve[exfalso; apply H7; eauto].
    inverts wel.
    exists*.
   +
     inverts Red2.
     rewrite fill_setr.
    destruct e2'; exists*.
   +
     inverts Red1.
     forwards*: typing_regular Typ2.
    rewrite fill_setl. destruct e1'; exists*.
Qed.


From Hammer Require Import Hammer.

Require Import NZAxioms NZMulOrder.

Module Type Sqrt (Import A : Typ).
Parameter Inline sqrt : t -> t.
End Sqrt.

Module Type SqrtNotation (A : Typ)(Import B : Sqrt A).
Notation "√ x" := (sqrt x) (at level 6).
End SqrtNotation.

Module Type Sqrt' (A : Typ) := Sqrt A <+ SqrtNotation A.

Module Type NZSqrtSpec (Import A : NZOrdAxiomsSig')(Import B : Sqrt' A).
Axiom sqrt_spec : forall a, 0<=a -> √a * √a <= a < S (√a) * S (√a).
Axiom sqrt_neg : forall a, a<0 -> √a == 0.
End NZSqrtSpec.

Module Type NZSqrt (A : NZOrdAxiomsSig) := Sqrt A <+ NZSqrtSpec A.
Module Type NZSqrt' (A : NZOrdAxiomsSig) := Sqrt' A <+ NZSqrtSpec A.

Module Type NZSqrtProp
(Import A : NZOrdAxiomsSig')
(Import B : NZSqrt' A)
(Import C : NZMulOrderProp A).

Local Notation "a ²" := (a*a) (at level 5, no associativity, format "a ²").

Lemma sqrt_spec_nonneg : forall b,
b² < (S b)² -> 0 <= b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_spec_nonneg".
intros b LT.
destruct (le_gt_cases 0 b) as [Hb|Hb]; trivial. exfalso.
assert ((S b)² < b²).
rewrite mul_succ_l, <- (add_0_r b²).
apply add_lt_le_mono.
apply mul_lt_mono_neg_l; trivial. apply lt_succ_diag_r.
now apply le_succ_l.
order.
Qed.

Lemma sqrt_nonneg : forall a, 0<=√a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_nonneg".
intros. destruct (lt_ge_cases a 0) as [Ha|Ha].
now rewrite (sqrt_neg _ Ha).
apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order.
Qed.

Lemma sqrt_unique : forall a b, b² <= a < (S b)² -> √a == b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_unique".
intros a b (LEb,LTb).
assert (Ha : 0<=a) by (transitivity (b²); trivial using square_nonneg).
assert (Hb : 0<=b) by (apply sqrt_spec_nonneg; order).
assert (Ha': 0<=√a) by now apply sqrt_nonneg.
destruct (sqrt_spec a Ha) as (LEa,LTa).
assert (b <= √a).
apply lt_succ_r, square_lt_simpl_nonneg; [|order].
now apply lt_le_incl, lt_succ_r.
assert (√a <= b).
apply lt_succ_r, square_lt_simpl_nonneg; [|order].
now apply lt_le_incl, lt_succ_r.
order.
Qed.

Instance sqrt_wd : Proper (eq==>eq) sqrt.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_wd".
intros x x' Hx.
destruct (lt_ge_cases x 0) as [H|H].
rewrite 2 sqrt_neg; trivial. reflexivity.
now rewrite <- Hx.
apply sqrt_unique. rewrite Hx in *. now apply sqrt_spec.
Qed.

Lemma sqrt_spec_alt : forall a, 0<=a -> exists r,
a == (√a)² + r /\ 0 <= r <= 2*√a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_spec_alt".
intros a Ha.
destruct (sqrt_spec _ Ha) as (LE,LT).
destruct (le_exists_sub _ _ LE) as (r & Hr & Hr').
exists r.
split. now rewrite add_comm.
split. trivial.
apply (add_le_mono_r _ _ (√a)²).
rewrite <- Hr, add_comm.
generalize LT. nzsimpl'. now rewrite lt_succ_r, add_assoc.
Qed.

Lemma sqrt_unique' : forall a b c, 0<=c<=2*b ->
a == b² + c -> √a == b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_unique'".
intros a b c (Hc,H) EQ.
apply sqrt_unique.
rewrite EQ.
split.
rewrite <- add_0_r at 1. now apply add_le_mono_l.
nzsimpl. apply lt_succ_r.
rewrite <- add_assoc. apply add_le_mono_l.
generalize H; now nzsimpl'.
Qed.

Lemma sqrt_square : forall a, 0<=a -> √(a²) == a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_square".
intros a Ha.
apply sqrt_unique' with 0.
split. order. apply mul_nonneg_nonneg; order'. now nzsimpl.
Qed.

Lemma sqrt_pred_square : forall a, 0<a -> √(P a²) == P a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_pred_square".
intros a Ha.
apply sqrt_unique.
assert (EQ := lt_succ_pred 0 a Ha).
rewrite EQ. split.
apply lt_succ_r.
rewrite (lt_succ_pred 0).
assert (0 <= P a) by (now rewrite <- lt_succ_r, EQ).
assert (P a < a) by (now rewrite <- le_succ_l, EQ).
apply mul_lt_mono_nonneg; trivial.
now apply mul_pos_pos.
apply le_succ_l.
rewrite (lt_succ_pred 0). reflexivity. now apply mul_pos_pos.
Qed.

Lemma sqrt_le_mono : forall a b, a <= b -> √a <= √b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_le_mono".
intros a b Hab.
destruct (lt_ge_cases a 0) as [Ha|Ha].
rewrite (sqrt_neg _ Ha). apply sqrt_nonneg.
assert (Hb : 0 <= b) by order.
destruct (sqrt_spec a Ha) as (LE,_).
destruct (sqrt_spec b Hb) as (_,LT).
apply lt_succ_r.
apply square_lt_simpl_nonneg; try order.
now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
Qed.

Lemma sqrt_lt_cancel : forall a b, √a < √b -> a < b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_lt_cancel".
intros a b H.
destruct (lt_ge_cases b 0) as [Hb|Hb].
rewrite (sqrt_neg b Hb) in H; generalize (sqrt_nonneg a); order.
destruct (lt_ge_cases a 0) as [Ha|Ha]; [order|].
destruct (sqrt_spec a Ha) as (_,LT).
destruct (sqrt_spec b Hb) as (LE,_).
apply le_succ_l in H.
assert ((S (√a))² <= (√b)²).
apply mul_le_mono_nonneg; trivial.
now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
order.
Qed.

Lemma sqrt_le_square : forall a b, 0<=a -> 0<=b -> (b²<=a <-> b <= √a).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_le_square".
intros a b Ha Hb. split; intros H.
rewrite <- (sqrt_square b); trivial.
now apply sqrt_le_mono.
destruct (sqrt_spec a Ha) as (LE,LT).
transitivity (√a)²; trivial.
now apply mul_le_mono_nonneg.
Qed.

Lemma sqrt_lt_square : forall a b, 0<=a -> 0<=b -> (a<b² <-> √a < b).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_lt_square".
intros a b Ha Hb. split; intros H.
destruct (sqrt_spec a Ha) as (LE,_).
apply square_lt_simpl_nonneg; try order.
rewrite <- (sqrt_square b Hb) in H.
now apply sqrt_lt_cancel.
Qed.

Lemma sqrt_0 : √0 == 0.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_0".
rewrite <- (mul_0_l 0) at 1. now apply sqrt_square.
Qed.

Lemma sqrt_1 : √1 == 1.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_1".
rewrite <- (mul_1_l 1) at 1. apply sqrt_square. order'.
Qed.

Lemma sqrt_2 : √2 == 1.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_2".
apply sqrt_unique' with 1. nzsimpl; split; order'. now nzsimpl'.
Qed.

Lemma sqrt_pos : forall a, 0 < √a <-> 0 < a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_pos".
intros a. split; intros Ha. apply sqrt_lt_cancel. now rewrite sqrt_0.
rewrite <- le_succ_l, <- one_succ, <- sqrt_1. apply sqrt_le_mono.
now rewrite one_succ, le_succ_l.
Qed.

Lemma sqrt_lt_lin : forall a, 1<a -> √a<a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_lt_lin".
intros a Ha. rewrite <- sqrt_lt_square; try order'.
rewrite <- (mul_1_r a) at 1.
rewrite <- mul_lt_mono_pos_l; order'.
Qed.

Lemma sqrt_le_lin : forall a, 0<=a -> √a<=a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_le_lin".
intros a Ha.
destruct (le_gt_cases a 0) as [H|H].
setoid_replace a with 0 by order. now rewrite sqrt_0.
destruct (le_gt_cases a 1) as [H'|H'].
rewrite <- le_succ_l, <- one_succ in H.
setoid_replace a with 1 by order. now rewrite sqrt_1.
now apply lt_le_incl, sqrt_lt_lin.
Qed.

Lemma sqrt_mul_below : forall a b, √a * √b <= √(a*b).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_mul_below".
intros a b.
destruct (lt_ge_cases a 0) as [Ha|Ha].
rewrite (sqrt_neg a Ha). nzsimpl. apply sqrt_nonneg.
destruct (lt_ge_cases b 0) as [Hb|Hb].
rewrite (sqrt_neg b Hb). nzsimpl. apply sqrt_nonneg.
assert (Ha':=sqrt_nonneg a).
assert (Hb':=sqrt_nonneg b).
apply sqrt_le_square; try now apply mul_nonneg_nonneg.
rewrite mul_shuffle1.
apply mul_le_mono_nonneg; try now apply mul_nonneg_nonneg.
now apply sqrt_spec.
now apply sqrt_spec.
Qed.

Lemma sqrt_mul_above : forall a b, 0<=a -> 0<=b -> √(a*b) < S (√a) * S (√b).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_mul_above".
intros a b Ha Hb.
apply sqrt_lt_square.
now apply mul_nonneg_nonneg.
apply mul_nonneg_nonneg.
now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
now apply lt_le_incl, lt_succ_r, sqrt_nonneg.
rewrite mul_shuffle1.
apply mul_lt_mono_nonneg; trivial; now apply sqrt_spec.
Qed.

Lemma sqrt_succ_le : forall a, 0<=a -> √(S a) <= S (√a).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_succ_le".
intros a Ha.
apply lt_succ_r.
apply sqrt_lt_square.
now apply le_le_succ_r.
apply le_le_succ_r, le_le_succ_r, sqrt_nonneg.
rewrite <- (add_1_l (S (√a))).
apply lt_le_trans with (1²+(S (√a))²).
rewrite mul_1_l, add_1_l, <- succ_lt_mono.
now apply sqrt_spec.
apply add_square_le. order'. apply le_le_succ_r, sqrt_nonneg.
Qed.

Lemma sqrt_succ_or : forall a, 0<=a -> √(S a) == S (√a) \/ √(S a) == √a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_succ_or".
intros a Ha.
destruct (le_gt_cases (√(S a)) (√a)) as [H|H].
right. generalize (sqrt_le_mono _ _ (le_succ_diag_r a)); order.
left. apply le_succ_l in H. generalize (sqrt_succ_le a Ha); order.
Qed.

Lemma sqrt_eq_succ_iff_square : forall a, 0<=a ->
(√(S a) == S (√a) <-> exists b, 0<b /\ S a == b²).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_eq_succ_iff_square".
intros a Ha. split.
intros EQ. exists (S (√a)).
split. apply lt_succ_r, sqrt_nonneg.
generalize (proj2 (sqrt_spec a Ha)). rewrite <- le_succ_l.
assert (Ha' : 0 <= S a) by now apply le_le_succ_r.
generalize (proj1 (sqrt_spec (S a) Ha')). rewrite EQ; order.
intros (b & Hb & H).
rewrite H. rewrite sqrt_square; try order.
symmetry.
rewrite <- (lt_succ_pred 0 b Hb). f_equiv.
rewrite <- (lt_succ_pred 0 b²) in H. apply succ_inj in H.
now rewrite H, sqrt_pred_square.
now apply mul_pos_pos.
Qed.

Lemma sqrt_add_le : forall a b, √(a+b) <= √a + √b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.sqrt_add_le".
assert (AUX : forall a b, a<0 -> √(a+b) <= √a + √b).
intros a b Ha. rewrite (sqrt_neg a Ha). nzsimpl.
apply sqrt_le_mono.
rewrite <- (add_0_l b) at 2.
apply add_le_mono_r; order.
intros a b.
destruct (lt_ge_cases a 0) as [Ha|Ha]. now apply AUX.
destruct (lt_ge_cases b 0) as [Hb|Hb].
rewrite (add_comm a), (add_comm (√a)); now apply AUX.
assert (Ha':=sqrt_nonneg a).
assert (Hb':=sqrt_nonneg b).
rewrite <- lt_succ_r.
apply sqrt_lt_square.
now apply add_nonneg_nonneg.
now apply lt_le_incl, lt_succ_r, add_nonneg_nonneg.
destruct (sqrt_spec a Ha) as (_,LTa).
destruct (sqrt_spec b Hb) as (_,LTb).
revert LTa LTb. nzsimpl. rewrite 3 lt_succ_r.
intros LTa LTb.
assert (H:=add_le_mono _ _ _ _ LTa LTb).
etransitivity; [eexact H|]. clear LTa LTb H.
rewrite <- (add_assoc _ (√a) (√a)).
rewrite <- (add_assoc _ (√b) (√b)).
rewrite add_shuffle1.
rewrite <- (add_assoc _ (√a + √b)).
rewrite (add_shuffle1 (√a) (√b)).
apply add_le_mono_r.
now apply add_square_le.
Qed.

Lemma add_sqrt_le : forall a b, 0<=a -> 0<=b -> √a + √b <= √(2*(a+b)).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtProp.add_sqrt_le".
intros a b Ha Hb.
assert (Ha':=sqrt_nonneg a).
assert (Hb':=sqrt_nonneg b).
apply sqrt_le_square.
apply mul_nonneg_nonneg. order'. now apply add_nonneg_nonneg.
now apply add_nonneg_nonneg.
transitivity (2*((√a)² + (√b)²)).
now apply square_add_le.
apply mul_le_mono_nonneg_l. order'.
apply add_le_mono; now apply sqrt_spec.
Qed.

End NZSqrtProp.

Module Type NZSqrtUpProp
(Import A : NZDecOrdAxiomsSig')
(Import B : NZSqrt' A)
(Import C : NZMulOrderProp A)
(Import D : NZSqrtProp A B C).

Local Notation "a ²" := (a*a) (at level 5, no associativity, format "a ²").

Definition sqrt_up a :=
match compare 0 a with
| Lt => S √(P a)
| _ => 0
end.

Local Notation "√° a" := (sqrt_up a) (at level 6, no associativity).

Lemma sqrt_up_eqn0 : forall a, a<=0 -> √°a == 0.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_eqn0".
intros a Ha. unfold sqrt_up. case compare_spec; try order.
Qed.

Lemma sqrt_up_eqn : forall a, 0<a -> √°a == S √(P a).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_eqn".
intros a Ha. unfold sqrt_up. case compare_spec; try order.
Qed.

Lemma sqrt_up_spec : forall a, 0<a -> (P √°a)² < a <= (√°a)².
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_spec".
intros a Ha.
rewrite sqrt_up_eqn, pred_succ; trivial.
assert (Ha' := lt_succ_pred 0 a Ha).
rewrite <- Ha' at 3 4.
rewrite le_succ_l, lt_succ_r.
apply sqrt_spec.
now rewrite <- lt_succ_r, Ha'.
Qed.

Lemma sqrt_up_nonneg : forall a, 0<=√°a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_nonneg".
intros. destruct (le_gt_cases a 0) as [Ha|Ha].
now rewrite sqrt_up_eqn0.
rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg.
Qed.

Instance sqrt_up_wd : Proper (eq==>eq) sqrt_up.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_wd".
assert (Proper (eq==>eq==>Logic.eq) compare).
intros x x' Hx y y' Hy. do 2 case compare_spec; trivial; order.
intros x x' Hx; unfold sqrt_up; rewrite Hx; case compare; now rewrite ?Hx.
Qed.

Lemma sqrt_up_unique : forall a b, 0<b -> (P b)² < a <= b² -> √°a == b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_unique".
intros a b Hb (LEb,LTb).
assert (Ha : 0<a)
by (apply le_lt_trans with (P b)²; trivial using square_nonneg).
rewrite sqrt_up_eqn; trivial.
assert (Hb' := lt_succ_pred 0 b Hb).
rewrite <- Hb'. f_equiv. apply sqrt_unique.
rewrite <- le_succ_l, <- lt_succ_r, Hb'.
rewrite (lt_succ_pred 0 a Ha). now split.
Qed.

Lemma sqrt_up_square : forall a, 0<=a -> √°(a²) == a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_square".
intros a Ha.
le_elim Ha.
rewrite sqrt_up_eqn by (now apply mul_pos_pos).
rewrite sqrt_pred_square; trivial. apply (lt_succ_pred 0); trivial.
rewrite sqrt_up_eqn0; trivial. rewrite <- Ha. now nzsimpl.
Qed.

Lemma sqrt_up_succ_square : forall a, 0<=a -> √°(S a²) == S a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_succ_square".
intros a Ha.
rewrite sqrt_up_eqn by (now apply lt_succ_r, mul_nonneg_nonneg).
now rewrite pred_succ, sqrt_square.
Qed.

Lemma sqrt_up_0 : √°0 == 0.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_0".
rewrite <- (mul_0_l 0) at 1. now apply sqrt_up_square.
Qed.

Lemma sqrt_up_1 : √°1 == 1.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_1".
rewrite <- (mul_1_l 1) at 1. apply sqrt_up_square. order'.
Qed.

Lemma sqrt_up_2 : √°2 == 2.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_2".
rewrite sqrt_up_eqn by order'.
now rewrite two_succ, pred_succ, sqrt_1.
Qed.

Lemma le_sqrt_sqrt_up : forall a, √a <= √°a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.le_sqrt_sqrt_up".
intros a. unfold sqrt_up. case compare_spec; intros H.
rewrite <- H, sqrt_0. order.
rewrite <- (lt_succ_pred 0 a H) at 1. apply sqrt_succ_le.
apply lt_succ_r. now rewrite (lt_succ_pred 0 a H).
now rewrite sqrt_neg.
Qed.

Lemma le_sqrt_up_succ_sqrt : forall a, √°a <= S (√a).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.le_sqrt_up_succ_sqrt".
intros a. unfold sqrt_up.
case compare_spec; intros H; try apply le_le_succ_r, sqrt_nonneg.
rewrite <- succ_le_mono. apply sqrt_le_mono.
rewrite <- (lt_succ_pred 0 a H) at 2. apply le_succ_diag_r.
Qed.

Lemma sqrt_sqrt_up_spec : forall a, 0<=a -> (√a)² <= a <= (√°a)².
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_sqrt_up_spec".
intros a H. split.
now apply sqrt_spec.
le_elim H.
now apply sqrt_up_spec.
now rewrite <-H, sqrt_up_0, mul_0_l.
Qed.

Lemma sqrt_sqrt_up_exact :
forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_sqrt_up_exact".
intros a Ha.
split. intros. exists √a.
split. apply sqrt_nonneg.
generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order.
intros (b & Hb & Hb'). rewrite Hb'.
now rewrite sqrt_square, sqrt_up_square.
Qed.

Lemma sqrt_up_le_mono : forall a b, a <= b -> √°a <= √°b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_le_mono".
intros a b H.
destruct (le_gt_cases a 0) as [Ha|Ha].
rewrite (sqrt_up_eqn0 _ Ha). apply sqrt_up_nonneg.
rewrite 2 sqrt_up_eqn by order. rewrite <- succ_le_mono.
apply sqrt_le_mono, succ_le_mono. rewrite 2 (lt_succ_pred 0); order.
Qed.

Lemma sqrt_up_lt_cancel : forall a b, √°a < √°b -> a < b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_lt_cancel".
intros a b H.
destruct (le_gt_cases b 0) as [Hb|Hb].
rewrite (sqrt_up_eqn0 _ Hb) in H; generalize (sqrt_up_nonneg a); order.
destruct (le_gt_cases a 0) as [Ha|Ha]; [order|].
rewrite <- (lt_succ_pred 0 a Ha), <- (lt_succ_pred 0 b Hb), <- succ_lt_mono.
apply sqrt_lt_cancel, succ_lt_mono. now rewrite <- 2 sqrt_up_eqn.
Qed.

Lemma sqrt_up_lt_square : forall a b, 0<=a -> 0<=b -> (b² < a <-> b < √°a).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_lt_square".
intros a b Ha Hb. split; intros H.
destruct (sqrt_up_spec a) as (LE,LT).
apply le_lt_trans with b²; trivial using square_nonneg.
apply square_lt_simpl_nonneg; try order. apply sqrt_up_nonneg.
apply sqrt_up_lt_cancel. now rewrite sqrt_up_square.
Qed.

Lemma sqrt_up_le_square : forall a b, 0<=a -> 0<=b -> (a <= b² <-> √°a <= b).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_le_square".
intros a b Ha Hb. split; intros H.
rewrite <- (sqrt_up_square b Hb).
now apply sqrt_up_le_mono.
apply square_le_mono_nonneg in H; [|now apply sqrt_up_nonneg].
transitivity (√°a)²; trivial. now apply sqrt_sqrt_up_spec.
Qed.

Lemma sqrt_up_pos : forall a, 0 < √°a <-> 0 < a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_pos".
intros a. split; intros Ha. apply sqrt_up_lt_cancel. now rewrite sqrt_up_0.
rewrite <- le_succ_l, <- one_succ, <- sqrt_up_1. apply sqrt_up_le_mono.
now rewrite one_succ, le_succ_l.
Qed.

Lemma sqrt_up_lt_lin : forall a, 2<a -> √°a < a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_lt_lin".
intros a Ha.
rewrite sqrt_up_eqn by order'.
assert (Ha' := lt_succ_pred 2 a Ha).
rewrite <- Ha' at 2. rewrite <- succ_lt_mono.
apply sqrt_lt_lin. rewrite succ_lt_mono. now rewrite Ha', <- two_succ.
Qed.

Lemma sqrt_up_le_lin : forall a, 0<=a -> √°a<=a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_le_lin".
intros a Ha.
le_elim Ha.
rewrite sqrt_up_eqn; trivial. apply le_succ_l.
apply le_lt_trans with (P a). apply sqrt_le_lin.
now rewrite <- lt_succ_r, (lt_succ_pred 0).
rewrite <- (lt_succ_pred 0 a) at 2; trivial. apply lt_succ_diag_r.
now rewrite <- Ha, sqrt_up_0.
Qed.

Lemma sqrt_up_mul_above : forall a b, 0<=a -> 0<=b -> √°(a*b) <= √°a * √°b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_mul_above".
intros a b Ha Hb.
apply sqrt_up_le_square.
now apply mul_nonneg_nonneg.
apply mul_nonneg_nonneg; apply sqrt_up_nonneg.
rewrite mul_shuffle1.
apply mul_le_mono_nonneg; trivial; now apply sqrt_sqrt_up_spec.
Qed.

Lemma sqrt_up_mul_below : forall a b, 0<a -> 0<b -> (P √°a)*(P √°b) < √°(a*b).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_mul_below".
intros a b Ha Hb.
apply sqrt_up_lt_square.
apply mul_nonneg_nonneg; order.
apply mul_nonneg_nonneg; apply lt_succ_r.
rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos.
rewrite (lt_succ_pred 0); now rewrite sqrt_up_pos.
rewrite mul_shuffle1.
apply mul_lt_mono_nonneg; trivial using square_nonneg;
now apply sqrt_up_spec.
Qed.

Lemma sqrt_up_succ_le : forall a, 0<=a -> √°(S a) <= S (√°a).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_succ_le".
intros a Ha.
apply sqrt_up_le_square.
now apply le_le_succ_r.
apply le_le_succ_r, sqrt_up_nonneg.
rewrite <- (add_1_l (√°a)).
apply le_trans with (1²+(√°a)²).
rewrite mul_1_l, add_1_l, <- succ_le_mono.
now apply sqrt_sqrt_up_spec.
apply add_square_le. order'. apply sqrt_up_nonneg.
Qed.

Lemma sqrt_up_succ_or : forall a, 0<=a -> √°(S a) == S (√°a) \/ √°(S a) == √°a.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_succ_or".
intros a Ha.
destruct (le_gt_cases (√°(S a)) (√°a)) as [H|H].
right. generalize (sqrt_up_le_mono _ _ (le_succ_diag_r a)); order.
left. apply le_succ_l in H. generalize (sqrt_up_succ_le a Ha); order.
Qed.

Lemma sqrt_up_eq_succ_iff_square : forall a, 0<=a ->
(√°(S a) == S (√°a) <-> exists b, 0<=b /\ a == b²).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_eq_succ_iff_square".
intros a Ha. split.
intros EQ.
le_elim Ha.
exists (√°a). split. apply sqrt_up_nonneg.
generalize (proj2 (sqrt_up_spec a Ha)).
assert (Ha' : 0 < S a) by (apply lt_succ_r; order').
generalize (proj1 (sqrt_up_spec (S a) Ha')).
rewrite EQ, pred_succ, lt_succ_r. order.
exists 0. nzsimpl. now split.
intros (b & Hb & H).
now rewrite H, sqrt_up_succ_square, sqrt_up_square.
Qed.

Lemma sqrt_up_add_le : forall a b, √°(a+b) <= √°a + √°b.
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.sqrt_up_add_le".
assert (AUX : forall a b, a<=0 -> √°(a+b) <= √°a + √°b).
intros a b Ha. rewrite (sqrt_up_eqn0 a Ha). nzsimpl.
apply sqrt_up_le_mono.
rewrite <- (add_0_l b) at 2.
apply add_le_mono_r; order.
intros a b.
destruct (le_gt_cases a 0) as [Ha|Ha]. now apply AUX.
destruct (le_gt_cases b 0) as [Hb|Hb].
rewrite (add_comm a), (add_comm (√°a)); now apply AUX.
rewrite 2 sqrt_up_eqn; trivial.
nzsimpl. rewrite <- succ_le_mono.
transitivity (√(P a) + √b).
rewrite <- (lt_succ_pred 0 a Ha) at 1. nzsimpl. apply sqrt_add_le.
apply add_le_mono_l.
apply le_sqrt_sqrt_up.
now apply add_pos_pos.
Qed.

Lemma add_sqrt_up_le : forall a b, 0<=a -> 0<=b -> √°a + √°b <= S √°(2*(a+b)).
Proof. hammer_hook "NZSqrt" "NZSqrt.NZSqrtUpProp.add_sqrt_up_le".
intros a b Ha Hb.
le_elim Ha.
le_elim Hb.
rewrite 3 sqrt_up_eqn; trivial.
nzsimpl. rewrite <- 2 succ_le_mono.
etransitivity; [eapply add_sqrt_le|].
apply lt_succ_r. now rewrite (lt_succ_pred 0 a Ha).
apply lt_succ_r. now rewrite (lt_succ_pred 0 b Hb).
apply sqrt_le_mono.
apply lt_succ_r. rewrite (lt_succ_pred 0).
apply mul_lt_mono_pos_l. order'.
apply add_lt_mono.
apply le_succ_l. now rewrite (lt_succ_pred 0).
apply le_succ_l. now rewrite (lt_succ_pred 0).
apply mul_pos_pos. order'. now apply add_pos_pos.
apply mul_pos_pos. order'. now apply add_pos_pos.
rewrite <- Hb, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono.
rewrite <- (mul_1_l a) at 1. apply mul_le_mono_nonneg_r; order'.
rewrite <- Ha, sqrt_up_0. nzsimpl. apply le_le_succ_r, sqrt_up_le_mono.
rewrite <- (mul_1_l b) at 1. apply mul_le_mono_nonneg_r; order'.
Qed.

End NZSqrtUpProp.


(** * The disjoint lists relation
      This file contains the defintion of the disjoint list of [ids] relation [are_disjoints]
      and its lemmas.
    *)

Set Implicit Arguments.

Require Import ListIds.
Require Import SimpleTypes.
Require Import Arith.Arith_base List Omega.
Require Import Wellfounded.Lexicographic_Product.
Require Import Relation_Operators.
Require Import Coq.Setoids.Setoid.

Require Import LibTactics.

(** * Disjoints lists of [ids] definition *)

Definition are_disjoints (l l' : list id) : Prop :=
forall (x : id), (in_list_id x l) = true -> (in_list_id x l') = false.

(** * Several lemmas about [are_disjoints] *)

Lemma are_disjoints_cons_inversion : forall a b l1 l2,
    are_disjoints (a::l1) (b::l2) -> are_disjoints l1 l2.
Proof.
  intros.
  unfold are_disjoints in *.
  intros.
  simpl in H.
  specialize H with (x:=x).
  destruct (eq_id_dec a x);
  destruct (eq_id_dec b x);
  auto; intuition.
Qed.

Hint Resolve are_disjoints_cons_inversion:core.

Lemma are_disjoints_cons_l : forall a l1 l2, are_disjoints (a::l1) l2 -> are_disjoints l1 l2.
Proof.
  intros.
  unfold are_disjoints in *.
  intros.
  simpl in H.
  specialize H with (x:=x).
  destruct (eq_id_dec a x).
  auto.
  auto.
Qed.

Hint Resolve are_disjoints_cons_l:core.

Lemma are_disjoints_cons_diff : forall  a b l1 l2, are_disjoints (a::l1) (b::l2) -> a <> b.
Proof.
  intros. intro.
  unfold are_disjoints in H.
  specialize H with (x:=a).
  simpl in H.
  rewrite H0 in H.
  destruct (eq_id_dec b b); intuition.
Qed.

Hint Resolve are_disjoints_cons_diff:core.

Lemma are_disjoints_cons : forall l1 l2 x y, are_disjoints l1 l2 -> y <> x ->
                                        in_list_id x l2 = false ->
                                        in_list_id y l1 = false ->
                                        are_disjoints (x::l1) (y::l2).
Proof.
  intros.
  unfold are_disjoints in *.
  intros.
  simpl.
  destruct (eq_id_dec y x0).
  - subst.
    simpl in H3.
    destruct (eq_id_dec x x0).
    intuition.
    rewrite  <- H2.
    rewrite  <- H3.
    reflexivity.
  - simpl in H3.
    destruct (eq_id_dec x x0).
    * subst. assumption.
    * apply H. assumption.
Qed.

Hint Resolve are_disjoints_cons:core.

Lemma disjoint_inversion2 : forall (l l': (list id)) (x: id),
    are_disjoints l l' -> in_list_id x l' = true -> in_list_id x l = false.
Proof.
  intros.
  unfold are_disjoints in H.
  induction l'.
  inversion H0.
  assert(forall x, in_list_id x l = true -> in_list_id x l' = false).
  { intros. apply H in H1 as H1'. simpl in H1'. destruct (eq_id_dec a x0).
    inversion H1'. auto. }
  apply Bool.not_true_is_false.
  intro.
  specialize H with (x:=x).
  simpl in H, H0.
  destruct (eq_id_dec a x).
  intuition.
  intuition.
  apply H1 in H2.
  rewrite H0 in H2.
  inversion H2.
Qed.

Hint Resolve disjoint_inversion2:core.
Hint Rewrite disjoint_inversion2:RE.

Lemma disjoint_list_and_append_inversion1 : forall (l l1 l2 : list id),
    (are_disjoints l (l1++l2) ) -> (are_disjoints l l1).
Proof.
  intros.
  unfold are_disjoints in *.
  intros.
  apply H in H0.
  apply in_list_id_append_inversion1 in H0.
  apply H0.
Qed.

Hint Resolve disjoint_list_and_append_inversion1:core.

Lemma disjoint_list_and_append_inversion2 : forall (l l1 l2 : list id),
    (are_disjoints l (l1++l2) ) -> (are_disjoints l l2).
Proof.
  intros.
  unfold are_disjoints in *.
  intros.
  apply H in H0.
  apply in_list_id_append_inversion2 in H0.
  assumption.
Qed.

Hint Resolve disjoint_list_and_append_inversion2:core.

Lemma disjoint_list_and_append_inversion3 : forall (l l1 l2 : (list id)),
    (are_disjoints l (l1++l2) ) -> (are_disjoints l l1) /\ (are_disjoints l l2).
Proof.
  intros.
  split.
  eapply disjoint_list_and_append_inversion1.
  apply H.
  eapply disjoint_list_and_append_inversion2.
  apply H.
Qed.

Hint Resolve disjoint_list_and_append_inversion3:core.

Lemma disjoints_nill1 : forall C, are_disjoints C nil.
Proof.
  induction C;
  unfold are_disjoints; eauto.
Qed.

Hint Resolve disjoints_nill1:core.