(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work 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 2 of the License, or
 * (at your option) any later version.
 *
 * This work 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 this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.metrics.Prod_Sub.
Require Export CoRN.metrics.Equiv.
Set Automatic Introduction.

Section Definition_MS.
(**
** Definition of Metric Space
*)

Record CMetricSpace : Type :=
  {scms_crr :> CPsMetricSpace;
   ax_d_apdiag_imp_grzero : apdiag_imp_grzero scms_crr (cms_d (c:=scms_crr))}.

End Definition_MS.

Section MS_basics.
(**
** Metric Space basics
*)

Lemma d_CMetricSpace_apdiag_imp_grzero :
 forall X : CMetricSpace, apdiag_imp_grzero (cms_crr X) (cms_d (c:=X)).
Proof.
 intro X.
 apply ax_d_apdiag_imp_grzero.
Qed.

Lemma d_zero_imp_eq :
 forall (X : CMetricSpace) (a b : X), a[-d]b[=][0] -> a[=]b.
Proof.
 intros X a b.
 intro H.
 apply not_ap_imp_eq.
 red in |- *.
 intro H1.
 generalize H.
 apply ap_imp_neq.
 apply Greater_imp_ap.
 apply ax_d_apdiag_imp_grzero.
 exact H1.
Qed.

Lemma is_CMetricSpace_diag_zero :
 forall (X : CSetoid) (d : CSetoid_bin_fun X X IR)
   (H : com d) (H1 : tri_ineq d) (H2 : nneg d) (H3 : diag_zero X d)
   (H4 : apdiag_imp_grzero X d), CMetricSpace.
Proof.
 intros X d H H1 H2 H3 H4.
 set (H5 := Build_is_CPsMetricSpace X d H H2 (diag_zero_imp_pos_imp_ap X d H3) H1) in *.
 set (H6 := Build_CPsMetricSpace X d H5) in *.
 set (H7 := Build_CMetricSpace H6 H4) in *.
 exact H7.
Qed.

End MS_basics.
Section prodandsub.
(**
** Product-Metric-Spaces and Sub-Metric-Spaces
*)
(**
The product of two metric spaces is again a metric space.
*)

Lemma Prod0CMetricSpaces_apdiag_grzero :
 forall X Y : CMetricSpace,
 apdiag_imp_grzero (Prod0CPsMetricSpace X Y)
   (cms_d (c:=Prod0CPsMetricSpace X Y)).
Proof.
 intros X Y.
 unfold apdiag_imp_grzero in |- *.
 intros x y.
 case x.
 case y.
 intros c c0 c1 c2.
 simpl in |- *.
 intro H.
 elim H.
  intro H1.
  apply plus_resp_pos_nonneg.
   apply ax_d_apdiag_imp_grzero.
   exact H1.
  apply ax_d_nneg.
  apply CPsMetricSpace_is_CPsMetricSpace.
 intro H1.
 astepr ((c2[-d]c0)[+](c1[-d]c)).
 apply plus_resp_pos_nonneg.
  apply ax_d_apdiag_imp_grzero.
  exact H1.
 apply ax_d_nneg.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Definition Prod0CMetricSpace (X Y : CMetricSpace) :=
  Build_CMetricSpace (Prod0CPsMetricSpace X Y)
    (Prod0CMetricSpaces_apdiag_grzero X Y).

(**
A subspace of a metric space is again a metric space.
*)
Arguments SubPsMetricSpace [X].

Lemma SubMetricSpace_apdiag_grzero :
 forall (X : CMetricSpace) (P : X -> CProp),
 apdiag_imp_grzero (SubPsMetricSpace P) (cms_d (c:=SubPsMetricSpace P)).
Proof.
 intros X P.
 unfold apdiag_imp_grzero in |- *.
 intros x y.
 simpl in |- *.
 case x.
 case y.
 simpl in |- *.
 intros.
 apply ax_d_apdiag_imp_grzero.
 auto.
Qed.

Definition SubMetricSpace (X : CMetricSpace) (P : X -> CProp) :=
  Build_CMetricSpace (SubPsMetricSpace P) (SubMetricSpace_apdiag_grzero X P).

Arguments SubMetricSpace [X].

End prodandsub.
Section Zeroff.
(**
** Pseudo Metric Spaces vs Metric Spaces
*)
(**
Not all pseudo metric spaces are a metric space:
*)

Lemma zf_nis_CMetricSpace :
 forall X : CSetoid,
 {x : X | {y : X | x[#]y}} ->
 Not
   (apdiag_imp_grzero (zf_as_CPsMetricSpace X)
      (cms_d (c:=zf_as_CPsMetricSpace X))).
Proof.
 intros X Z.
 red in |- *.
 intro H.
 set (H1 := Build_CMetricSpace (zf_as_CPsMetricSpace X) H) in *.
 set (H2 := d_CMetricSpace_apdiag_imp_grzero H1) in *.
 generalize H2.
 unfold H1 in |- *.
 simpl in |- *.
 unfold apdiag_imp_grzero in |- *.
 unfold Zero_fun in |- *.
 simpl in |- *.
 unfold zero_fun in |- *.
 elim Z.
 intros x Z1.
 elim Z1.
 intros y Z2.
 intros H3.
 set (H4 := H3 x y Z2) in *.
 set (H5 := less_irreflexive_unfolded IR [0] H4) in *.
 exact H5.
Qed.

(**
But a pseudo metric space induces a metric space:
*)

Definition metric_ap (X : CPsMetricSpace) (x y : X) : CProp := [0][<]x[-d]y.

Definition metric_eq (X : CPsMetricSpace) (x y : X) : Prop := x[-d]y[=][0].

Lemma metric_ap_irreflexive :
 forall X : CPsMetricSpace, irreflexive (metric_ap X).
Proof.
 intro X.
 unfold irreflexive in |- *.
 intro x.
 red in |- *.
 unfold metric_ap in |- *.
 set (H0 := pos_imp_ap_imp_diag_zero X (cms_d (c:=X))
   (ax_d_pos_imp_ap X (cms_d (c:=X)) (CPsMetricSpace_is_CPsMetricSpace X))
     (ax_d_nneg X (cms_d (c:=X)) (CPsMetricSpace_is_CPsMetricSpace X))) in *.
 generalize H0.
 unfold diag_zero in |- *.
 intros H1 H2.
 set (H3 := less_wdr IR [0] (x[-d]x) [0] H2 (H1 x)) in *.
 set (H4 := less_irreflexive_unfolded IR [0] H3) in *.
 exact H4.
Qed.

Lemma metric_ap_symmetric :
 forall X : CPsMetricSpace, Csymmetric (metric_ap X).
Proof.
 intro X.
 unfold Csymmetric in |- *.
 intros x y.
 unfold metric_ap in |- *.
 intro H.
 astepr (x[-d]y).
  exact H.
 apply ax_d_com.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Lemma metric_ap_cotransitive :
 forall X : CPsMetricSpace, cotransitive (metric_ap X).
Proof.
 intro X.
 unfold cotransitive in |- *.
 unfold metric_ap in |- *.
 intros x y H z.
 cut (ZeroR[<](x[-d]z)[+](z[-d]y)).
  intro H0.
  apply positive_Sum_two.
  exact H0.
 apply less_leEq_trans with (x[-d]y).
  exact H.
 apply ax_d_tri_ineq.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Lemma metric_ap_tight :
 forall X : CPsMetricSpace, tight_apart (metric_eq X) (metric_ap X).
Proof.
 intro X.
 unfold tight_apart in |- *.
 unfold metric_ap in |- *.
 unfold metric_eq in |- *.
 intros x y.
 split.
  intro H.
  cut (ZeroR[<=]x[-d]y).
   rewrite -> leEq_def in |- *.
   intro H1.
   cut (Not (x[-d]y[#][0])).
    intro H2.
    apply not_ap_imp_eq.
    exact H2.
   red in |- *.
   intro H2.
   set (H3 := less_conf_ap IR (x[-d]y) [0]) in *.
   elim H3.
   intros H4 H5.
   set (H6 := H4 H2) in *.
   elim H6.
    intuition.
   intuition.
  apply ax_d_nneg.
  apply CPsMetricSpace_is_CPsMetricSpace.
 intro H.
 red in |- *.
 intro H0.
 set (H1 := less_wdr IR [0] (x[-d]y) [0] H0 H) in *.
 set (H2 := less_irreflexive_unfolded IR [0] H1) in *.
 exact H2.
Qed.

Definition Metric_CSet_is_CSetoid (X : CPsMetricSpace) :=
  Build_is_CSetoid X (metric_eq X) (metric_ap X) (metric_ap_irreflexive X)
    (metric_ap_symmetric X) (metric_ap_cotransitive X) (
    metric_ap_tight X).

Definition Metric_CSetoid (X : CPsMetricSpace) :=
  Build_CSetoid X (metric_eq X) (metric_ap X) (Metric_CSet_is_CSetoid X).

Definition metric_d (X : CPsMetricSpace) (x y : Metric_CSetoid X) := x[-d]y.

Lemma metric_d_strext :
 forall X : CPsMetricSpace,
 bin_fun_strext (Metric_CSetoid X) (Metric_CSetoid X) IR (metric_d X).
Proof.
 intro X.
 unfold bin_fun_strext in |- *.
 intros x1 x2 y1 y2.
 simpl in |- *.
 unfold metric_d in |- *.
 unfold metric_ap in |- *.
 intro H.
 apply positive_Sum_two.
 set (H0 := less_conf_ap IR (x1[-d]y1) (x2[-d]y2)) in *.
 elim H0.
 intros H1 H2.
 set (H4 := H1 H) in *.
 elim H4.
  intro H5.
  astepr ((x1[-d]x2)[+](y1[-d]y2)[+][0]).
  astepr ((x1[-d]x2)[+](y1[-d]y2)[+]((x1[-d]y1)[-](x1[-d]y1))).
  astepr ((x1[-d]x2)[+](y1[-d]y2)[+](x1[-d]y1)[-](x1[-d]y1)).
  apply shift_less_minus.
  astepl (x1[-d]y1).
  apply less_leEq_trans with (x2[-d]y2).
   exact H5.
  apply leEq_transitive with ((x2[-d]x1)[+](x1[-d]y2)).
   apply ax_d_tri_ineq.
   apply CPsMetricSpace_is_CPsMetricSpace.
  astepr ((x2[-d]x1)[+](y1[-d]y2)[+](x1[-d]y1)).
   astepr ((x2[-d]x1)[+]((y1[-d]y2)[+](x1[-d]y1))).
   apply plus_resp_leEq_lft.
   astepr ((x1[-d]y1)[+](y1[-d]y2)).
   apply ax_d_tri_ineq.
   apply CPsMetricSpace_is_CPsMetricSpace.
  astepl ((y1[-d]y2)[+](x2[-d]x1)[+](x1[-d]y1)).
  astepr ((y1[-d]y2)[+](x1[-d]x2)[+](x1[-d]y1)).
  astepl ((y1[-d]y2)[+]((x2[-d]x1)[+](x1[-d]y1))).
  astepr ((y1[-d]y2)[+]((x1[-d]x2)[+](x1[-d]y1))).
  astepl ((y1[-d]y2)[+]((x1[-d]y1)[+](x2[-d]x1))).
  astepr ((y1[-d]y2)[+]((x1[-d]y1)[+](x1[-d]x2))).
  astepl ((y1[-d]y2)[+](x1[-d]y1)[+](x2[-d]x1)).
  astepr ((y1[-d]y2)[+](x1[-d]y1)[+](x1[-d]x2)).
  apply plus_resp_eq.
  apply ax_d_com.
  apply CPsMetricSpace_is_CPsMetricSpace.
 intro H5.
 astepr ((x1[-d]x2)[+](y1[-d]y2)[+][0]).
 astepr ((x1[-d]x2)[+](y1[-d]y2)[+]((x2[-d]y2)[-](x2[-d]y2))).
 astepr ((x1[-d]x2)[+](y1[-d]y2)[+](x2[-d]y2)[-](x2[-d]y2)).
 apply shift_less_minus.
 astepl (x2[-d]y2).
 apply less_leEq_trans with (x1[-d]y1).
  exact H5.
 apply leEq_transitive with ((x1[-d]x2)[+](x2[-d]y1)).
  apply ax_d_tri_ineq.
  apply CPsMetricSpace_is_CPsMetricSpace.
 astepr ((x1[-d]x2)[+](y1[-d]y2)[+](x2[-d]y2)).
 astepr ((x1[-d]x2)[+]((y1[-d]y2)[+](x2[-d]y2))).
 apply plus_resp_leEq_lft.
 astepr ((x2[-d]y2)[+](y1[-d]y2)).
 astepr ((x2[-d]y2)[+](y2[-d]y1)).
  apply ax_d_tri_ineq.
  apply CPsMetricSpace_is_CPsMetricSpace.
 apply plus_resp_eq.
 apply ax_d_com.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Definition Metric_d (X : CPsMetricSpace) :=
  Build_CSetoid_bin_fun (Metric_CSetoid X) (Metric_CSetoid X) IR (
    metric_d X) (metric_d_strext X).

Lemma Metric_d_com : forall X : CPsMetricSpace, com (Metric_d X).
Proof.
 intro X.
 unfold com in |- *.
 intros x y.
 unfold Metric_d in |- *.
 simpl in |- *.
 unfold metric_d in |- *.
 apply ax_d_com.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Lemma Metric_d_nneg : forall X : CPsMetricSpace, nneg (Metric_d X).
Proof.
 intro X.
 unfold nneg in |- *.
 intros x y.
 unfold Metric_d in |- *.
 simpl in |- *.
 unfold metric_d in |- *.
 apply ax_d_nneg.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Lemma Metric_d_pos_imp_ap :
 forall X : CPsMetricSpace, pos_imp_ap (Metric_d X).
Proof.
 intro X.
 unfold pos_imp_ap in |- *.
 intros x y.
 unfold Metric_d in |- *.
 simpl in |- *.
 unfold metric_d in |- *.
 unfold metric_ap in |- *.
 intuition.
Qed.

Lemma Metric_d_tri_ineq : forall X : CPsMetricSpace, tri_ineq (Metric_d X).
Proof.
 intro X.
 unfold tri_ineq in |- *.
 intros x y z.
 unfold Metric_d in |- *.
 simpl in |- *.
 unfold metric_d in |- *.
 apply ax_d_tri_ineq.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Definition QuotientCSetoid_is_CPsMetricSpace (X : CPsMetricSpace) :=
  Build_is_CPsMetricSpace (Metric_CSetoid X) (Metric_d X) (
    Metric_d_com X) (Metric_d_nneg X) (Metric_d_pos_imp_ap X)
    (Metric_d_tri_ineq X).

Definition QuotientCPsMetricSpace (X : CPsMetricSpace) :=
  Build_CPsMetricSpace (Metric_CSetoid X) (Metric_d X)
    (QuotientCSetoid_is_CPsMetricSpace X).

Lemma Metric_d_apdiag_grzero :
 forall X : CPsMetricSpace,
 apdiag_imp_grzero (QuotientCPsMetricSpace X)
   (cms_d (c:=QuotientCPsMetricSpace X)).
Proof.
 intro X.
 unfold apdiag_imp_grzero in |- *.
 intros x y.
 simpl in |- *.
 unfold metric_ap in |- *.
 unfold metric_d in |- *.
 intuition.
Qed.

Definition QuotientCMetricSpace (X : CPsMetricSpace) :=
  Build_CMetricSpace (QuotientCPsMetricSpace X) (Metric_d_apdiag_grzero X).

(**
Some pseudo metric spaces already are a metric space:
*)

Lemma dIR_apdiag_grzero :
 apdiag_imp_grzero IR_as_CPsMetricSpace (cms_d (c:=IR_as_CPsMetricSpace)).
Proof.
 unfold apdiag_imp_grzero in |- *.
 intros x y.
 simpl in |- *.
 unfold dIR in |- *.
 intro H.
 set (H0 := AbsIR_pos) in *.
 generalize H0.
 simpl in |- *.
 intro H1.
 apply H1.
 apply minus_ap_zero.
 exact H.
Qed.

Definition IR_as_CMetricSpace :=
  Build_CMetricSpace IR_as_CPsMetricSpace dIR_apdiag_grzero.

(**
In that case the induced metric space is equivalent to the original one:
*)

Definition emb (X : CPsMetricSpace) : X -> QuotientCMetricSpace X.
Proof.
 intros x.
 unfold QuotientCMetricSpace in |- *.
 simpl in |- *.
 exact x.
Defined.

Lemma emb_strext : forall X : CPsMetricSpace, fun_strext (emb X).
Proof.
 intro X.
 unfold fun_strext in |- *.
 unfold emb in |- *.
 simpl in |- *.
 unfold metric_ap in |- *.
 apply ax_d_pos_imp_ap.
 apply CPsMetricSpace_is_CPsMetricSpace.
Qed.

Definition Emb (X : CPsMetricSpace) :=
  Build_CSetoid_fun X (QuotientCMetricSpace X) (emb X) (emb_strext X).

Lemma Quotient_pres_CMetricSpace :
 forall X : CMetricSpace, isopsmetry X (QuotientCPsMetricSpace X) (Emb X).
Proof.
 intro X.
 unfold isopsmetry in |- *.
 unfold Emb in |- *.
 simpl in |- *.
 unfold emb in |- *.
 split.
  unfold bijective in |- *.
  split.
   unfold injective in |- *.
   simpl in |- *.
   intros a0 a1.
   unfold metric_ap in |- *.
   apply ax_d_apdiag_imp_grzero.
  unfold surjective in |- *.
  intro b.
  simpl in |- *.
  exists b.
  unfold metric_eq in |- *.
  apply pos_imp_ap_imp_diag_zero.
   apply d_pos_imp_ap.
  apply d_nneg.
 unfold equivalent_psmetric in |- *.
 simpl in |- *.
 split.
  split.
   apply CPsMetricSpace_is_CPsMetricSpace.
  apply Build_is_CPsMetricSpace.
     unfold com in |- *.
     simpl in |- *.
     unfold metric_d in |- *.
     apply ax_d_com.
     apply CPsMetricSpace_is_CPsMetricSpace.
    unfold nneg in |- *.
    simpl in |- *.
    unfold metric_d in |- *.
    apply ax_d_nneg.
    apply CPsMetricSpace_is_CPsMetricSpace.
   unfold pos_imp_ap in |- *.
   simpl in |- *.
   unfold metric_d in |- *.
   apply ax_d_pos_imp_ap.
   apply CPsMetricSpace_is_CPsMetricSpace.
  unfold tri_ineq in |- *.
  simpl in |- *.
  unfold metric_d in |- *.
  apply ax_d_tri_ineq.
  apply CPsMetricSpace_is_CPsMetricSpace.
 split.
  exists 0.
  unfold metric_d in |- *.
  intros x y.
  apply eq_imp_leEq.
  rational.
 exists 0.
 unfold metric_d in |- *.
 intros x y.
 apply eq_imp_leEq.
 rational.
Qed.

End Zeroff.

Section Limitt.
(**
** Limit
*)
(**
A sequence in a metric space has at most one limit.
*)
Arguments MSseqLimit [X].

(* begin hide *)
Lemma nz : forall n m : nat, n <= max n m.
Proof.
 intro n.
 intro m.
 intuition.
Qed.
(* end hide *)

(* begin hide *)
Lemma d_wd :
 forall (X : CPsMetricSpace) (a b c : X), a[=]b -> a[-d]c[=]b[-d]c.
Proof.
 intros X a b c.
 intros H.
 apply not_ap_imp_eq.
 red in |- *.
 intro H1.
 cut (a[#]b or c[#]c).
  intro H2.
  elim H2.
   apply eq_imp_not_ap.
   exact H.
  apply ap_irreflexive_unfolded.
 cut (a[-d]c[#]b[-d]c -> a[#]b or c[#]c).
  intro H2.
  apply H2.
  exact H1.
 apply csbf_strext.
Qed.
(* end hide *)

Lemma unique_MSseqLim :
 forall (X : CMetricSpace) (seq : nat -> X) (a b : X),
 MSseqLimit seq a and MSseqLimit seq b -> a[=]b.
Proof.
 intros X seq a b.
 unfold MSseqLimit in |- *.
 simpl in |- *.
 intros H.
 apply d_zero_imp_eq.
 apply not_ap_imp_eq.
 red in |- *.
 intro H1.
 set (H2 := recip_ap_zero IR (a[-d]b) H1) in *.
 set (H3 := Archimedes' (OneR[/] a[-d]b[//]H1)) in *.
 elim H3.
 intros n H4.
 set (H6 := less_transitive_unfolded IR ([1][/] a[-d]b[//]H1) (
   nring n) (nring n[+][1]) H4 (nring_less_succ IR n)) in *.
 elim H.
 intros H5 H7.
 elim (H5 (S (S n)) (ap_symmetric_unfolded IR [0] ([0][+][1][+][1])
   (less_imp_ap IR [0] ([0][+][1][+][1]) (less_transitive_unfolded IR [0] ([0][+][1]) (
     [0][+][1][+][1]) (less_plusOne IR [0]) (less_plusOne IR (ZeroR[+][1])))))).
 intros x H8.
 elim (H7 (S (S n)) (ap_symmetric_unfolded IR [0] ([0][+][1][+][1])
   (less_imp_ap IR [0] ([0][+][1][+][1]) (less_transitive_unfolded IR [0] ([0][+][1]) (
     [0][+][1][+][1]) (less_plusOne IR [0]) (less_plusOne IR ([0][+][1]:IR)))))).
 intros y H9.
 set (H10 := H9 (max y x)) in *.
 set (H11 := H8 (max x y)) in *.
 simpl in |- *.
 set (H12 := H11 (nz x y)) in *.
 set (H13 := H10 (nz y x)) in *.
 set (H14 := ap_symmetric_unfolded IR [0] ([0][+][1][+][1]) (less_imp_ap IR [0] ([0][+][1][+][1])
   (less_transitive_unfolded IR [0] ([0][+][1]) ( [0][+][1][+][1]) (less_plusOne IR [0])
     (less_plusOne IR ([0][+][1]))))) in *.
 cut ((seq (max x y)[-d]a)[+](seq (max y x)[-d]b)[<]
   nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[+]
     nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)).
  intro H15.
  cut (nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[+]
    nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[<=]
      (seq (max x y)[-d]a)[+](seq (max y x)[-d]b)).
   rewrite -> leEq_def in |- *.
   intro H16.
   auto.
  cut (nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[+]
    nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[<=] a[-d]b).
   intro H16.
   apply leEq_transitive with (a[-d]b).
    exact H16.
   astepr ((seq (max x y)[-d]a)[+](seq (max x y)[-d]b)).
    astepr ((a[-d]seq (max x y))[+](seq (max x y)[-d]b)).
     apply ax_d_tri_ineq.
     apply CPsMetricSpace_is_CPsMetricSpace.
    astepl ((seq (max x y)[-d]b)[+](a[-d]seq (max x y))).
    astepr ((seq (max x y)[-d]b)[+](seq (max x y)[-d]a)).
    apply plus_resp_eq.
    simpl in |- *.
    apply d_com.
   apply plus_resp_eq.
   apply d_wd.
   cut (max x y = max y x -> seq (max x y)[=]seq (max y x)).
    intro H17.
    apply H17.
    apply max_comm.
   intro H17.
   rewrite H17.
   apply eq_reflexive.
  astepl ((Two:IR)[*]nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)).
  astepl (nexp IR (S n) ([1][/] [0][+][1][+][1][//]H14)).
   astepl (([1][/] [0][+][1][+][1][//]H14)[^]S n).
   astepl ([1][/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14).
   apply leEq_transitive with ([1][/] nring (S n)[//] ap_symmetric_unfolded IR [0] (nring (S n))
     (less_imp_ap IR [0] (nring (S n)) (pos_Snring IR n))).
    apply leEq_transitive with ([1][/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14).
     2: apply less_leEq.
     2: set (Hn := bin_less_un) in *.
     2: generalize Hn.
     2: simpl in |- *.
     2: intro Hn'.
     2: apply Hn'.
    apply recip_resp_leEq.
     apply nexp_resp_pos.
     astepr (Two:IR).
     apply pos_two.
    apply eq_imp_leEq.
    apply eq_reflexive_unfolded.
   apply shift_div_leEq.
    apply (pos_Snring IR n).
   apply shift_leEq_mult' with H1.
    2: apply less_leEq.
    2: apply H6.
   cut ([0][<]a[-d]b or a[-d]b[<][0]).
    intro H16.
    elim H16.
     intro H17.
     exact H17.
    intro H17.
    set (H18 := ax_d_nneg X (cms_d (c:=X))) in *.
    generalize H18.
    unfold nneg in |- *.
    intro H19.
    set (H20 := H19 (CPsMetricSpace_is_CPsMetricSpace X) a b) in *.
    rewrite -> leEq_def in H20.
    set (H21 := H20 H17) in *.
    intuition.
   apply ap_imp_less.
   apply ap_symmetric_unfolded.
   exact H1.
  astepl ((OneR[/] [0][+][1][+][1][//]H14)[^]S n).
  astepl (OneR[^]S n[/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14).
  astepl (OneR[/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14).
  astepl ((OneR[+][1])[*] ([1][/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14)).
   apply mult_cancel_lft with (OneR[/] [0][+][1][+][1][//]H14).
    apply div_resp_ap_zero_rev.
    apply ap_symmetric_unfolded.
    apply less_imp_ap.
    apply pos_one.
   astepr (([1][/] [0][+][1][+][1][//]H14)[*]([0][+][1][+][1])[*]
     ([1][/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14)).
    astepr (OneR[*] ([1][/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14)).
    astepr (OneR[/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14).
    astepr (OneR[*][1][/] ([0][+][1][+][1])[*]([0][+][1][+][1])[^]S n[//]
      mult_resp_ap_zero IR ([0][+][1][+][1]) (([0][+][1][+][1])[^]S n) H14
        (nexp_resp_ap_zero (S n) H14)).
    astepr ([1][*][1][/] ([0][+][1][+][1])[^]S (S n)[//] nexp_resp_ap_zero (S (S n)) H14).
    rational.
   astepr (([1][/] [0][+][1][+][1][//]H14)[*]Two[*]
     nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)).
   astepr (([1][/] [0][+][1][+][1][//]H14)[*]([0][+][1][+][1])[*]
     nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)).
   apply mult_wdr.
   3: apply plus_resp_less_both.
    3: exact H12.
   3: exact H13.
  astepr (([1][/] [0][+][1][+][1][//]H14)[^]S (S n)).
  apply eq_symmetric_unfolded.
  apply nexp_distr_recip.
 astepl ([1][+][1][/] ([0][+][1][+][1])[^]S (S n)[//] nexp_resp_ap_zero (S (S n)) H14).
  2: rational.
 astepl ([0][+][1][+][1][/] ([0][+][1][+][1])[^]S (S n)[//] nexp_resp_ap_zero (S (S n)) H14).
 rstepr ([0][+][1][+][1][/] ([0][+][1][+][1])[*]([0][+][1][+][1])[^]S n[//]
   mult_resp_ap_zero IR ([0][+][1][+][1]) (([0][+][1][+][1])[^]S n) H14
     (nexp_resp_ap_zero (S n) H14)).
 astepl ([0][+][1][+][1][/] ([0][+][1][+][1])[*]([0][+][1][+][1])[^]S n[//]
   mult_resp_ap_zero IR ([0][+][1][+][1]) (([0][+][1][+][1])[^]S n) H14
     (nexp_resp_ap_zero (S n) H14)).
 apply eq_reflexive_unfolded.
Qed.

End Limitt.


Require Import List Map Envs AllInRel Exp AppExpFree Filter LengthEq.
Require Import IL Annotation AutoIndTac Liveness.Liveness LabelsDefined.
Require Import Slot.

Definition choose_y (slot : var -> var)
           (X : ⦃var⦄) (x:var)
           (RMapp : ⦃var⦄ * ⦃var⦄)
           (y:var) :=
  if [x ∈ X] then (* reg prefered *)
    if [y ∈ fst RMapp] then Var y
    else Var (slot y)
  else (* slot prefered *)
    if [y ∈ snd RMapp] then Var (slot y)
    else Var y.

Lemma choose_y_freeVars slot X x RM y
  : Ops.freeVars (choose_y slot X x RM y) ⊆ {y; singleton (slot y)}.
Proof.
  unfold choose_y; repeat cases; simpl; cset_tac.
Qed.

Fixpoint slot_lift_args
           (slot : var -> var)
           (RM : ⦃var⦄ * ⦃var⦄)
           (RMapp : ⦃var⦄ * ⦃var⦄)
           (Y: list op) (Z : params)
  : list op
  :=
    match Y, Z with
    | e::Y, z::Z => let y := getVar e in
      if [z ∈ fst RM ∩ snd RM]
      then choose_y slot (fst RM) z RMapp y::
                    choose_y slot (snd RM) z RMapp y::
                    slot_lift_args slot RM RMapp Y Z
      else if [z ∈ fst RM]
           then choose_y slot (fst RM) z RMapp y::slot_lift_args slot RM RMapp Y Z
           else choose_y slot (snd RM) z RMapp y::slot_lift_args slot RM RMapp Y Z
    | _, _ => nil
    end.

Lemma slot_lift_args_length slot RM RMapp Y Z (Len:❬Y❭=❬Z❭)
      (NoDup:NoDupA eq Z)
  : ❬slot_lift_args slot RM RMapp Y Z❭ =
    ❬Z❭ + cardinal (of_list Z ∩ (fst RM ∩ snd RM)).
Proof.
  general induction Len; simpl; eauto.
  inv NoDup.
  repeat cases; simpl; rewrite IHLen; eauto.
  - rewrite cap_special_in; eauto.
    rewrite add_cardinal_2; eauto. cset_tac.
  - rewrite cap_special_notin; eauto.
  - rewrite cap_special_notin; eauto.
Qed.

Smpl Add match goal with
         | [ H : context [ ❬slot_lift_args ?slot ?RM ?RMapp ?Y ?Z❭ ],
             Len : ❬?Y❭ = ❬?Z❭, NoDup : NoDupA eq ?Z |- _ ]
           => rewrite (@slot_lift_args_length slot RM RMapp Y Z Len NoDup) in H
         | [ Len : ❬?Y❭ = ❬?Z❭, NoDup : NoDupA eq ?Z |-
             context [ ❬slot_lift_args ?slot ?RM ?RMapp ?Y ?Z❭ ] ]
           => rewrite (@slot_lift_args_length slot RM RMapp Y Z Len NoDup)
         end : len.

Lemma choose_y_isVar slot X y RMapp v
  :  isVar (choose_y slot X y RMapp v).
Proof.
  unfold choose_y; repeat cases; eauto using isVar.
Qed.

Lemma slot_lift_args_isVar (slot:var -> var) RM RMapp Y Z
  : (forall (n : nat) (y : op), get Y n y -> isVar y)
    -> forall (n : nat) (y : op), get (slot_lift_args slot RM RMapp Y Z) n y -> isVar y.
Proof.
  intros.
  general induction Y; destruct Z; simpl in *; isabsurd.
  exploit H; eauto using get. inv H1; simpl in *.
  repeat cases in H0; inv H0; eauto using get, choose_y_isVar.
  inv H6; eauto using get, choose_y_isVar.
Qed.

Lemma slot_lift_args_get slot RM RMapp Y Z n x
  : get (slot_lift_args slot RM RMapp Y Z) n x
    -> exists n y z X, get Y n y /\ get Z n z /\
               x = choose_y slot X z RMapp (getVar y) /\
               (X = fst RM \/ X = snd RM).
Proof.
  intros.
  general induction Y; destruct Z; isabsurd; simpl in *.
  - repeat cases in H; clear_trivial_eqs; inv H; eauto 20 using get.
    + inv H4; eauto 20 using get. eapply IHY in H5; dcr.
      eauto 20 using get.
    + eapply IHY in H4; dcr.
      eauto 20 using get.
    + eapply IHY in H4; dcr.
      eauto 20 using get.
Qed.

Lemma lifted_args_in_RL_slot_SpM
      (Y : args)
      (R M : ⦃var⦄) RM
      (slot : var -> var)
      (H5 : forall (n : nat) (y : op), get Y n y -> isVar y)
      (Sp L K M' R' : ⦃var⦄)
      (Cover : list_union (Ops.freeVars ⊝ Y) ⊆ R' ∪ M')
      (M'_incl: M' ⊆ Sp ∪ M) (R'_incl : R' ⊆ (R \ K ∪ L)) Z
  : list_union (Ops.freeVars ⊝ slot_lift_args slot RM (R',M') Y Z) ⊆ R ∪ L ∪ map slot (Sp ∪ M) .
Proof.
  apply list_union_incl; [|eauto with cset].
  intros; inv_get.
  eapply slot_lift_args_get in H. dcr; subst.
  exploit H5; eauto. inv H; simpl in *.
  assert (v ∈ R' ∪ M'). {
    rewrite <- Cover.
    eapply incl_list_union; eauto using get. reflexivity. simpl. cset_tac.
  }
  unfold choose_y; repeat cases; simpl in *.
  - rewrite R'_incl in COND0. revert COND0; clear. intros. cset_tac.
  - rewrite <- map_singleton; eauto.
    apply incl_union_right.
    apply lookup_set_incl; eauto.
    cset_tac.
  - rewrite <- map_singleton; eauto.
    apply incl_union_right.
    apply lookup_set_incl; eauto.
    cset_tac.
  - assert (v ∈ R') by cset_tac.
    rewrite R'_incl in H3. revert H3; clear. intros. cset_tac.
Qed.

Lemma slot_lift_args_app_expfree (slot:var -> var) RM RMapp Y Z f
  (IV : forall (n : nat) (y : op), get Y n y -> isVar y)
  : app_expfree (stmtApp f (slot_lift_args slot RM RMapp Y Z)).
Proof.
  econstructor.
  intros; inv_get; eauto using slot_lift_args_isVar.
Qed.


(** * Kripke Semantics *)

Set Implicit Arguments.

Require Import decidable_In.
Require Import environments.
Require Import extralibrary.
Require Import sublist.
Require Import language_syntax.
Require Import substitution.
Require Import variable_sets.
Require Import fresh_csts.
Require Import relocation.

(** ** Kripke Model *)

(** We use the conventional Kripke model adopted by Troelstra and van Dalen
   for the semantics of LJT.

   - A Kripke model is a tuple of a partially-ordered set of _worlds_, a domain,
     interpretations of constants and function symbols into the domain,
     and a binary relation between worlds and atomic sentences. *)

Record Kripke : Type := {
  worlds: Type;
  wle : worlds -> worlds -> Type;
  wle_refl : forall w, wle w w;
  wle_trans : forall w w' w'', wle w w' -> wle w' w'' -> wle w w'';
  domain : Type;
  csts : name -> domain;
  funs : function -> domain -> domain -> domain;
  atoms : worlds -> predicate * domain -> Type;
  atoms_mon : forall w w', wle w w' -> forall P, atoms w P -> atoms w' P
  }.

Notation "w <= w'" := (wle _ w w') (at level 70).

(** ** Semantics *)

(** Interpretation of a pseudo-term in a Kripke model using associations for variables.

   - The interpretation of pseudo-terms is made total by ignoring insignificant variables.

   - The being-in-a-list part of a term is simply ignored during the interpretation.

   - The trace relocation has no impact on the Kripke semantics. *)

Fixpoint psem K m (t:term m) (eta:assoc (domain K)){struct t} :
  domain K :=
  match t with
    | Var x _ => match eta ^^ x with
                    | Some u => u
                    | None => csts _ 0 (* fixed value *)
                  end
    | Cst c => csts _ c
    | App f t1 t2 => funs _ f (psem K t1 eta) (psem K t2 eta)
  end.

(** Forcing: The Kripke semantics is extended to all formulae *)

Reserved Notation "w ||- A [ eta ]" (at level 80).

Fixpoint force K (w: worlds K) m (A : formula m) eta {struct A} : Type :=
  match A with
    | Atom (p,t) => atoms K w (p, psem K t eta)
    | B --> C    => forall w', w <= w' ->
                    w' ||- B [eta] -> w' ||- C [eta]
    | Forall y B => forall w', w <= w' ->
                    forall (d :domain K), w' ||- B [(y, d) :: eta]
  end

  where " w ||- A [ eta ] " := (force _ w A  eta).

Notation "w ||- A [ eta ]" := (force _ w A eta) (at level 80).

(** Forcing is monotone w.r.t. the world relation. *)

Lemma mono_force : forall K (w w':worlds K) eta,
  w <= w' ->
  forall m (A:formula m),
    w ||- A [eta] -> w' ||- A [eta].
Proof.
  induction A as [m [p t]| |]; simpl; intros.
  apply atoms_mon with (w:=w); auto.

  apply X0; eauto using wle_trans.

  apply X0; eauto using wle_trans.
Qed.

(** Kripke semantics is independent of relocation. *)

Lemma reloc_psem : forall m (t: term m) K eta
  k l (h: sub_name (ov_t t) k) (h0: sub_name (ov_t t) l),
  psem K (treloc t h) eta = psem K (treloc t h0) eta.
Proof.
  induction t; simpl; intros; f_equal; auto.
Qed.

Fixpoint reloc_force m (A: formula m) {struct A} :
  forall K (w: worlds K) eta
    k l (h: sub_name (ov_f A) k) (h0: sub_name (ov_f A) l),
    w ||- (freloc A h) [eta] ->
    w ||- (freloc A h0) [eta] :=
      match A in formula _ return
        forall K (w: worlds K) eta
          k l (h: sub_name (ov_f A) k) (h0: sub_name (ov_f A) l),
          w ||- (freloc A h) [eta] ->
          w ||- (freloc A h0) [eta]
        with
        | Atom (p, t) => fun K w eta k l h h0 Hatom =>
          let P := fun (d:domain K) => atoms K w (p, d) in
            eq_rect_r P Hatom (
              reloc_psem t K eta (In_inv_atom _ _ h0)(In_inv_atom _ _ h))
        | B --> C => fun K w eta k l h h0 Himply =>
          let h' := In_inv_impL B C h in
          let h'' := In_inv_impR B C h in
          let h0' := In_inv_impL B C h0 in
          let h0'' := In_inv_impR B C h0 in
            fun w' (h1:w <= w') (h2: w' ||- (freloc B h0') [eta]) =>
              let p1 := reloc_force B K w' eta h0' h' h2 in
              let p2 := Himply w' h1 p1 in
                reloc_force C K w' eta h'' h0'' p2
        | Forall y B => fun K w eta k l h h0 Hall =>
          fun w' (h1:w <= w')(d:domain K) =>
            reloc_force B K w' ((y,d) :: eta)
            (In_inv_all B h) (In_inv_all B h0) (Hall w' h1 d)
      end.

(** ** Equivalence of associations *)

Definition assoc_equiv (A:Type) (m:trace) (eta eta0:assoc A) :=
  forall x, x @ m -> eta ^^ x = eta0 ^^ x.

Hint Unfold assoc_equiv.

Lemma assoc_equiv_comm : forall (A:Type) (m:trace) (eta eta0:assoc A),
  assoc_equiv m eta eta0 ->
  assoc_equiv m eta0 eta.
Proof.
  firstorder using assoc_equiv.
Qed.

Lemma assoc_equiv_cons : forall A m (eta eta0 : assoc A),
  assoc_equiv m eta eta0 ->
  forall x d,
    assoc_equiv (x :: m) ((x, d) :: eta) ((x, d) :: eta0).
Proof.
  unfold assoc_equiv; intros; simpl; case_name; auto.
  eauto using neq_In_cons.
Qed.

Hint Resolve assoc_equiv_comm assoc_equiv_cons.

(** A specified tactic for handling [assoc_equiv]. *)

Ltac solve_assoc :=
  let z := fresh "z" in
    let Hz := fresh "Hz" in
      intros z Hz; simpl in *; repeat case_name; intuition.

(** Semantics for well-defined terms/formulas is fixed. *)

Lemma psem_assoc_equiv : forall K m eta eta0 (t:term m),
  assoc_equiv m eta eta0 ->
  psem K t eta = psem K t eta0.
Proof.
  induction t; simpl; intros;
    [ rewrite H; auto
      | reflexivity
      | f_equal; auto
    ].
Qed.

Lemma psem_term_assoc_indep : forall K eta eta' (t:(term nil)),
  psem K t eta = psem K t eta'.
Proof.
  intros; apply psem_assoc_equiv; firstorder.
Qed.

Lemma force_assoc_equiv : forall m (A:formula m) K (w:worlds K) eta eta0,
  assoc_equiv m eta eta0 ->
  w ||- A [eta] ->
  w ||- A [eta0].
Proof.
  induction A as [m [p t] | |]; simpl; intros;
    [ rewrite psem_assoc_equiv with (eta0:=eta0) in X; auto
      | eauto
      | apply IHA with (eta := (x,d)::eta); auto
    ].
Qed.

Lemma force_formula_assoc_indep : forall K (w:worlds K) eta eta' (A: formula nil),
  w ||- A [eta] ->
  w ||- A [eta'].
Proof.
  intros; apply force_assoc_equiv with eta; firstorder.
Qed.

(** ** Forcing and substitution *)

Theorem psem_tsubst_In : forall m (t:term m) l x u K eta,
  sub_name (dom eta) l ->
  x @ l ->
  psem K ([[l ! (x,u)::nil]] t) eta = psem K t eta.
Proof.
  induction t; simpl; intros;
    [ destruct (x <-? l); try case_name; auto; simpl; intuition (rewrite notIn_dom_None); auto
      | reflexivity
      | f_equal; auto ].
Qed.

Theorem force_subst_In : forall m (A:formula m) l x u K (w:worlds K) eta,
  sub_name (dom eta) l ->
  x @ l ->
  w ||- ([l ! (x,u)::nil] A) [eta] ->
  w ||- A [eta]

  with subst_In_force : forall m (A:formula m) l x u K (w:worlds K) eta,
    sub_name (dom eta) l ->
    x @ l ->
    w ||- A [eta] ->
    w ||- ([l ! (x,u)::nil] A) [eta].
Proof.
  induction A as [m [p t] | m A1 IHA1 A2 IHA2 | m y A]; simpl; intros.
  rewrite <- psem_tsubst_In with (l:=l) (x:=x) (u:=u); assumption.

  clear IHA1 IHA2.
  apply force_subst_In with (l:=l)(x:=x)(u:=u);[ assumption | assumption | ].
  apply X; try assumption.
  apply subst_In_force; assumption.

  clear IHA.
  apply force_subst_In with (l:=y::l)(x:=x)(u:=u);
    [ simpl; apply incl_cons_3; exact H
      | apply in_cons; exact H0
      | apply X; assumption ].

  induction A as [m [p t] | m A1 IHA1 A2 IHA2 | m y A]; simpl; intros.
  rewrite psem_tsubst_In with (x:=x)(u:=u); assumption.

  clear IHA1 IHA2.
  apply subst_In_force; try assumption.
  apply X; try assumption.
  apply force_subst_In with (l:=l)(x:=x)(u:=u); assumption.

  clear IHA.
  apply subst_In_force;
    [ simpl; apply incl_cons_3; exact H
      | apply in_cons; exact H0
      | apply X; assumption ].
Qed.

Lemma psem_tsubst : forall m (t:term m) x l (u:(term nil)) K eta,
  sub_name (dom eta) l ->
  psem K t ((x, psem K u eta) :: eta) =
  psem K ([[(l \ x) ! (x,u):: nil]] t) eta.
Proof.
  induction t; simpl; intros;
    [ case_name; case_In;
      [ destruct (notIn_rm_1 x0 l); auto
        | pattern u at 1; rewrite (treloc_id u (sub_ov_term u)); apply reloc_psem
        | auto
        | rewrite notIn_dom_None; auto;
          contradict n0; unfold sublist in *; apply (@In_rm_2 name (name_Dec)); auto
      ]
      | reflexivity
      | f_equal; auto ].
Qed.

Theorem force_subst : forall m (A:formula m) x l (u:(term nil)) K (w:worlds K) eta,
  sub_name (dom eta) l ->
  w ||- A [(x, psem K u eta) :: eta] ->
  w ||- ([(l \ x) ! (x,u)::nil] A) [eta]

with subst_force : forall m (A:formula m) x l (u:term nil) K (w:worlds K) eta,
  sub_name (dom eta) l ->
  w ||- ([(l \ x) ! (x,u)::nil] A) [eta] ->
  w ||- A [(x, psem K u eta) :: eta].
Proof.
  { destruct A as [ [p t] | A1 A2 | y A ]; simpl; intros.
  - rewrite <- psem_tsubst; auto.
  - apply force_subst; auto; apply X; auto; apply subst_force with (l:=l); auto.
  - destruct (x == y) as [xyeq | xyneq].
    + apply subst_In_force.
      * simpl; apply (@incl_rm_4 name (name_Dec)); assumption.
      * rewrite xyeq; apply in_eq.
      * apply force_assoc_equiv with
              ((y, d) :: (x, psem K u eta) :: eta); auto; solve_assoc.
    + rewrite (@rm_cons name (name_Dec)); auto.
      apply force_subst;
        [ simpl; apply incl_cons_3; exact H
        |  rewrite psem_assoc_equiv with (eta0:= eta);
          [ apply force_assoc_equiv with
            ((y, d) :: (x, psem K u eta) :: eta); auto; solve_assoc
          | solve_assoc]
        ].
  }

  { destruct A as [ [p t] | A1 A2 | y A ]; simpl; intros.
    - rewrite <- psem_tsubst in X; auto.
    - apply subst_force with (l:=l); auto; apply X; auto; apply force_subst; auto.
    - destruct (x == y) as [xyeq | xyneq].
      + apply force_assoc_equiv with ((y,d) :: eta).
        * solve_assoc.
        * apply force_subst_In with (l:= y:: (l \ x))(x:=x)(u:=u).
          simpl; apply (@incl_rm_4 name name_Dec); auto.
          rewrite xyeq; auto with datatypes.
          apply X; auto.
      + rewrite (@rm_cons name name_Dec) in X; auto.
        apply force_assoc_equiv with ((x, psem K u eta) :: (y,d) :: eta).
        * solve_assoc.
        * rewrite psem_assoc_equiv with (eta0:= (y,d)::eta);
         [ apply subst_force with (l:= y::l);
            [ simpl; apply incl_cons_3; exact H
            | apply X; exact X0
            ]
          | solve_assoc
          ].
  }
Qed.


Require Import compcert.lib.Coqlib.

Require Import compcert.lib.Integers.

Require Import MSets.MSetPositive.
Import PositiveSet. Module PSet:= PositiveSet. (*For positive-indexed sets*)
Require Import FSets.FMapPositive.
Import PositiveMap. Module PMap:= PositiveMap. (*For positive-indexed maps*)
Require Import FSets.FMapFacts.

Module PMapsFacts:=  (WFacts_fun OrderedTypeEx.PositiveOrderedTypeBits PMap).
Import PMapsFacts.

(*+ First step: bearest of verifiers *)

(** * 1)Values *)
Inductive val: Type :=
| Vundef
  | Vint: int -> val. (*int is a machine *)

(** * 2) Types *)
Inductive type : Type :=
| Tint: type    (**r integer types *).

(** * 3) Expressions *)
Definition ident := positive.

Inductive expr : Type :=
  | Eval (v: val) (ty: type)  (**r constant *)
  | Evar (id: ident) (ty: type)  (**r constant *).

Definition type_of (e:expr): type:=
  match e with
    Eval _ ty => ty
  | Evar _ ty => ty
  end.

Fixpoint free_vars_expr (e:expr): PositiveSet.t:=
  match e with
    Eval _ _ => PositiveSet.empty
  | Evar id _ => singleton id
  end.

(** * 8) Environment *)
Require Import Coq.Classes.Morphisms.
Require Import Relation_Definitions.
Require Import Coq.Classes.RelationClasses.
Definition env:Type := PMap.t (val * type).
Definition find  (e:env) (k:ident) := PMap.find k e.
Definition env_fun_equiv: relation (positive -> option (val * type)) := pointwise_relation _ Logic.eq.
Global Instance Equivalenc_env_fun_equiv: Equivalence env_fun_equiv:= _.
Definition env_equiv: relation env := (fun x y => env_fun_equiv (find x) (find y)).
Global Instance Equivalenc_env_equiv: Equivalence env_equiv.
Proof.
  pose proof (Relations.inverse_image_of_equivalence _ _  find env_fun_equiv).
  destruct H; auto.
  constructor;
    destruct (Equivalenc_env_fun_equiv); eauto.
Qed.

Definition empty_env: env:= PMap.empty _.
Definition update_env (e:env) (k:ident) (ty:type) (v:val): env:=
  PMap.add k (v, ty) e.

Global Instance Proper_update_env: Proper ( env_equiv ==> Logic.eq ==>Logic.eq ==>Logic.eq ==> env_equiv) update_env.
Proof.
  intros ? ? ? ? ? ? ? ? ? ? ? ? id; subst.
  cbv delta [update_env] beta.
  destruct (Pos.eq_dec y0 id); auto.
  - subst. cbv [find]; repeat rewrite add_eq_o; eauto.
  - cbv [find]; repeat rewrite add_neq_o; eauto.
Qed.

Definition remove_env (e:env) (k:ident): env:=
  PMap.remove k e.
Global Instance Proper_remove_env: Proper ( env_equiv ==> Logic.eq ==> env_equiv) remove_env.
Proof.
  intros ? ? ? ? ? ? id; subst.
  cbv delta [remove_env] beta.
  destruct (Pos.eq_dec y0 id); auto.
  - subst. cbv [find]; repeat rewrite remove_eq_o; eauto.
  - cbv [find]; repeat rewrite remove_neq_o; eauto.
Qed.

Definition get_var_error (e:env) (k:ident) : val:=
  match find e k with
  | Some (v, _) => v
  | None => Vundef
  end.
Definition get_type (e:env) (k:ident): option type:=
  match find e k with
    None => None
  | Some (_, ty) => Some ty
  end.
Global Instance Proper_get_type: Proper ( env_equiv ==> Logic.eq ==> Logic.eq) get_type.
Proof.
  intros ? ? ? ? ? ?; subst.
  cbv [get_type]; rewrite H; reflexivity.
Qed.

Definition eval_expr (e:env) (ex:expr): option (val*type) :=
  match ex with
  | Eval v ty => Some (v,ty)
  | Evar id ty => (find e id)
  end.
Global Instance Proper_eval_expr: Proper ( env_equiv ==> Logic.eq ==> Logic.eq) eval_expr.
Proof.
  intros ? ? ? ? ? ?; subst.
  induction y0; simpl.
  - reflexivity.
  - rewrite H; reflexivity.
Qed.

(** * 4) Assertions *)
Inductive assertion:=
| Atrue : assertion
| Afalse : assertion
| Aand : assertion -> assertion -> assertion
| Aor : assertion -> assertion -> assertion
| Anot : assertion -> assertion
| Aexists : ident -> type -> assertion -> assertion
| Adefined : ident -> assertion
| Aexpr_type : expr -> type -> assertion
| Avar_type: ident -> type -> assertion
| Aeq: ident -> expr -> assertion. (* x == 5 *)

Fixpoint free_vars (A: assertion): PSet.t:= (*returns a set od positives*)
  match A with
  | Atrue | Afalse=> PSet.empty
  | Aand A1 A2 => union (free_vars A1) (free_vars A2)
  | Aor A1 A2 => union (free_vars A1) (free_vars A2)
  | Anot A' => free_vars A'
  | Aexists id _ A' => PSet.remove id (free_vars A')
  | Adefined id => singleton id
  | Aexpr_type e _ => free_vars_expr e
  | Avar_type id _ => singleton id
  | Aeq id e => PSet.add id (free_vars_expr e)
  end.

Definition fresh_var (A:assertion): positive:=
  match (max_elt (free_vars A)) with
  | Some x => x+1
  | None => 1
  end.

Definition expr_type (e:env)(ex:expr)(ty:type):=
  match ex with
  | Eval v ty' => ty = ty'
  | Evar id ty' => ty = ty' /\ get_type e id = Some ty
  end.

Global Instance Proper_expr_type: Proper ( env_equiv ==> Logic.eq ==>  Logic.eq ==> Logic.iff) expr_type.
Proof.
  intros ? ? ? ? ? ? ? ? ?; subst.
  induction y0; simpl.
  - reflexivity.
  - f_equiv. rewrite H; reflexivity.
Qed.

Fixpoint eval_assert (e: env) (P:assertion): Prop:=
  match P with
  | Atrue => True
  | Afalse => False
  | Aand P1 P2 => eval_assert e P1 /\ eval_assert e P2
  | Aor  P1 P2 => eval_assert e P1 \/ eval_assert e P2
  | Anot P => ~ eval_assert e P
  | Aexists id ty P => exists v, eval_assert (update_env e id ty v) P
  | Adefined id =>  ~ find e id = None
  | Aexpr_type ex ty => expr_type e ex ty
  | Avar_type id ty => get_type e id = Some ty
  | Aeq id ex2 => find e id = eval_expr e ex2
  end.

Global Instance Proper_eval_assert: Proper ( env_equiv ==> Logic.eq ==> Logic.iff) eval_assert.
Proof.
  intros ? ? ? ? ? ?.
  subst. generalize x y H. clear.
  induction y0;
    try solve[intros; split;auto];
    simpl; intros;
    try solve[rewrite H; reflexivity].
  - rewrite IHy0_1, IHy0_2; eauto; reflexivity.
  - rewrite IHy0_1, IHy0_2; eauto; reflexivity.
  - rewrite IHy0; eauto; reflexivity.
  - split; (
    intros HH; destruct HH as [v HH]; exists v;
    rewrite IHy0; eauto; f_equiv; auto; symmetry; auto ).
  - repeat rewrite H; tauto.
Qed.

(** * 5) Statements *)

Inductive statement : Type :=
  | Sskip : statement                   (**r do nothing *)
  | Sassign : ident -> type -> expr -> statement
  | Sassert : assertion -> statement
  | Sassume : assertion -> statement
.

(** * 6) Continuations*)
Inductive cont: Type:=
| Kstop
| Kseq: statement -> cont -> cont.

(** * 7) Knowledge*)
Definition knowledge:= assertion.

(** * 10) State *)

Inductive state : Type :=
  State : env ->
          statement ->
          cont -> state.

(** * 11)Smallstep semantics *)
Inductive step: state -> state-> Prop:=
| step_skip: forall e s c,
    step (State e Sskip (Kseq s c)) (State e s c)
| step_assign: forall e ex2 k ty v c,
    get_type e k = Some ty \/ get_type e k = None ->
    eval_expr e ex2 = Some (v, ty) ->
    step (State e (Sassign k ty ex2) c)
         (State (update_env e k ty v) Sskip c)
| step_assume: forall e P c,
    eval_assert e P ->
    step (State e (Sassert P) c)
         (State e  Sskip c)
| step_assert_pass: forall e P c s,
    eval_assert e P ->
    step (State e (Sassert P) (Kseq s c))
         (State e s c).

Inductive step_star: state -> state -> Prop:=
| stutter : forall st, step_star st st
| Star_step : forall st st' st'', step_star st st' ->
                             step st' st'' ->
                             step_star st st''.

Inductive safe_state:
  state-> Prop:=
| safe_skip: forall e k,
    safe_state (State e Sskip k)
| safe_assign: forall e ex2 k ty v c,
    get_type e k = Some ty \/ get_type e k = None ->
    eval_expr e ex2 = Some (v, ty) ->
    safe_state (State e (Sassign k ty ex2) c)
| safe_assume: forall e P c,
    safe_state (State e (Sassume P) c)
| safe_assert_pass: forall e P c,
    eval_assert e P ->
    safe_state (State e (Sassert P) c).

(** * 11) Safety *)
Definition Safe (st:state):Prop:=
  forall st', step_star st st' ->
         safe_state st'.

(** *Obligations and proofs*)
Notation obligations:= (list (assertion * assertion)). (*list (assertion |- assertion )*)

Definition assertion_entailment (entailment:assertion * assertion): Prop :=
  let (P,Q):= entailment in
  forall e, eval_assert e P -> eval_assert e Q.

Fixpoint list_entailment (entailments: list (assertion * assertion)): Prop :=
  match entailments with
    nil => True
  | ent::ents => assertion_entailment ent /\ list_entailment ents
  end.

(** *Predicate evaluator*)
Definition assert_expr_defined (e:expr): assertion:=
  match e with
    Eval v ty => Atrue
   | Evar id ty => Adefined id
  end.

(* kge' := x = v /\ exists x, kge *)
(* kge' := x = temp /\ exists temp, temp = ex2 /\ exists x, kge *)
Definition weakest_pre (stm:statement)(*Postcondition = True*) :assertion:= (*weakest liberal precondition*)
  match stm with
    Sskip => Atrue
  | Sassign id ty e2 => Aand (Aand (Aexpr_type e2 ty) (assert_expr_defined e2)) (Aor (Avar_type id ty) (Anot (Adefined id)))
  | Sassert P => P
  | Sassume P => Atrue
  end.

Definition evaluate_statements (phi:assertion)(stm:statement): assertion:=
  match stm with
  | Sskip =>  phi
  | Sassign id ty ex => (* id = expr*)
    (*Ex. temp. x=temp /\ Ex. x.  temp = e /\ P*)
    let temp:= fresh_var phi in
    Aexists temp ty (Aand (Aeq id (Evar temp ty)) (Aexists id ty (Aand (Aeq temp ex) phi)))
  | Sassert A => (Aand A phi)
  | Sassume A => (Aand A phi)
  end.

Fixpoint evaluate_continuation (phi:assertion)(k:cont): obligations :=
  match k with
  | Kstop => nil
  | Kseq stm k' =>
    (phi, weakest_pre stm):: (evaluate_continuation (evaluate_statements phi stm) k')
  end.

(** *Verifier Guarantee*)
(* Proof that verification implies safety*)

Lemma expre_eval_safe:
  forall e ex ty,
    expr_type e ex ty ->
    eval_assert e (assert_expr_defined ex) ->
    exists v,  eval_expr e ex = Some (v, ty).
Proof.
  intros.
  destruct ex; simpl.
  - econstructor; simpl in H;
      inversion H; subst; reflexivity.
  - cbn in H0.
    simpl in H.
    cbv [get_type] in H.
    destruct (find e id);
      try solve [contradiction; eapply H0; eauto].
    simpl in H; destruct H.
    destruct p; inversion H1; subst.
    clear H0.
    Set Keep Proof Equalities.
    injection H1; intros; subst.
    econstructor; reflexivity.
Qed.

Lemma wealest_pre_safe_st:
  forall e stm k,
    eval_assert e (weakest_pre stm) ->
    safe_state (State e stm k).
Proof.
  intros.
  destruct stm; try solve[ constructor; auto].
  simpl in H.
  destruct H as [[H1 H2] H3].
  destruct (expre_eval_safe _ _ _ H1 H2).
  econstructor; eauto.
  destruct H3; [left|right]; auto.
  cbv [get_type].
  destruct (find e i); auto.
  contradict H0; intros HH; discriminate.
Qed.

Definition invariant (st:state):=
  match st with
  | State e stm k =>
    exists phi,
    eval_assert e phi /\
    eval_assert e (weakest_pre stm) /\
    list_entailment (evaluate_continuation (evaluate_statements phi stm) k)
  end.

Lemma step_preservation:
  forall st st',
    step st st' ->
    invariant st ->
    invariant st'.
Proof.
  intros.
  inversion H; subst.
  - cbv delta[invariant] beta iota in H0;
      destruct H0 as [phi [phi_OK [stm_OK entailments]]].

    cbv delta [evaluate_statements] beta iota.
    exists phi.
    split; auto.
    cbv delta [list_entailment evaluate_continuation] beta iota in entailments.
    destruct entailments as [A B].
    apply A in phi_OK.
    split; auto.
  - destruct H0 as [phi [phi_OK [stm_OK entailments]]].
    cbv [evaluate_statements] in entailments.
    exists (evaluate_statements phi (Sassign k ty ex2)).
    split.
    +

      Lemma redundant_update:
        forall e i ty v ty' v',
          env_equiv (update_env (update_env e i ty v) i ty' v')
                    (update_env e i ty' v').
      Proof.
        intros ? ? ? ? ? ? id.
        cbv delta[update_env find] beta.
        destruct (peq i id).
        - repeat rewrite add_eq_o; auto.
        - repeat rewrite add_neq_o; auto.
      Qed.
      Lemma add_eq_o' : forall m x e,
          @PMap.find (val*type) x (PMap.add x e m) = Some e.
      Proof.
        intros; apply add_eq_o; reflexivity.
      Qed.
      Lemma update_comm:
        forall e i j ty v ty' v',
          i <> j ->
          env_equiv (update_env (update_env e i ty v) j ty' v')
                    (update_env (update_env e j ty' v') i ty v).
      Proof.
        intros ? ? ? ? ? ? ? NEQ id.
        cbv delta[update_env find] beta.
        destruct (peq i id); destruct (peq j id); subst;
          try solve[contradiction NEQ; auto];
          repeat (repeat rewrite add_eq_o';
                  rewrite add_neq_o;
                  repeat rewrite add_eq_o'); auto.
      Qed.
      Lemma expr_type_update:
        forall k ex,
          ~ PSet.In k (free_vars_expr ex) ->
          forall e ty ty' v, expr_type (update_env e k ty' v) ex ty <->
                        expr_type e ex ty.
      Proof.
        intros; destruct ex; try tauto.
        simpl in *. f_equiv.
        rewrite PSet.singleton_spec in H.
        cbv delta[get_type update_env find] beta.
        rewrite add_neq_o; auto. reflexivity.
      Qed.
      Lemma get_type_update:
        forall k i,
          k <> i ->
          forall e ty' v, get_type (update_env e k ty' v) i =
                     get_type e i.
      Proof.
        intros; try tauto.
        cbv delta[get_type update_env find] beta.
        rewrite add_neq_o; auto.
      Qed.
      Lemma eval_expr_update:
        forall k ex,
          ~ PSet.In k (free_vars_expr ex) ->
          forall e ty v,
            eval_expr (update_env e k ty v) ex =
            eval_expr e ex.
      Proof.
        intros.
        destruct ex; simpl in *; auto.
        rewrite PSet.singleton_spec in H.
        cbv [find update_env]. rewrite add_neq_o; auto.
      Qed.
      Lemma free_vars_update:
        forall k phi,
          ~ PSet.In k (free_vars phi) ->
          forall e ty v,
            eval_assert (update_env e k ty v) phi <->
            eval_assert e phi.
      Proof.
        intros ? ? ?. induction phi; eauto; try reflexivity.
        - intros; simpl; f_equiv; first [apply IHphi1 | apply IHphi2];
            auto; intros HH; apply H; simpl; apply union_spec;
              [left| right]; assumption.
        - intros; simpl; f_equiv; [ apply IHphi1|  apply IHphi2]; auto;
            intros HH; apply H; simpl; apply union_spec;
              [left| right]; assumption.
        - intros; simpl; f_equiv.
          apply IHphi; assumption.
        - intros; simpl.
          split; intros [v' HH]; exists v'.
          + destruct (E.eq_dec k i).
            * subst.

              pose proof (redundant_update e i ty v t0 v').
              rewrite <- H0; auto.
            * idtac.

              rewrite update_comm in HH; auto.
              rewrite <- IHphi; eauto.
              intros IN.
              apply H.
              eapply remove_spec; split; auto.
          + destruct (E.eq_dec k i).
            * subst; rewrite redundant_update; eauto.
            * rewrite update_comm; auto.
              rewrite IHphi; eauto.
              intros IN.
              apply H.
              eapply remove_spec; split; auto.
        - intros.
          simpl in *.
          rewrite singleton_spec in H.
          cbv delta[update_env find] beta.
          rewrite add_neq_o; tauto.
        - intros.
          simpl in *.

          rewrite expr_type_update; eauto; reflexivity.

        - intros.
          simpl in *.

          rewrite PSet.singleton_spec in H.

          rewrite get_type_update; eauto; reflexivity.
        - intros.
          simpl in *.
          rewrite PSet.add_spec in H.
          apply Classical_Prop.not_or_and in H; destruct H.

          f_equiv. cbv [find update_env]; rewrite add_neq_o; auto.

          apply eval_expr_update; auto.

      Qed.
      Lemma fresh_var_spec:
        forall phi,
          ~ PSet.In (fresh_var phi) (free_vars phi).
      Proof.
        intros.
        cbv delta[fresh_var] beta iota zeta; intros AA.
        destruct (max_elt (free_vars phi)) eqn:BB.
        - eapply PSet.max_elt_spec2 in BB; eauto.
          apply BB; eauto.
          simpl.
          unfold elt in *.
          clear.
          admit. (*positive arithmetic*)
        - apply PSet.max_elt_spec3 in BB.
          eapply BB; eauto.
      Admitted.
      Lemma assertion_assignment_ok:
        forall e k v ty ex2 phi,
          eval_assert e phi ->
          eval_assert e (weakest_pre (Sassign k ty ex2)) ->
          eval_assert (update_env e k ty v) (evaluate_statements phi (Sassign k ty ex2)).
      Proof.
        intros.
        destruct H0 as [[EXtype EXdef] Kdef].
        repeat econstructor.

        - simpl.
          destruct (peq (fresh_var phi) k).
          + simpl.
            cbv delta[find update_env] beta.
            repeat rewrite add_eq_o; auto.
          + simpl.
            cbv delta[find update_env] beta.
            rewrite add_neq_o; auto.
            rewrite add_eq_o; auto.
            rewrite add_eq_o; auto.
        -  simpl.
           instantiate (1:= get_var_error e k).
           simpl in EXtype.
           admit.
        - destruct (peq (fresh_var phi) k).
          + rewrite <- e0.
            subst; repeat rewrite free_vars_update;
              eauto.
            apply fresh_var_spec.
            apply fresh_var_spec.
            apply fresh_var_spec.
          + rewrite update_comm; auto.
            rewrite free_vars_update;
              try apply fresh_var_spec.
            rewrite redundant_update.
            unfold get_var_error.
            destruct Kdef.
            * simpl in H0; unfold get_type in H0.
              destruct (find e k) eqn:HH; try congruence.
              destruct p. inversion H0; subst.

              Lemma pointless_update:
                forall e k v ty,
                  find e k = Some (v, ty) ->
                  env_equiv (update_env e k ty v)
                            e.
              Proof.
                intros ? ? ? ? ? id.
                unfold update_env, find.
                destruct (peq k id).
                - rewrite add_eq_o; symmetry; subst; auto.
                - rewrite add_neq_o; auto.
              Qed.

              rewrite pointless_update; auto.
            * simpl in *. destruct (find e k) eqn:HH.
              contradict H0. intros ?; congruence.
              admit.
      Admitted.

        (*The following lemma is loosely the progress lemms*)
        (*In some sense, safe states are the once that can step*)
        Lemma invariant_safety:
          forall st,
            invariant st ->
            safe_state st.
        Proof.
          cbv [invariant]; destruct st as [e s k].
          intros INV; destruct INV as [phi [phi_OK [stm_OK entailments]]].
          destruct s; try solve[econstructor].
          - cbv [weakest_pre eval_assert assert_expr_defined] in stm_OK.
            destruct stm_OK as [[E_ty HH] DEFINED].
            destruct e0.
            + econstructor.
              * destruct DEFINED; eauto.
                right. cbv [get_type].
                destruct (find e i); try reflexivity.
                contradict H; discriminate.
              * simpl in *; subst ty; reflexivity.
            + simpl in *. destruct E_ty; subst ty.
              cbv [get_type] in H0. destruct (e id) eqn:Eid; try discriminate.
              destruct p. inversion H0; subst t1.
              econstructor.
              * destruct DEFINED; eauto.
                right. cbv [get_type].
                destruct (e i); try reflexivity.
                contradict H; discriminate.
              * simpl in *. eassumption.
          - constructor.
            assumption.

        Qed.

        Lemma star_preservation:
          forall st st',
            step_star st st' ->
            invariant st ->
            invariant st'.
        Proof.
          intros ? ? STAR.
          Require Import  Program.Equality.
          dependent induction STAR; auto.
          intros IH; apply IHSTAR in IH; clear IHSTAR.
          eapply step_preservation; eauto.
        Qed.

        Lemma star_safety:
          forall st,
            invariant st ->
            forall st',
              step_star st st' ->
              safe_state st'.
        Proof.
          intros.
          apply invariant_safety.
          apply star_preservation with st; auto.
        Qed.

        Section VerificationSafety.

          Context (verified_program: cont)
                  (program_obligations: obligations)
                  ( Precondition: assertion)
                  (program_verified: evaluate_continuation Atrue verified_program = program_obligations)
                  (verifier_guaranty: list_entailment program_obligations).

          Lemma initial_invariant:
            invariant (State empty_env Sskip verified_program).
          Proof.
            exists Atrue. repeat (split; auto).
            cbv [evaluate_statements].
            rewrite program_verified.
            apply verifier_guaranty.
          Qed.

          Theorem verifier_correctness:
            Safe (State empty_env Sskip verified_program).
          Proof.
            intros st' step.
            eapply star_safety with (State empty_env Sskip verified_program); auto.
            apply initial_invariant.
          Qed.

        End VerificationSafety.

        (*Delete later:

Inductive Safe': state -> Prop:=
| Safe_Stop: forall e, Safe' (State Sskip Kstop e)
| Safe_Step:
    forall st st',
      Safe' st' ->
      step st st' ->
      Safe' st.

(** * Examples *)

(*
  "a" = 1
  "b" = 2
  \\ assert "a" == 1
  \\ assert "b" == 2

         *)
         *)


Require Import AutoSep.

Lemma allocate_array' : forall p n offset,
  allocated p offset n ===> Ex ls, [| length ls = n |] * array ls (p ^+ $(offset)).
  induction n; simpl.

  sepLemma.
  instantiate (1 := nil); auto.
  sepLemma.

  intros; sepLemmaLhsOnly.
  etransitivity; [ eapply himp_star_frame; [ apply IHn | reflexivity ] | ]; clear IHn.
  sepLemmaLhsOnly.
  apply himp_ex_c; exists (x :: x0).
  sepLemma.
  etransitivity; [ eapply himp_star_frame; [ apply Arrays.ptsto32m'_in | reflexivity ] | ].
  etransitivity; [ | apply ptsto32m'_out ].
  simpl.
  destruct offset; simpl.
  replace (p ^+ natToW 0) with p by words; sepLemma.
  etransitivity; [ | apply ptsto32m'_shift_base ].
  instantiate (1 := 4); reflexivity.
  auto.
  replace (p ^+ natToW (S offset) ^+ $0) with (p ^+ natToW (S offset)) by words.
  sepLemma.
  etransitivity; [ | apply ptsto32m'_shift_base ].
  instantiate (1 := 4).
  rewrite <- wplus_assoc.
  rewrite <- natToW_plus.
  replace (S offset + 4) with (S (S (S (S (S offset))))) by omega.
  reflexivity.
  auto.
Qed.

Inductive make_array : Prop := MakeArray.

Hint Constructors make_array.

Lemma allocate_array : forall p n,
  p = p
  -> make_array
  -> p =?> n ===> Ex ls, [| length ls = n |] * array ls p.
  intros; eapply Himp_trans; [ apply allocate_array' | ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
Qed.

Lemma free_array' : forall p n offset,
  Ex ls, [| length ls = n |] * array ls (p ^+ $(offset)) ===> allocated p offset n.
  sepLemma.
  etransitivity; [ apply ptsto32m_allocated | ].
  etransitivity; [ apply allocated_shift_base | ].
  3: sepLemma.
  unfold natToW; W_eq.
  auto.
Qed.

Inductive dissolve_array : Prop := DissolveArray.

Hint Constructors dissolve_array.

Lemma free_array : forall p n,
  p = p
  -> dissolve_array
  -> Ex ls, [| length ls = n |] * array ls p ===> p =?> n.
  intros; eapply Himp_trans; [ | apply free_array' ].
  replace (p ^+ $0) with p by words; apply Himp_refl.
Qed.

Lemma selN_updN_eq : forall v a n,
  (n < length a)%nat
  -> Array.selN (Array.updN a n v) n = v.
  induction a; destruct n; simpl; intuition.
Qed.

Lemma selN_upd_eq : forall v a n,
  (n < length a)%nat
  -> goodSize (length a)
  -> Array.selN (Array.upd a (natToW n) v) n = v.
  intros; rewrite upd_updN.
  apply selN_updN_eq; auto.
  eauto using goodSize_weaken.
Qed.

Lemma inc : forall n (w : W) l,
  n = wordToNat l
  -> w < natToW n
  -> w ^+ natToW 1 <= l.
  intros; subst.
  assert (exists b, w < b) by eauto.
  pre_nomega.
  destruct H.
  erewrite <- next; eauto.
  unfold natToW in *; rewrite natToWord_wordToNat in *.
  auto.
Qed.

Theorem natToW_wordToNat : forall w : W,
  natToW (wordToNat w) = w.
  intros; apply natToWord_wordToNat.
Qed.

Theorem wordToNat_inj : forall sz (u v : word sz),
  wordToNat u = wordToNat v
  -> u = v.
  intros; rewrite <- (natToWord_wordToNat u); rewrite <- (natToWord_wordToNat v); congruence.
Qed.