Require Import Coq.Logic.Classical.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.ramification_lemmas.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.EnumEnsembles.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.Relation_ext.
Require Import RamifyCoq.lib.Equivalence_ext.
Require Import RamifyCoq.lib.Morphisms_ext.
Require Import RamifyCoq.msl_ext.log_normalize.
Require Import RamifyCoq.msl_ext.iter_sepcon.
Require Import RamifyCoq.msl_ext.ramification_lemmas.
Require Import RamifyCoq.msl_ext.abs_addr.
Require Import RamifyCoq.msl_ext.seplog.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.graph.reachable_ind.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.dag.
Require Import RamifyCoq.graph.FiniteGraph.

Local Open Scope logic.

Class PointwiseGraph (V E: Type) {VE: EqDec V eq} {EE: EqDec E eq} (GV GE: Type): Type := {
  pg_sg: PreGraph V E;
  vgamma: V -> GV;
  egamma: E -> GE
}.

Arguments pg_sg {V E _ _ GV GE} _.
Arguments vgamma {V E _ _ GV GE} _ _.
Arguments egamma {V E _ _ GV GE} _ _.

Class PointwiseGraphPred (V E GV GE Pred: Type): Type := {
  vertex_at: V -> GV -> Pred;
  edge_at: E -> GE -> Pred
}.

Class PointwiseGraphBasicAssum (V E: Type) := {
  SGBA_VE: EqDec V eq;
  SGBA_EE: EqDec E eq
}.

Existing Instances SGBA_VE SGBA_EE.

Class PointwiseGraphAssum {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E}:= {
  SGP_ND: NatDed Pred;
  SGP_SL : SepLog Pred;
  SGP_ClSL: ClassicalSep Pred;
  SGP_CoSL: CorableSepLog Pred
}.

Existing Instances SGP_ND SGP_SL SGP_ClSL SGP_CoSL.

Class PointwiseGraphAssum_vs {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} {SGA: PointwiseGraphAssum SGP} :=
  vertex_at_sep: sepcon_unique2 (@vertex_at _ _ _ _ _ SGP).

Class PointwiseGraphAssum_es {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} {SGA: PointwiseGraphAssum SGP} :=
  edge_at_sep: sepcon_unique2 (@edge_at _ _ _ _ _ SGP).

Class PointwiseGraphAssum_vn {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} {SGA: PointwiseGraphAssum SGP} (vnull: V) :=
  vertex_at_not_null: forall gx, @derives Pred _ (vertex_at vnull gx) FF.

Class PointwiseGraphAssum_en {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} {SGA: PointwiseGraphAssum SGP} (enull: E) :=
  edge_at_not_null: forall ge, @derives Pred _ (edge_at enull ge) FF.

Instance AAV {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} : AbsAddr V GV.
  apply (mkAbsAddr V GV (fun x y => if equiv_dec x y then true else false)); simpl; intros.
  + destruct_eq_dec p1 p2; destruct_eq_dec p2 p1; congruence.
  + destruct_eq_dec p1 p1; destruct_eq_dec p1 p2; congruence.
Defined.

Instance AAE {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} : AbsAddr E GE.
  apply (mkAbsAddr E GE (fun x y => if equiv_dec x y then true else false)); simpl; intros.
  + destruct_eq_dec p1 p2; destruct_eq_dec p2 p1; congruence.
  + destruct_eq_dec p1 p1; destruct_eq_dec p1 p2; congruence.
Defined.

Class PointwiseGraphStrongAssum {V E GV GE Pred: Type} (SGP: PointwiseGraphPred V E GV GE Pred) {SGBA: PointwiseGraphBasicAssum V E} {SGA: PointwiseGraphAssum SGP} := {
  SGP_PSL: PreciseSepLog Pred;
  SGP_OSL: OverlapSepLog Pred;
  SGP_DSL: DisjointedSepLog Pred;
  SGP_COSL: CorableOverlapSepLog Pred;

  VP_MSL: MapstoSepLog (AAV SGP) vertex_at;
  VP_sMSL: StaticMapstoSepLog (AAV SGP) vertex_at;
  EP_MSL: MapstoSepLog (AAE SGP) edge_at;
  EP_sMSL: StaticMapstoSepLog (AAE SGP) edge_at
}.

Existing Instances SGP_PSL SGP_OSL SGP_DSL SGP_COSL VP_MSL VP_sMSL EP_MSL EP_sMSL.

Class PointwiseGraphConstructor (V E DV DE DG GV GE: Type) {SGBA: PointwiseGraphBasicAssum V E}:= {
  compute_vgamma: LabeledGraph V E DV DE DG -> V -> GV;
  compute_egamma: LabeledGraph V E DV DE DG -> E -> GE
}.

Section Local_PointwiseGraphConstructor.

Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Class Local_PointwiseGraphConstructor (V E DV DE DG GV GE: Type) {SGBA: PointwiseGraphBasicAssum V E} {SGC: PointwiseGraphConstructor V E DV DE DG GV GE} := {
  vguard: LabeledGraph V E DV DE DG -> V -> Prop;
  compute_vgamma_local: forall (G1 G2: LabeledGraph V E DV DE DG) (x: V),
    vguard G1 x ->
    vguard G2 x ->
    vlabel G1 x = vlabel G2 x ->
    (forall e, evalid G1 e /\ src G1 e = x <-> evalid G2 e /\ src G2 e = x) ->
    (forall e, evalid G1 e -> src G1 e = x -> evalid G2 e -> src G2 e = x -> dst G1 e = dst G2 e) ->
    (forall e, evalid G1 e -> src G1 e = x -> evalid G2 e -> src G2 e = x -> elabel G1 e = elabel G2 e) ->
    compute_vgamma G1 x = compute_vgamma G2 x;
  eguard: LabeledGraph V E DV DE DG -> E -> Prop;
  compute_egamma_local: forall (G1 G2: LabeledGraph V E DV DE DG) (e: E),
    eguard G1 e ->
    eguard G2 e ->
    elabel G1 e = elabel G2 e ->
    src G1 e = src G2 e ->
    dst G1 e = dst G2 e ->
    compute_egamma G1 e = compute_egamma G2 e
}.

End Local_PointwiseGraphConstructor.

Section GENERAL_SPATIAL_GRAPH.

Context {V E GV GE: Type}.
Context {SGBA: PointwiseGraphBasicAssum V E}.

Section PURE_FACTS.

Definition vertices_identical (PV: Ensemble V): relation (PointwiseGraph V E GV GE) :=
  respectful_relation vgamma (guarded_pointwise_relation PV eq).

Definition vertices_identical0: relation (PointwiseGraph V E GV GE) :=
  vertices_identical (fun _ => True).

Definition vertices_identical2 (PV1 PV2: Ensemble V) (g1 g2: PointwiseGraph V E GV GE) : Prop :=
  Same_set PV1 PV2 /\ vertices_identical PV1 g1 g2.

Instance vertices_identical_proper: Proper (Same_set ==> eq ==> eq ==> iff) vertices_identical.
Proof.
  hnf; intros.
  hnf; intros G1 G1' ?; subst G1'.
  hnf; intros G2 G2' ?; subst G2'.
  unfold vertices_identical, respectful_relation.
  split; intros.
  + rewrite guarded_pointwise_relation_spec in H0 |- *.
    intros; apply H0.
    rewrite (app_same_set H); auto.
  + rewrite guarded_pointwise_relation_spec in H0 |- *.
    intros; apply H0.
    rewrite <- (app_same_set H); auto.
Qed.
Global Existing Instance vertices_identical_proper.

Lemma vertices_identical_spec: forall PV g1 g2,
  vertices_identical PV g1 g2 <-> (forall x, PV x -> vgamma g1 x = vgamma g2 x).
Proof.
  intros.
  unfold vertices_identical, respectful_relation.
  rewrite guarded_pointwise_relation_spec; intros.
  tauto.
Qed.

Lemma vertices_identical2_spec: forall PV1 PV2 g1 g2,
  vertices_identical2 PV1 PV2 g1 g2 <->
  Same_set PV1 PV2 /\
  (forall x, PV1 x -> PV2 x -> vgamma g1 x = vgamma g2 x).
Proof.
  intros.
  unfold vertices_identical2.
  rewrite vertices_identical_spec.
  assert (Same_set PV1 PV2 -> (forall x, PV1 x -> PV2 x)) by (rewrite Same_set_spec; intros; firstorder).
  firstorder.
Qed.

Instance vertices_identical_Equivalence (PV: Ensemble V): Equivalence (vertices_identical PV).
  apply resp_Equivalence.
  apply guarded_pointwise_equivalence.
  apply eq_equivalence.
Defined.

Instance vertices_identical0_Equivalence: Equivalence vertices_identical0.
  apply vertices_identical_Equivalence.
Defined.

(* vertices_identical2 is not a equivalence relation, because it is not reflexive. *)
Global Existing Instance vertices_identical0_Equivalence.
Global Existing Instance vertices_identical_Equivalence.

Lemma vertices_identical_weaken: forall PV1 PV2 g1 g2,
  Included PV2 PV1 ->
  vertices_identical PV1 g1 g2 ->
  vertices_identical PV2 g1 g2.
Proof.
  intros.
  unfold vertices_identical, respectful_relation in *.
  eapply guarded_pointwise_relation_weaken; eauto.
Qed.

Lemma vertices_identical0_vertices_identical: forall PV g1 g2,
  vertices_identical0 g1 g2 ->
  vertices_identical PV g1 g2.
Proof.
  intros.
  eapply vertices_identical_weaken; eauto.
  hnf; intros.
  exact I.
Qed.

Lemma vertices_identical0_is_vertices_identical: forall g1 g2,
  vertices_identical0 g1 g2 <-> vertices_identical (fun _ => True) g1 g2.
Proof.
  reflexivity.
Qed.

Lemma vertices_identical_vertices_identical2: forall PV g1 g2,
  vertices_identical PV g1 g2 <-> vertices_identical2 PV PV g1 g2.
Proof.
  intros.
  unfold vertices_identical2.
  assert (Same_set PV PV) by reflexivity.
  tauto.
Qed.

Definition spatialgraph_vgen (g: PointwiseGraph V E GV GE) (x: V) (a: GV) : PointwiseGraph V E GV GE := Build_PointwiseGraph _ _ _ _ _ _ (pg_sg g) (fun v => if (equiv_dec x v) then a else vgamma g v) (egamma g).

Definition single_vertex_spatialgraph (x: V) (a: GV) (default_e: GE) : PointwiseGraph V E GV GE := Build_PointwiseGraph _ _ _ _ _ _ (single_vertex_pregraph x) (fun _ => a) (fun _ => default_e).

Lemma update_self: forall (g: PointwiseGraph V E GV GE) (x: V) (d: GV), vgamma g x = d -> vertices_identical0 g (spatialgraph_vgen g x d).
Proof.
  intros.
  unfold vertices_identical0.
  rewrite vertices_identical_spec; intros.
  intros.
  simpl.
  destruct_eq_dec x x0; subst; auto.
Qed.

Lemma update_irr: forall (PV: Ensemble V) (g: PointwiseGraph V E GV GE) (x: V) (d: GV), ~ PV x -> vertices_identical PV g (spatialgraph_vgen g x d).
Proof.
  intros.
  unfold vertices_identical0.
  rewrite vertices_identical_spec; intros.
  intros.
  simpl.
  destruct_eq_dec x x0; subst; auto.
  tauto.
Qed.

Definition edges_identical (PE: Ensemble E) (g1 g2: PointwiseGraph V E GV GE) : Prop :=
  guarded_pointwise_relation PE eq (egamma g1) (egamma g2).

Definition edges_identical0 (g1 g2: PointwiseGraph V E GV GE) : Prop :=
  pointwise_relation _ eq (egamma g1) (egamma g2).

Definition edges_identical2 (PE1 PE2: Ensemble E) (g1 g2: PointwiseGraph V E GV GE) : Prop :=
  Same_set PE1 PE2 /\
  guarded_pointwise_relation PE1 eq (egamma g1) (egamma g2).

Instance edges_identical_proper: Proper (Same_set ==> eq ==> eq ==> iff) edges_identical.
Proof.
  hnf; intros. hnf; intros G1 G1' ?; subst G1'. hnf; intros G2 G2' ?; subst G2'. unfold edges_identical, respectful_relation. split; intros.
  + rewrite guarded_pointwise_relation_spec in H0 |- *. intros; apply H0. rewrite (app_same_set H); auto.
  + rewrite guarded_pointwise_relation_spec in H0 |- *. intros; apply H0. rewrite <- (app_same_set H); auto.
Qed.
Global Existing Instance edges_identical_proper.

(* TODO: add some properties for edges_identical. *)

Lemma spacialgraph_gen_vgamma: forall (g: PointwiseGraph V E GV GE) (x: V) (d: GV), vgamma (spatialgraph_vgen g x d) x = d.
Proof.
  intros.
  simpl.
  destruct_eq_dec x x; auto.
  congruence.
Qed.

End PURE_FACTS.

Section SPATIAL_FACTS.

Context {Pred: Type}.
Context {SGP: PointwiseGraphPred V E GV GE Pred}.
Context {SGA: PointwiseGraphAssum SGP}.
Notation Graph := (PointwiseGraph V E GV GE).

Definition graph_vcell (g: Graph) (v : V) : Pred := vertex_at v (vgamma g v).
Definition graph_ecell (g: Graph) (e : E) : Pred := edge_at e (egamma g e).
Definition vertices_at (P: V -> Prop) (g: Graph): Pred := pred_sepcon P (graph_vcell g).
Definition edges_at (P: E -> Prop) (g: Graph): Pred := pred_sepcon P (graph_ecell g).

Definition Gamma (g: Graph) x := (x, vgamma g x).

Definition Graph_vcell (p : V * GV) := vertex_at (fst p) (snd p).

Lemma Gamma_injective: forall g x y, Gamma g x = Gamma g y -> x = y.
Proof. intros. unfold Gamma in H. inversion H. auto. Qed.

Lemma vertices_at_vertices_identical2: forall (g1 g2: Graph) (P1 P2: V -> Prop),
  vertices_identical2 P1 P2 g1 g2 ->
  vertices_at P1 g1 = vertices_at P2 g2.
Proof.
  intros.
  apply pred_sepcon_strong_proper.
  + destruct H.
    rewrite Same_set_spec in H; auto.
  + intros.
    unfold graph_vcell.
    f_equal.
    destruct H.
    rewrite vertices_identical_spec in H2.
    apply H2; auto.
Qed.

Lemma vertices_at_vertices_identical: forall (g1 g2 : Graph) (P : V -> Prop),
  vertices_identical P g1 g2 -> vertices_at P g1 = vertices_at P g2.
Proof.
  intros.
  apply vertices_at_vertices_identical2.
  split; [reflexivity | auto].
Qed.

Lemma vertices_at_vertices_identical0: forall (g1 g2 : Graph) (P : V -> Prop),
  vertices_identical0 g1 g2 -> vertices_at P g1 = vertices_at P g2.
Proof.
  intros.
  apply vertices_at_vertices_identical.
  apply vertices_identical0_vertices_identical; auto.
Qed.

Lemma vertices_at_Same_set: forall (g : Graph) (P Q: V -> Prop),
  Same_set P Q -> vertices_at P g = vertices_at Q g.
Proof.
  intros.
  apply vertices_at_vertices_identical2.
  split; [auto | reflexivity].
Qed.

Lemma vertices_at_False: forall (g: Graph),
  vertices_at (fun _ => False) g = emp.
Proof.
  intros.
  apply pred_sepcon_False.
Qed.

Lemma vertices_at_Empty: forall (g: Graph),
  vertices_at (Empty_set _) g = emp.
Proof.
  intros.
  apply pred_sepcon_Empty.
Qed.

(*************************************

Ramification Lemmas

*************************************)

Lemma vertices_at_ramif_1Q: forall {A: Type} (Pure: A -> Prop) (g: Graph) (P: V -> Prop) x (g': A -> Graph) (P': A -> V -> Prop) (x': A -> V),
  (exists F,
     Prop_join (eq x) F P /\
     (forall a, Pure a -> Prop_join (eq (x' a)) F (P' a)) /\
     (forall a, Pure a -> vertices_identical F g (g' a))) ->
  vertices_at P g |-- vertex_at x (vgamma g x) *
    (ALL a: A, !! Pure a -->
      (vertex_at (x' a) (vgamma (g' a) (x' a)) -* vertices_at (P' a) (g' a))).
Proof.
  intros.
  unfold vertices_at.
  change (@vertex_at _ _ _ _ _ SGP x (vgamma g x)) with (graph_vcell g x).
  RAMIF_Q'.formalize.
  change ((fun a : A => vertex_at (x' a) (vgamma (g' a) (x' a)))) with
    ((fun a : A => graph_vcell (g' a) (x' a))).
  simpl.
  apply (pred_sepcon_ramif_1Q Pure P P' (graph_vcell g) (fun a => graph_vcell (g' a)) x x').
  destruct H as [F [? [? ?]]].
  exists F; split; [| split]; auto.
  intros.
  unfold graph_vcell; f_equal.
  specialize (H1 a H2).
  rewrite vertices_identical_spec in H1.
  apply H1; auto.
Qed.

Lemma vertices_at_ramif_xQ: forall {A: Type} (Pure: A -> Prop) (g: Graph) (G L: V -> Prop) (g': A -> Graph) (L' G': A -> V -> Prop),
  (exists F,
     Prop_join L F G /\
     (forall a, Pure a -> Prop_join (L' a) F (G' a)) /\
     (forall a, Pure a -> vertices_identical F g (g' a))) ->
  vertices_at G g |-- vertices_at L g *
    (ALL a: A, !! Pure a -->
      (vertices_at (L' a) (g' a) -* vertices_at (G' a) (g' a))).
Proof.
  intros.
  unfold vertices_at.
  apply pred_sepcon_ramif_xQ.
  destruct H as [F [? [? ?]]].
  exists F; split; [| split]; auto.
  intros.
  unfold graph_vcell; f_equal.
  specialize (H1 a H2).
  rewrite vertices_identical_spec in H1.
  apply H1; auto.
Qed.

Lemma vertices_at_ramif_1: forall (g g': Graph) (P P': V -> Prop) x x' d d',
  (exists F,
     Prop_join (eq x) F P /\
     Prop_join (eq x') F P' /\
     vertices_identical F g g') ->
  vgamma g x = d ->
  vgamma g' x' = d' ->
  vertices_at P g |-- vertex_at x d * (vertex_at x' d' -* vertices_at P' g').
Proof.
  intros.
  subst.
  change (@vertex_at _ _ _ _ _ SGP x (vgamma g x)) with (graph_vcell g x).
  change (@vertex_at _ _ _ _ _ SGP x' (vgamma g' x')) with (graph_vcell g' x').
  apply pred_sepcon_ramif_1.
  destruct H as [F [? [? ?]]].
  exists F; split; [| split]; auto.
  intros.
  unfold graph_vcell; f_equal.
  rewrite vertices_identical_spec in H1.
  apply H1; auto.
Qed.

Lemma vertices_at_ramif_1_stable: forall (g: Graph) (P: V -> Prop) x d,
  vgamma g x = d ->
  P x ->
  vertices_at P g |-- vertex_at x d * (vertex_at x d -* vertices_at P g).
Proof.
  intros.
  apply vertices_at_ramif_1.
  eexists.
  split; [| split].
  + apply Ensemble_join_Intersection_Complement.
    - unfold Included, Ensembles.In; intros; subst.
      auto.
    - intros.
      apply decidable_prop_decidable.
      apply equiv_dec.
  + apply Ensemble_join_Intersection_Complement.
    - unfold Included, Ensembles.In; intros; subst.
      auto.
    - intros.
      apply decidable_prop_decidable.
      apply equiv_dec.
  + reflexivity.
  + auto.
  + auto.
Qed.

Lemma vertices_at_ramif_x: forall (g g': Graph) (G L L' G': V -> Prop),
  (exists F,
     Prop_join L F G /\
     Prop_join L' F G' /\
     vertices_identical F g g') ->
  vertices_at G g |-- vertices_at L g * (vertices_at L' g' -* vertices_at G' g').
Proof.
  intros.
  apply pred_sepcon_ramif_x.
  destruct H as [F [? [? ?]]].
  exists F; split; [| split]; auto.
  intros.
  unfold graph_vcell; f_equal.
  rewrite vertices_identical_spec in H1.
  apply H1; auto.
Qed.

Lemma vertices_at1: forall (g: Graph) P x0 d,
  (forall x, P x <-> x0 = x) ->
  vgamma g x0 = d ->
  vertices_at P g = vertex_at x0 d.
Proof.
  intros.
  replace (@vertex_at _ _ _ _ _ SGP x0 d) with (graph_vcell g x0).
  2: {
    simpl.
    unfold graph_vcell; simpl.
    rewrite H0; auto.
  }
  erewrite vertices_at_Same_set.
  + apply pred_sepcon1.
  + rewrite Same_set_spec.
    intro x; specialize (H x).
    assert (x = x0 <-> x0 = x) by (split; congruence).
    tauto.
Qed.

Lemma vertices_at_sepcon_x1: forall (g: Graph) x P P' d,
  Prop_join P (eq x) P' ->
  vgamma g x = d ->
  vertices_at P g * vertex_at x d = vertices_at P' g.
Proof.
  intros.
  subst d.
  change (vertex_at x (vgamma g x)) with (graph_vcell g x).
  destruct H.
  symmetry; apply pred_sepcon_sepcon1.
  + firstorder.
  + firstorder.
Qed.

Lemma vertices_at_sepcon_1x: forall (g: Graph) x P P' d,
  Prop_join P (eq x) P' ->
  vgamma g x = d ->
  vertex_at x d * vertices_at P g = vertices_at P' g.
Proof.
  intros.
  rewrite sepcon_comm.
  apply vertices_at_sepcon_x1; auto.
Qed.

Lemma vertices_at_sepcon_xx: forall (g: Graph) P1 P2 P,
  Prop_join P1 P2 P ->
  vertices_at P1 g * vertices_at P2 g = vertices_at P g.
Proof.
  intros.
  apply pred_sepcon_sepcon; auto.
Qed.

Lemma sepcon_unique_graph_vcell {SGA_vs: PointwiseGraphAssum_vs SGP}:
  sepcon_unique1 graph_vcell.
Proof.
  pose proof vertex_at_sep.
  unfold sepcon_unique1, sepcon_unique2, graph_vcell in *.
  simpl.
  intros.
  apply H.
Qed.

Lemma vertices_at_sepcon_unique_x1 {SGA_vs: PointwiseGraphAssum_vs SGP}: forall (g: Graph) x P d,
  vertices_at P g * vertex_at x d |-- !! (~ P x).
Proof.
  intros.
  apply not_prop_right; intros.
  eapply derives_trans; [apply sepcon_derives; [apply pred_sepcon_prop_true; eauto | apply derives_refl] |].
  unfold graph_vcell.
  rewrite sepcon_comm, <- sepcon_assoc.
  eapply derives_trans; [apply sepcon_derives; [apply vertex_at_sep | apply derives_refl] |].
  normalize.
Qed.

Lemma vertices_at_sepcon_unique_1x {SGA_vs: PointwiseGraphAssum_vs SGP}: forall (g: Graph) x P d,
  vertex_at x d * vertices_at P g |-- !! (~ P x).
Proof.
  intros.
  rewrite sepcon_comm.
  apply vertices_at_sepcon_unique_x1; auto.
Qed.

Lemma vertices_at_sepcon_unique_xx {SGA_vs: PointwiseGraphAssum_vs SGP}: forall (g1 g2: Graph) P1 P2,
  vertices_at P1 g1 * vertices_at P2 g2 |-- !! Disjoint _ P1 P2.
Proof.
  intros.
  eapply derives_trans with (!! (forall x, P1 x -> P2 x -> False)).
  2: apply prop_derives; rewrite Disjoint_spec; auto.
  rewrite prop_forall_allp.
  apply allp_right; intro x.
  rewrite !prop_impl_imp.
  apply imp_andp_adjoint; normalize.
  apply imp_andp_adjoint; normalize.
  eapply derives_trans; [apply sepcon_derives; apply pred_sepcon_prop_true; eauto |].
  rewrite sepcon_assoc, (sepcon_comm TT), !sepcon_assoc.
  rewrite TT_sepcon_TT, <- sepcon_assoc.
  unfold graph_vcell.
  eapply derives_trans; [apply sepcon_derives; [apply vertex_at_sep | apply derives_refl] |].
  normalize.
Qed.

Lemma neg_pure_from_vertices_at: forall (g: Graph) (P Q: V -> Prop),
  (forall (x: V) (gx: GV), Q x -> @derives _ SGP_ND (vertex_at x gx) FF) ->
  vertices_at P g |-- !! (Disjoint _ P Q).
Proof.
  intros.
  unfold vertices_at.
  apply neg_pure_from_pred_sepcon.
  intros.
  unfold graph_vcell.
  apply H; auto.
Qed.

Section SPATIAL_FACTS_STRONG_ASSU.

Context {SGSA: PointwiseGraphStrongAssum SGP}.

Lemma precise_graph_cell: forall g v, precise (graph_vcell g v).
Proof. intros. unfold graph_vcell. apply (@mapsto_precise _ _ _ _ _ _ _ _ VP_MSL). Qed.

Lemma sepcon_unique_graph_cell: forall g, sepcon_unique1 (graph_vcell g).
Proof.
  repeat intro. unfold graph_vcell.
  apply (@mapsto_conflict _ _ _ _ _ _ _ _ _ _ _ VP_sMSL).
  simpl.
  destruct_eq_dec x x; congruence.
Qed.

Lemma joinable_graph_cell : forall g, joinable (graph_vcell g).
Proof.
  intros. unfold joinable; intros. unfold graph_vcell. apply (@disj_mapsto _ _ (AAV SGP) _ _ _ _ _ _ VP_MSL _ VP_sMSL).
  simpl.
  destruct_eq_dec x y; congruence.
Qed.

End SPATIAL_FACTS_STRONG_ASSU.

End SPATIAL_FACTS.

Section SPATIAL_CONSTRUCTOR.

Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Context {DV DE DG: Type}.
Context {SGC: PointwiseGraphConstructor V E DV DE DG GV GE}.
Context {L_SGC: Local_PointwiseGraphConstructor V E DV DE DG GV GE}.

Section PURE_FACTS.

Definition Graph_PointwiseGraph (G: LabeledGraph V E DV DE DG) : PointwiseGraph V E GV GE :=
  Build_PointwiseGraph _ _ _ _ _ _ G (compute_vgamma G) (compute_egamma G).

Lemma GSG_VGenPreserve: forall P (G: LabeledGraph V E DV DE DG) x lx gx,
  gx = vgamma (Graph_PointwiseGraph (labeledgraph_vgen G x lx)) x ->
  Included P (vguard G) ->
  Included P (vguard (labeledgraph_vgen G x lx)) ->
  vertices_identical P (Graph_PointwiseGraph (labeledgraph_vgen G x lx)) (spatialgraph_vgen (Graph_PointwiseGraph G) x gx).
Proof.
  intros.
  rewrite vertices_identical_spec.
  intros.
  simpl.
  destruct_eq_dec x x0.
  + subst; auto.
  + apply compute_vgamma_local; auto.
    - apply H1; auto.
    - apply H0; auto.
    - simpl.
      unfold update_vlabel.
      destruct_eq_dec x x0; congruence.
    - simpl; intros.
      tauto.
Qed.

(* The counterpart of subgraph version is not true. *)
Lemma GSG_PartialGraphPreserve: forall P (G1 G2: LabeledGraph V E DV DE DG),
  Included P (vguard G1) ->
  Included P (vguard G2) ->
  Included P (vvalid G1) ->
  Included P (vvalid G2) ->
  ((predicate_partial_labeledgraph G1 P) ~=~ (predicate_partial_labeledgraph G2 P))%LabeledGraph ->
  vertices_identical P (Graph_PointwiseGraph G1) (Graph_PointwiseGraph G2).
Proof.
  intros.
  unfold vertices_identical, respectful_relation.
  rewrite guarded_pointwise_relation_spec.
  intros.
  simpl.
  rename H4 into HP.
  unfold Included, Ensembles.In in H, H0, H1, H2.
  destruct H3 as [[? [? [? ?]]] [? ?]].
  simpl in H3, H4, H5, H6, H7, H8.
  unfold predicate_weak_evalid, predicate_vvalid in H3, H4, H5, H6, H7, H8.
  apply compute_vgamma_local; auto.
  + intros.
    split; intros [? ?]; subst; firstorder.
  + intros; subst.
    firstorder.
  + intros; subst.
    firstorder.
Qed.

Lemma GSG_PartialGraphPreserve2: forall P1 P2 (G1 G2: LabeledGraph V E DV DE DG),
  Included P1 (vguard G1) ->
  Included P2 (vguard G2) ->
  Included P1 (vvalid G1) ->
  Included P2 (vvalid G2) ->
  ((predicate_partial_labeledgraph G1 P1) ~=~ (predicate_partial_labeledgraph G2 P2))%LabeledGraph ->
  vertices_identical2 P1 P2 (Graph_PointwiseGraph G1) (Graph_PointwiseGraph G2).
Proof.
  intros.
  assert (Same_set P1 P2).
  + destruct H3 as [[? _] _].
    rewrite Same_set_spec; unfold pointwise_relation.
    simpl in H3; unfold predicate_vvalid in H3.
    unfold Included, Ensembles.In in H1, H2.
    firstorder.
  + rewrite <- H4 in *.
    split; auto.
    apply GSG_PartialGraphPreserve; auto.
Qed.

End PURE_FACTS.

Section SPATIAL_FACTS.

Context {Pred: Type}.
Context {SGP: PointwiseGraphPred V E GV GE Pred}.
Context {SGA: PointwiseGraphAssum SGP}.
Notation Graph := (LabeledGraph V E DV DE DG).

Definition full_vertices_at (g: Graph): Pred := vertices_at (vvalid g) (Graph_PointwiseGraph g).

Definition reachable_vertices_at (x : V) (g: Graph): Pred := vertices_at (reachable g x) (Graph_PointwiseGraph g).

Definition reachable_vertices_at' (x : V) (g1 g2: Graph): Pred := vertices_at (reachable g2 x) (Graph_PointwiseGraph g1).

Definition reachable_dag_vertices_at (x: V) (g: Graph): Pred := !! localDag g x && vertices_at (reachable g x) (Graph_PointwiseGraph g).

Definition reachable_through_vertices_at (S : list V) (g : Graph): Pred := vertices_at (reachable_through_set g S) (Graph_PointwiseGraph g).

Definition reachable_through_dag_vertices_at (S : list V) (g : Graph): Pred := !! (Forall (localDag g) S) && vertices_at (reachable_through_set g S) (Graph_PointwiseGraph g).

Lemma va_reachable_reachable_through: forall g x, reachable_vertices_at x g = reachable_through_vertices_at (x :: nil) g.
Proof.
  intros.
  unfold reachable_vertices_at, reachable_through_vertices_at.
  apply pred_sepcon_proper; [| reflexivity].
  intro y.
  pose proof reachable_through_set_single g x y.
  tauto.
Qed.

Lemma va_reachable_vertices_identical2: forall (g1 g2 : Graph) x,
  vertices_identical2 (reachable g1 x) (reachable g2 x) (Graph_PointwiseGraph g1) (Graph_PointwiseGraph g2) ->
  reachable_vertices_at x g1 = reachable_vertices_at x g2.
Proof.
  intros.
  apply vertices_at_vertices_identical2; auto.
Qed.

Lemma va_reachable_partialgraph_eq: forall (g1 g2 : Graph) x,
  Included (reachable g1 x) (vguard g1) ->
  Included (reachable g2 x) (vguard g2) ->
  ((predicate_partial_labeledgraph g1 (reachable g1 x)) ~=~ (predicate_partial_labeledgraph g2 (reachable g2 x)))%LabeledGraph ->
  reachable_vertices_at x g1 = reachable_vertices_at x g2.
Proof.
  intros. apply va_reachable_vertices_identical2.
  apply GSG_PartialGraphPreserve2; auto.
  + hnf; intros.
    apply reachable_foot_valid in H2; auto.
  + hnf; intros.
    apply reachable_foot_valid in H2; auto.
Qed.

Lemma va_reachable_eq: forall (g1 g2 : Graph) x,
  Included (reachable g1 x) (vguard g1) ->
  Included (reachable g2 x) (vguard g2) ->
  (g1 ~=~ g2)%LabeledGraph ->
  reachable_vertices_at x g1 = reachable_vertices_at x g2.
Proof.
  intros.
  apply va_reachable_partialgraph_eq; auto.
  rewrite H1 at 1.
  destruct H1 as [? _].
  rewrite H1.
  reflexivity.
Qed.

Lemma va_reachable_through_vertices_identical2: forall (g1 g2 : Graph) S,
  vertices_identical2 (reachable_through_set g1 S) (reachable_through_set g2 S) (Graph_PointwiseGraph g1) (Graph_PointwiseGraph g2) ->
  reachable_through_vertices_at S g1 = reachable_through_vertices_at S g2.
Proof.
  intros.
  apply vertices_at_vertices_identical2; auto.
Qed.

Lemma va_reachable_through_partialgraph_eq: forall (g1 g2 : Graph) S,
  Included (reachable_through_set g1 S) (vguard g1) ->
  Included (reachable_through_set g2 S) (vguard g2) ->
  ((predicate_partial_labeledgraph g1 (reachable_through_set g1 S)) ~=~ (predicate_partial_labeledgraph g2 (reachable_through_set g2 S)))%LabeledGraph ->
  reachable_through_vertices_at S g1 = reachable_through_vertices_at S g2.
Proof.
  intros. apply va_reachable_through_vertices_identical2.
  apply GSG_PartialGraphPreserve2; auto.
  + hnf; intros.
    apply reachable_through_set_foot_valid in H2; auto.
  + hnf; intros.
    apply reachable_through_set_foot_valid in H2; auto.
Qed.

Lemma va_reachable_through_eq: forall (g1 g2 : Graph) S,
  Included (reachable_through_set g1 S) (vguard g1) ->
  Included (reachable_through_set g2 S) (vguard g2) ->
  (g1 ~=~ g2)%LabeledGraph ->
  reachable_through_vertices_at S g1 = reachable_through_vertices_at S g2.
Proof.
  intros.
  apply va_reachable_through_partialgraph_eq; auto.
  rewrite H1 at 1.
  destruct H1 as [? _].
  rewrite H1.
  reflexivity.
Qed.

Lemma va_reachable_invalid: forall(g: Graph) x, ~ vvalid g x -> reachable_vertices_at x g = emp.
Proof.
  intros.
  unfold reachable_vertices_at.
  erewrite <- vertices_at_False.
  apply vertices_at_Same_set.
  rewrite Same_set_spec; intros ?.
  split; try tauto.
  intros.
  apply reachable_head_valid in H0; auto.
Qed.

Lemma localDag_vertices_unfold: forall (g: Graph) x S, vvalid g x -> localDag g x -> step_list g x S -> reachable_vertices_at x g = vertex_at x (vgamma (Graph_PointwiseGraph g) x) * reachable_through_vertices_at S g.
Proof.
  intros.
  symmetry.
  apply vertices_at_sepcon_1x; auto.
  apply localDag_reachable_spec'; auto.
Qed.

Lemma localDag_graph_gen_step_list: forall (g: Graph) x S d,
  vvalid g x ->
  localDag g x ->
  step_list g x S ->
  Included (reachable_through_set g S) (vguard g) ->
  Included (reachable_through_set g S) (vguard (labeledgraph_vgen g x d)) ->
  reachable_through_vertices_at S g = reachable_through_vertices_at S (labeledgraph_vgen g x d).
Proof.
  intros.
  apply va_reachable_through_partialgraph_eq; auto.
  split; [reflexivity | split; intros; [| reflexivity]].
  simpl.
  unfold update_vlabel.
  destruct_eq_dec x v; [exfalso | auto].
  destruct (localDag_reachable_spec g x S H H0 H1).
  destruct H4.
  symmetry in H6; revert H6.
  apply H8; auto.
Qed.

Lemma va_reachable_dag_unfold {SGA_vs: PointwiseGraphAssum_vs SGP}: forall (g: Graph) x S d,
  vvalid g x ->
  step_list g x S ->
  vgamma (Graph_PointwiseGraph g) x = d ->
  reachable_dag_vertices_at x g = vertex_at x d * reachable_through_dag_vertices_at S g.
Proof.
  intros.
  subst.
  unfold reachable_dag_vertices_at, reachable_through_dag_vertices_at.
  apply pred_ext; normalize.
  + apply andp_right.
    - apply prop_right.
      rewrite Forall_forall; intros.
      eapply local_dag_step; eauto.
      rewrite (H0 x0) in H2; auto.
    - apply derives_refl'.
      apply localDag_vertices_unfold; auto.
  + assert ((vertex_at x (vgamma (Graph_PointwiseGraph g) x): Pred) * vertices_at (reachable_through_set g S) (Graph_PointwiseGraph g)
   |-- !!localDag g x).
    - eapply derives_trans; [apply vertices_at_sepcon_unique_1x; auto |].
      apply prop_derives; intro.
      eapply localDag_step_rev; eauto.
    - rewrite (add_andp _ _ H2); normalize.
      apply derives_refl'.
      symmetry; apply localDag_vertices_unfold; auto.
Qed.

Lemma va_reachable_dag_update_unfold {SGA_vs: PointwiseGraphAssum_vs SGP}: forall (g: Graph) x S d d',
  vvalid g x ->
  step_list g x S ->
  vgamma (Graph_PointwiseGraph (labeledgraph_vgen g x d)) x = d' ->
  Included (reachable_through_set g S) (vguard g) ->
  Included (reachable_through_set g S) (vguard (labeledgraph_vgen g x d)) ->
  reachable_dag_vertices_at x (labeledgraph_vgen g x d) = vertex_at x d' * reachable_through_dag_vertices_at S g.
Proof.
  intros.
  erewrite va_reachable_dag_unfold by eauto.
  unfold reachable_through_dag_vertices_at.
  normalize.
  f_equal.
  rewrite (add_andp _ _ (vertices_at_sepcon_unique_1x _ _ _ _)).
  rewrite (add_andp _ _ (vertices_at_sepcon_unique_1x (Graph_PointwiseGraph g) _ _ d')).
  rewrite !(andp_comm _ (!! _)).
  apply andp_prop_ext; [reflexivity |].
  intros.
  f_equal.
  apply va_reachable_through_partialgraph_eq; auto.
  split; [reflexivity | split; intros; [| reflexivity]].
  simpl.
  unfold update_vlabel.
  destruct_eq_dec x v; [exfalso | auto].
  subst v.
  simpl in H6; clear H5.
  destruct H6 as [? [y [? ?]]].
  simpl in H4.
  apply H4.
  exists y; split; auto.
Qed.

Lemma va_reachable_root_stable_ramify: forall (g: Graph) (x: V) (gx: GV),
  vgamma (Graph_PointwiseGraph g) x = gx ->
  vvalid g x ->
  @derives Pred _
    (reachable_vertices_at x g)
    (vertex_at x gx * (vertex_at x gx -* reachable_vertices_at x g)).
Proof.
  intros.
  subst.
  unfold reachable_vertices_at.
  apply vertices_at_ramif_1_stable; auto.
  apply reachable_refl; auto.
Qed.

Lemma va_reachable_root_update_ramify: forall (g: Graph) (x: V) (lx: DV) (gx gx': GV),
  vvalid g x ->
  vgamma (Graph_PointwiseGraph g) x = gx ->
  vgamma (Graph_PointwiseGraph (labeledgraph_vgen g x lx)) x = gx' ->
  Included (Intersection V (reachable g x) (Complement V (eq x))) (vguard g) ->
  Included (Intersection V (reachable g x) (Complement V (eq x))) (vguard (labeledgraph_vgen g x lx)) ->
  @derives Pred _
    (reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx' -* reachable_vertices_at x (labeledgraph_vgen g x lx))).
Proof.
  intros.
  subst.
  unfold reachable_vertices_at.
  apply vertices_at_ramif_1; auto.
  eexists.
  split; [| split].
  + apply Ensemble_join_Intersection_Complement.
    - unfold Included, Ensembles.In; intros; subst.
      apply reachable_refl; auto.
    - intros.
      apply decidable_prop_decidable.
      apply equiv_dec.
  + apply Ensemble_join_Intersection_Complement.
    - unfold Included, Ensembles.In; intros; subst.
      apply reachable_refl; auto.
    - intros.
      apply decidable_prop_decidable.
      apply equiv_dec.
  + apply GSG_PartialGraphPreserve; auto.
    - unfold Included, Ensembles.In; intros; subst.
      rewrite Intersection_spec in H0.
      destruct H0 as [? _].
      apply reachable_foot_valid in H0; auto.
    - unfold Included, Ensembles.In; intros; subst.
      rewrite Intersection_spec in H0.
      destruct H0 as [? _].
      apply reachable_foot_valid in H0; auto.
    - apply si_stronger_partial_labeledgraph_simple with (Complement V (eq x)).
      * apply Intersection2_Included, Included_refl.
      * apply lg_vgen_stable.
Qed.

Lemma va_reachable_internal_stable_ramify: forall (g: Graph) (x y: V) (gy: GV),
  vvalid g y ->
  vgamma (Graph_PointwiseGraph g) y = gy ->
  reachable g x y ->
  @derives _ _
    (reachable_vertices_at x g)
    (vertex_at y gy *
      (vertex_at y gy -* reachable_vertices_at x g)).
Proof.
  intros.
  subst.
  apply vertices_at_ramif_1_stable; auto.
Qed.

Lemma va_labeledgraph_add_edge_eq: forall (g: Graph) e s d data,
  ~ evalid g e ->
  let g' := labeledgraph_add_edge g e s d data in
(*  vertices_identical (Intersection V (vvalid g) (fun x : V => s <> x))
     (Graph_PointwiseGraph g) (Graph_PointwiseGraph g') -> *)
  Included (Intersection _ (vvalid g) (fun x => s <> x)) (vguard g) ->
  Included (Intersection _ (vvalid g') (fun x => s <> x)) (vguard g') ->
  vertices_at (Intersection _ (vvalid g) (fun x => s <> x)) (Graph_PointwiseGraph g) = vertices_at (Intersection _ (vvalid g') (fun x => s <> x)) (Graph_PointwiseGraph g').
Proof.
  intros.
  apply vertices_at_vertices_identical2.
  split; [simpl; reflexivity |].
  rewrite vertices_identical_spec; intros.
  apply compute_vgamma_local.
  + apply H0; auto.
  + apply H1; auto.
  + reflexivity.
  + intros.
    simpl.
    unfold addValidFunc, updateEdgeFunc.
    rewrite Intersection_spec in H2.
    destruct H2.
    destruct_eq_dec e e0.
    - subst e0; tauto.
    - assert (e0 <> e) by congruence; tauto.
  + simpl; unfold addValidFunc, updateEdgeFunc; intros.
    destruct_eq_dec e e0.
    - subst e0; exfalso; tauto.
    - reflexivity.
  + simpl; unfold addValidFunc, updateEdgeFunc, update_elabel; intros.
    destruct_eq_dec e e0.
    - subst e0; exfalso; tauto.
    - reflexivity.
Qed.

Lemma partialgraph_update:
  forall (g g': Graph) (S1 S1' S2: list V),
    (vertices_identical2 (reachable_through_set (predicate_partialgraph g (Intersection _ (vvalid g) (Complement _ (reachable_through_set g S1)))) S2) (reachable_through_set (predicate_partialgraph g' (Intersection _ (vvalid g') (Complement _ (reachable_through_set g' S1')))) S2) (Graph_PointwiseGraph g) (Graph_PointwiseGraph g')) ->
    Included (reachable_through_set (predicate_partialgraph g (Intersection _ (vvalid g) (Complement _ (reachable_through_set g S1)))) S2) (vguard g) ->
    Included (reachable_through_set (predicate_partialgraph g' (Intersection _ (vvalid g') (Complement _ (reachable_through_set g' S1')))) S2) (vguard g') ->
    reachable_through_vertices_at (S1 ++ S2) g |-- reachable_through_vertices_at S1 g * (reachable_through_vertices_at S1' g' -* reachable_through_vertices_at (S1' ++ S2) g').
Proof.
  intros.
  unfold reachable_through_vertices_at.
  apply vertices_at_ramif_x.
  exists (reachable_through_set (predicate_partialgraph g (Intersection _ (vvalid g) (Complement _ (reachable_through_set g S1)))) S2).
  split; [| split].
  + split.
    - intros.
      rewrite <- (unreachable_eq' g S1 S2).
      rewrite <- reachable_through_set_app. tauto. (* TODO: This tauto use LEM automatically. *)
    - intros.
      rewrite <- (unreachable_eq' g S1 S2) in H3.
      tauto.
  + split.
    - intros.
      destruct H as [? _].
      rewrite (app_same_set H).
      rewrite <- (unreachable_eq' g' S1' S2).
      rewrite <- reachable_through_set_app; tauto.
    - intros.
      destruct H as [? _].
      rewrite (app_same_set H) in H3.
      rewrite <- (unreachable_eq' g' S1' S2) in H3.
      tauto.
  + destruct H; auto.
Qed.

(*
(* TODO: resume these lemmas *)

Lemma full_vertices_at_ramify1: forall (g: Graph) x d d',
  vvalid g x ->
  vgamma g x = d ->
  full_vertices_at g |-- vertex_at x d * (vertex_at x d' -* full_vertices_at (spatialgraph_vgen g x d')).
Proof.
  intros.
  apply vertices_at_ramify1; auto.
Qed.

Lemma graph_ramify_aux0: forall (g: Graph) {rfg: ReachableFiniteGraph g} x d d',
  vvalid g x -> vgamma g x = d ->
  graph x g |-- vertex_at x d * (vertex_at x d' -* graph x (spatialgraph_vgen g x d')).
Proof.
  intros.
  apply vertices_at_ramify1; auto.
  apply reachable_refl; auto.
Qed.
 *)

Context {SGSA: PointwiseGraphStrongAssum SGP}.
Import OconNotation.

Fixpoint graphs (l : list V) (g: Graph) :=
  match l with
    | nil => emp
    | v :: l' => reachable_vertices_at v g ⊗ graphs l' g
  end.

Lemma graphs_app: forall (g : Graph) S1 S2, graphs (S1 ++ S2) g = graphs S1 g ⊗ graphs S2 g.
Proof.
  intros. induction S1; simpl.
  + rewrite ocon_comm, ocon_emp. auto.
  + rewrite IHS1. rewrite ocon_assoc. auto.
Qed.

Lemma graphs_graphs': forall S (g: Graph) {rfg: ReachableFiniteGraph g}
  (V_DEC: forall x : V, In x S -> Decidable (vvalid g x)),
  graphs S g = reachable_through_vertices_at S g.
Proof.
  induction S; intros until g; intros rfg V_DEC.
  + unfold graphs. unfold reachable_through_vertices_at, vertices_at, pred_sepcon. apply pred_ext.
    - apply (exp_right nil). simpl. apply andp_right; auto.
      apply andp_right; [| apply prop_right; constructor].
      apply prop_right. intro x. split; intros.
      * inversion H.
      * unfold reachable_through_set in H. destruct H as [s [? _]]. inversion H.
    - normalize. intro l; intros. normalize. destruct l; simpl; auto.
      specialize (H v). assert (In v (v :: l)) by apply in_eq.
      rewrite H in H1. unfold reachable_through_set in H1.
      destruct H1 as [s [? _]]. inversion H1.
  + unfold graphs. fold graphs. rewrite IHS; [| auto | intros; apply V_DEC; right; auto].
    unfold reachable_through_vertices_at, reachable_vertices_at, vertices_at, pred_sepcon. clear IHS. apply pred_ext.
    - normalize_overlap. intros. rename x into la.
      normalize_overlap. rename x into lS. normalize_overlap.
      rewrite (add_andp _ _ (iter_sepcon_unique_nodup la (sepcon_unique_graph_cell (Graph_PointwiseGraph g)))).
      rewrite (add_andp _ _ (iter_sepcon_unique_nodup lS (sepcon_unique_graph_cell (Graph_PointwiseGraph g)))).
      normalize_overlap.
      rewrite (iter_sepcon_ocon equiv_dec); auto. apply (exp_right (nodup equiv_dec (la ++ lS))).
      apply andp_right; [apply andp_right |].
      * apply prop_right.
        unfold reachable_set_list in *.
        unfold reachable_list in *. intros.
        rewrite nodup_In.
        rewrite reachable_through_set_eq.
        specialize (H1 x). specialize (H x).
        split; intro; [apply in_app_or in H3 | apply in_or_app];
        destruct H3; [left | right | left | right]; tauto.
      * apply prop_right.
        apply NoDup_nodup.
      * auto.
      * apply precise_graph_cell.
      * apply joinable_graph_cell.
    - normalize. intro l; intros. assert (In a (a :: S)) by apply in_eq.
      destruct (construct_reachable_list g a) as [la [? ?]]; [apply V_DEC; left; auto |].
      normalize_overlap. apply (exp_right la).
      destruct (construct_reachable_set_list g S) as [lS [? ?]]; [intros; apply V_DEC; right; auto |].
      normalize_overlap. apply (exp_right lS). normalize_overlap.
      rewrite (add_andp _ _ (iter_sepcon_unique_nodup l (sepcon_unique_graph_cell (Graph_PointwiseGraph g)))).
      normalize. rewrite (iter_sepcon_ocon equiv_dec); auto.
      2: apply precise_graph_cell.
      2: apply joinable_graph_cell.
      rewrite iter_sepcon_permutation with (l2 := nodup equiv_dec (la ++ lS)); auto.
      apply NoDup_Permutation; auto. apply NoDup_nodup.
      intros. rewrite nodup_In. clear -H H2 H5.
      specialize (H x). specialize (H2 x). specialize (H5 x). rewrite H.
      rewrite reachable_through_set_eq. rewrite in_app_iff. tauto.
Qed.

Lemma graph_unfold:
  forall (g: Graph) {rfg: ReachableFiniteGraph g} x S
         (V_DEC: forall x : V, In x S -> Decidable (vvalid g x)),
    vvalid g x ->
    step_list g x S ->
    reachable_vertices_at x g = vertex_at x (vgamma (Graph_PointwiseGraph g) x) ⊗ graphs S g.
Proof.
  intros. rewrite graphs_graphs'; auto. unfold reachable_vertices_at. unfold reachable_through_vertices_at.
  change (vertex_at x (vgamma (Graph_PointwiseGraph g) x)) with (graph_vcell (Graph_PointwiseGraph g) x).
  assert (forall y, reachable g x y <-> x = y \/ reachable_through_set g S y). {
    intros. rewrite (reachable_ind' g x S); intuition.
  } symmetry. apply pred_sepcon_ocon1; intros.
  + apply SGBA_VE.
  + apply RFG_reachable_through_set_decicable; auto.
  + specialize (H1 a). intuition.
  + apply precise_graph_cell.
  + apply joinable_graph_cell.
Qed.

Lemma precise_graph: forall (g: Graph) {rfg: ReachableFiniteGraph g} x,
    Decidable (vvalid g x) -> precise (reachable_vertices_at x g).
Proof.
  intros. unfold reachable_vertices_at. unfold vertices_at. rewrite pred_sepcon_eq.
  apply (precise_exp_iter_sepcon).
  + apply sepcon_unique_graph_cell.
  + destruct (construct_reachable_list g x H) as [l [? ?]].
    left; exists l. intuition.
  + apply precise_graph_cell.
  + intros. apply NoDup_Permutation; auto.
    destruct H0, H1. split; intros; specialize (H0 x0); specialize (H1 x0); intuition.
Qed.

Lemma subgraph_update:
  forall (g g': Graph) {rfg: ReachableFiniteGraph g} {rfg': ReachableFiniteGraph g'} (S1 S1' S2: list V),
    (forall x : V, In x (S1 ++ S2) -> Decidable (vvalid g x)) ->
    (forall x : V, In x (S1' ++ S2) -> Decidable (vvalid g' x)) ->
    vertices_identical2
     (reachable_through_set
        (predicate_partialgraph g
           (Intersection V (vvalid g)
              (Complement V (reachable_through_set g S1)))) S2)
     (reachable_through_set
        (predicate_partialgraph g'
           (Intersection V (vvalid g')
              (Complement V (reachable_through_set g' S1')))) S2)
     (Graph_PointwiseGraph g) (Graph_PointwiseGraph g') ->
    Included
     (reachable_through_set
        (predicate_partialgraph g
           (Intersection V (vvalid g)
              (Complement V (reachable_through_set g S1)))) S2)
     (vguard g) ->
    Included
     (reachable_through_set
        (predicate_partialgraph g'
           (Intersection V (vvalid g')
              (Complement V (reachable_through_set g' S1')))) S2)
     (vguard g') ->
    graphs S1 g ⊗ graphs S2 g |-- graphs S1 g * (graphs S1' g' -* graphs S1' g' ⊗ graphs S2 g').
Proof.
  intros. rewrite <- !graphs_app.
  rewrite !graphs_graphs'; auto.
  2: intros; apply X0; rewrite in_app_iff; left; auto.
  2: intros; apply X; rewrite in_app_iff; left; auto.
  apply partialgraph_update; auto.
Qed.

End SPATIAL_FACTS.

End SPATIAL_CONSTRUCTOR.

End GENERAL_SPATIAL_GRAPH.


From MetaCoq.Utils Require Import utils.
From MetaCoq.Template Require Import All.

Set Primitive Projections.

Record Eq (A : Type) := { eq : A -> A -> bool; eq_proof : forall x y, eq x y = true <-> x = y }.

Record Sigma (A : Type) (B : A -> Type) : Type :=
  { fst : A ; snd : B fst }.
Arguments fst {A B}.
Arguments snd {A B}.

MetaCoq Quote Recursively Definition foo := (fst, snd).

Program Definition eqnat : Eq nat := {| eq x y := true |}.
Next Obligation. Admitted.

MetaCoq Quote Recursively Definition eqnatr := eqnat.

Goal forall {A} {e : Eq A} x y, e.(eq _) x y = eq _ e x y.
Proof.
  intros.
  match goal with
   |- ?T => quote_term T (fun x => pose (qgoal:=x))
  end.
  match goal with
    H:= context [Ast.tProj {| proj_ind := Kernames.mkInd _ 0; proj_npars := 1; proj_arg := 0 |} _] |- _ => idtac
  end.
  reflexivity.
Qed.

Record prod' A B : Type :=
  pair' { fst' : A ; snd' : B }.
Arguments fst' {A B} _.
Arguments snd' {A B} _.

MetaCoq Test Quote ((pair' _ _ true 4).(snd')).

MetaCoq Test Quote prod'.

Require Import List String.
Import ListNotations.

Definition qprod' := mkInd (MPfile ["proj"; "TestSuite"; "MetaCoq"], "prod'") 0.
Definition qnat := mkInd (MPfile ["Datatypes"; "Init"; "Coq"], "nat") 0.
Definition qbool := mkInd (MPfile ["Datatypes"; "Init"; "Coq"], "bool") 0.

MetaCoq Unquote Definition x := (tProj (mkProjection qprod' 2 1)
   (tApp (tConstruct qprod' 0 nil)
      [tInd qbool nil;
      tInd qnat nil;
      tConstruct qbool 0 nil;
      tApp (tConstruct qnat 1 nil)
        [tApp (tConstruct qnat 1 nil)
           [tApp (tConstruct qnat 1 nil)
              [tApp (tConstruct qnat 1 nil)
                 [tConstruct qnat 0 nil]]]]])).

Check (eq_refl : x = snd' {| fst' := true; snd' := 4 |}).
Check (eq_refl : x = 4).


Require Import CoqCompile.Cps.
Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Data.Option.
Require Import BinPos.

Set Implicit Arguments.
Set Strict Implicit.

(** This file implements a pass that counts the occurances of each variable **)
Module Occurs.
  Import CPS.

  Section with_maps.
    Variable map_v : Type -> Type.
    Context {DMap_map_v : DMap var map_v}.

    Section monadic.
      Variable m : Type -> Type.
      Context {Monad_m : Monad m}.
      Context {Reader_m : MonadState (map_v positive) m}.

      Import MonadNotation.
      Local Open Scope monad_scope.

      Definition use_var (v : var) : m unit :=
        modify (fun x : map_v positive =>
          match Maps.lookup v x with
            | None => add v 1%positive x
            | Some n => add v (Psucc n) x
          end) ;;
        ret tt.

      Definition use_pat (p : pattern) : m unit := ret tt.

      Definition use_op (o : op) : m unit :=
        match o with
          | Var_o x => use_var x
          | _ => ret tt
        end.

      Fixpoint use_exp (e : exp) : m unit :=
        match e with
          | App_e f xs => use_op f ;; iterM use_op xs
          | Let_e d e => use_decl d ;; use_exp e
          | Letrec_e ds e => iterM use_decl ds ;; use_exp e
          | Switch_e x ls d =>
            use_op x ;;
            iterM (fun pe => use_exp (snd pe)) ls ;;
            iterM use_exp d
          | Halt_e o1 o2 => use_op o1 ;; use_op o2
        end
      with use_decl (d : decl) : m unit :=
        match d with
          | Op_d _ o => use_op o
          | Prim_d _ _ ls => iterM use_op ls
          | Fn_d _ _ e => use_exp e
          | Bind_d _ _ _ ls => iterM use_op ls
        end.

    End monadic.

    Require Import ExtLib.Data.Monads.StateMonad.

    Definition uses (e : exp) : map_v positive :=
      execState (use_exp e) empty.
  End with_maps.
End Occurs.


Require Import FunctionalExtensionality.

Ltac make_apply_under_binders_in lem H :=
  let tac := make_apply_under_binders_in in
  match type of H with
    | forall x : ?T, @?P x
      => let ret := constr:(fun x' : T =>
                              let Hx := H x' in
                              ltac:(let ret' := tac lem Hx in
                                exact ret')) in
         match eval cbv zeta in ret with
           | fun x => Some (@?P x) => let P' := (eval cbv zeta in P) in
                                      constr:(Some P')
         end
    | _ => let ret := constr:(ltac:(match goal with
                                  | _ => (let H' := fresh in
                                          pose H as H';
                                          apply lem in H';
                                          exact (Some H'))
                                  | _ => exact (@None nat)
                                end
                               )) in
           let ret' := (eval cbv beta zeta in ret) in
           constr:(ret')
    | _ => constr:(@None nat)
  end.

Ltac apply_under_binders_in lem H :=
  let H' := make_apply_under_binders_in lem H in
  let H'0 := match H' with Some ?H'0 => constr:(H'0) end in
  let H'' := fresh in
  pose proof H'0 as H'';
    clear H;
    rename H'' into H.

Goal forall A B C (f g : forall (x : A) (y : B x), C x y), (forall x y, f x y = g x y) -> True.
Proof.
  intros A B C f g H.
  let lem := constr:(@functional_extensionality_dep) in
  apply_under_binders_in lem H.
(* Anomaly: Uncaught exception Not_found(_). Please report. *)


Require Import List.
Require Import FunctionalExtensionality.
Require Import FJ_tactics.
Require Import Functors.
Require Import MonadLib.
Require Import Names.
Require Import PNames.
Require Import EffPure.
Require Import EffState.
Require Import EffReader.
Require Import Lambda.
Require Import Ref.
Require Import ESoundRS.

Section Lambda_Ref.

  Variable D : Set -> Set.
  Context {Fun_D : Functor D}.
  Context {Sub_LType_D : LType :<: D}.
  Context {Sub_RefType_D : RefType :<: D}.
  Context {Sub_UnitType_D : UnitType :<: D}.
  Context {WF_Sub_RefType_D : WF_Functor _ _ (Sub_RefType_D) _ _}.
  Context {WF_Sub_UnitType_D : WF_Functor _ _ (Sub_UnitType_D) _ _}.
  Context {WF_Sub_LType_F : WF_Functor _ _ (Sub_LType_D) _ _}.
  Context {Distinct_RefType_LType : Distinct_Sub_Functor Fun_D Sub_RefType_D Sub_LType_D}.
  Context {Distinct_UnitType_LType : Distinct_Sub_Functor Fun_D Sub_UnitType_D Sub_LType_D}.

  Variable E : Set -> Set -> Set.
  Context {Fun_F : forall A, Functor (E A)}.
  Context {Sub_RefE_E : forall A, RefE :<: E A}.
  Context {Sub_Lambda_E : forall A, Lambda D A :<: E A}.
  Context {WF_Sub_RefE_F : forall A, WF_Functor _ _ (Sub_RefE_E A) _ _}.
  Context {WF_Sub_Lambda_F : forall A, WF_Functor _ _ (Sub_Lambda_E A) _ _}.

  Variable V : Set -> Set.
  Context {Fun_V : Functor V}.
  Context {Sub_LocValue_V : LocValue :<: V}.
  Context {Sub_StuckValue_V : StuckValue :<: V}.
  Context {Sub_ClosValue_V : ClosValue E :<: V}.
  Context {Sub_UnitValue_V : UnitValue :<: V}.
  Context {WF_Sub_LocValue_V : WF_Functor _ _ (Sub_LocValue_V) _ _}.
  Context {WF_Sub_ClosValue_V : WF_Functor _ _ (Sub_ClosValue_V) _ _}.
  Context {Distinct_LocValue_RefValue : Distinct_Sub_Functor Fun_V Sub_LocValue_V Sub_ClosValue_V}.

  Context {eq_DType_DT : forall T, FAlgebra eq_DTypeName T (eq_DTypeR D) D}.
  Context {eq_DType_eq_DT : PAlgebra eq_DType_eqName D D (UP'_P (eq_DType_eq_P D))}.
  Context {eq_DType_neq_D : PAlgebra eq_DType_neqName D D (UP'_P (eq_DType_neq_P D))}.

  Variable (MT : Set -> Set).
  Context {Fun_MT : Functor MT}.
  Context {Mon_MT : Monad MT}.
  Context {Fail_MT : FailMonad MT}.
  Context {Inj_MT : InjMonad MT}.
  Context {Reasonable_MT : Reasonable_Monad MT}.
  Context {MT_eq_dec : forall (A : Set) (mta : MT A),
    {exists a, mta = return_ a} + {mta = fail}}.

  Variable (ME : Set -> Set). (* Evaluation Monad. *)
  Context {Fun_M : Functor ME}.
  Context {Mon_M : Monad ME}.
  Context {Environment_ME : Environment ME (list (Names.Value V))}.
  Context {StateM_ME : StateM ME (list (Names.Value V))}.
  Context {FailME : FailMonad ME}.

  Context {evalM_E : FAlgebra EvalName (Exp (E nat)) (evalMR V ME) (E nat)}.

  Context {WF_eval_Lambda_E :
    @WF_FAlgebra EvalName _ _ (Lambda D nat) (E nat)
    (Sub_Lambda_E nat) (MAlgebra_evalM_Lambda D E V ME) evalM_E}.
  Context {WF_eval_Ref_F : @WF_FAlgebra EvalName _ _ RefE (E nat)
    (Sub_RefE_E _) (MAlgebra_evalM_RefE V ME _) evalM_E}.

  Context {Typeof_E : forall T, FAlgebra TypeofName T (typeofR D MT) (E (DType D))}.
  Context {WF_Lambda_Typeof_F : forall T, @WF_FAlgebra TypeofName _ _ (Lambda D _) (E _)
    (Sub_Lambda_E _) (MAlgebra_typeof_Lambda D MT _) (Typeof_E T)}.
  Context {WF_RefE_Typeof_F : forall T, @WF_FAlgebra TypeofName _ _ RefE (E _)
    (Sub_RefE_E _) (MAlgebra_typeof_RefE D MT _) (Typeof_E T)}.

  Variable EQV_E : forall A B, (eqv_i E A B -> Prop) -> eqv_i E A B -> Prop.
  Context {funEQV_E : forall A B, iFunctor (EQV_E A B)}.

  (* ============================================== *)
  (* EQUIVALENCE OF REFERENCE EXPRESSIONS           *)
  (* ============================================== *)

  Inductive RefE_eqv (A B : Set) (C : eqv_i E A B -> Prop) : eqv_i E A B -> Prop :=
  | Ref_eqv : forall (gamma : Env _) gamma' a a' e e',
    C (mk_eqv_i _ _ _ gamma gamma' a a') ->
    proj1_sig e = proj1_sig (ref' (E A) a) ->
    proj1_sig e' = proj1_sig (ref' (E B) a') ->
    RefE_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e')
  | DeRef_eqv : forall (gamma : Env _) gamma' a a' e e',
    C (mk_eqv_i _ _ _ gamma gamma' a a') ->
    proj1_sig e = proj1_sig (deref' (E A) a) ->
    proj1_sig e' = proj1_sig (deref' (E B) a') ->
    RefE_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e')
  | Assign_eqv : forall (gamma : Env _) gamma' a b a' b' e e',
    C (mk_eqv_i _ _ _ gamma gamma' a a') ->
    C (mk_eqv_i _ _ _ gamma gamma' b b') ->
    proj1_sig e = proj1_sig (assign' (E _) a b) ->
    proj1_sig e' = proj1_sig (assign' (E _) a' b') ->
    RefE_eqv A B C (mk_eqv_i _ _ _ gamma gamma' e e').

  Definition ind_alg_RefE_eqv
    (A B : Set)
    (P : eqv_i E A B -> Prop)
    (Href : forall gamma gamma' a a' e e'
      (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a'))
      e_eq e'_eq,
      P (mk_eqv_i _ _ _ gamma gamma' e e'))
    (Hderef : forall gamma gamma' a a' e e'
      (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a'))
      e_eq e'_eq,
      P (mk_eqv_i _ _ _ gamma gamma' e e'))
    (Hassign : forall gamma gamma' a b a' b' e e'
      (IHa : P (mk_eqv_i _ _ _ gamma gamma' a a'))
      (IHb : P (mk_eqv_i _ _ _ gamma gamma' b b'))
      e_eq e'_eq,
      P (mk_eqv_i _ _ _ gamma gamma' e e'))
    i (e : RefE_eqv A B P i) : P i :=
    match e in RefE_eqv _ _ _ i return P i with
      | Ref_eqv gamma gamma' a a' e e'
        eqv_a_a' e_eq e'_eq =>
        Href gamma gamma' a a' e e' eqv_a_a' e_eq e'_eq
      | DeRef_eqv gamma gamma' a a' e e'
        eqv_a_a' e_eq e'_eq =>
        Hderef gamma gamma' a a' e e'
        eqv_a_a' e_eq e'_eq
      | Assign_eqv gamma gamma' a b a' b' e e'
        eqv_a_a' eqv_b_b' e_eq e'_eq =>
        Hassign gamma gamma' a b a' b' e e'
        eqv_a_a' eqv_b_b' e_eq e'_eq
    end.

  Definition RefE_eqv_ifmap (A B : Set)
    (A' B' : eqv_i E A B -> Prop) i (f : forall i, A' i -> B' i)
    (eqv_a : RefE_eqv A B A' i) : RefE_eqv A B B' i :=
    match eqv_a in RefE_eqv _ _ _ i return RefE_eqv _ _ _ i with
      | Ref_eqv gamma gamma' a a' e e'
        eqv_a_a' e_eq e'_eq =>
        Ref_eqv _ _ _ gamma gamma' a a' e e'
        (f _ eqv_a_a') e_eq e'_eq
      | DeRef_eqv gamma gamma' a a' e e'
        eqv_a_a' e_eq e'_eq =>
        DeRef_eqv _ _ _ gamma gamma' a a' e e'
        (f _ eqv_a_a') e_eq e'_eq
      | Assign_eqv gamma gamma' a b a' b' e e'
        eqv_a_a' eqv_b_b' e_eq e'_eq =>
        Assign_eqv _ _ _ gamma gamma' a b a' b' e e'
        (f _ eqv_a_a') (f _ eqv_b_b') e_eq e'_eq
    end.

  Global Instance iFun_RefE_eqv A B : iFunctor (RefE_eqv A B).
    constructor 1 with (ifmap := RefE_eqv_ifmap A B).
    destruct a; simpl; intros; reflexivity.
    destruct a; simpl; intros; unfold id; eauto.
  Defined.

  Variable Sub_RefE_eqv_EQV_E : forall A B,
    Sub_iFunctor (RefE_eqv A B) (EQV_E A B).

  Global Instance EQV_proj1_RefE_eqv :
    forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P E EQV_E A B) (RefE_eqv _ _).
    econstructor; intros.
    unfold iAlgebra; intros; apply ind_alg_RefE_eqv;
      unfold EQV_proj1_P; simpl; intros; subst.
    apply (inject_i (subGF := Sub_RefE_eqv_EQV_E A B)); econstructor; simpl; eauto.
    destruct a; destruct a'; eapply IHa; eauto.
    apply (inject_i (subGF := Sub_RefE_eqv_EQV_E A B)); econstructor 2; simpl; eauto.
    destruct a; destruct a'; eapply IHa; eauto.
    apply (inject_i (subGF := Sub_RefE_eqv_EQV_E A B)); econstructor 3; simpl; eauto.
    destruct a; destruct a'; eapply IHa; eauto.
    destruct b; destruct b'; eapply IHb; eauto.
    apply H.
  Qed.

  Context {Sub_Lambda_eqv_EQV_E : forall A B, Sub_iFunctor (Lambda_eqv _ _ A B) (EQV_E A B)}.

  Variable TypContext : Set.
  Variable WFV : (WFValue_i D V TypContext -> Prop) -> WFValue_i D V TypContext -> Prop.
  Context {TypContextCE : ConsExtensionC TypContext}.
  Context {GammaTypContext : GammaTypContextC D TypContext}.
  Context {TypContext_GCE : GammaConsExtensionC D TypContext _ _}.
  Context {TypContext_S : SigTypContextC D TypContext}.
  Context {TypContext_SCE : SigConsExtensionC D TypContext _ _}.
  Context {TypContext_WFE : WF_EnvC V TypContext}.
  Context {TypContext_SWFE : Sig_WF_EnvC D V TypContext WFV _ _}.

  Context {funWFV : iFunctor WFV}.

  Context {Sub_WFV_Loc_WFV : Sub_iFunctor (WFValue_Loc D V _) WFV}.
  Context {Sub_WFV_Unit_WFV : Sub_iFunctor (WFValue_Unit D V _) WFV}.
  Context {Sub_WFV_Clos_WFV : Sub_iFunctor (WFValue_Clos D E MT V EQV_E _) WFV}.

  Variable WFVM : (WFValueM_i D V MT ME TypContext -> Prop) -> WFValueM_i D V MT ME TypContext-> Prop.
  Context {funWFVM : iFunctor WFVM}.

  Context {Sub_WFVM_Base_WFVM : Sub_iFunctor (WFValueM_base D V MT ME _ WFV) WFVM}.
  Context {Sub_WFVM_Environment_WFVM : Sub_iFunctor (WFValueM_Environment D MT V ME _ WFV) WFVM}.
  Context {Sub_WFVM_Bot_WFVM : Sub_iFunctor (WFValueM_Bot D V MT ME _) WFVM}.
  Context {Sub_WFVM_State_WFVM : Sub_iFunctor (WFValueM_State D V MT ME TypContext) WFVM}.

  Context {WFV_Weaken_WFV : iPAlgebra WFValue_Weaken_Name (WFValue_Weaken_P D V _ WFV) WFV}.
  Context {WF_invertLoc_WFV :
    iPAlgebra WF_invertLoc_Name (WF_invertLoc_P _ _ _ WFV) WFV}.
  Context {WF_invertLoc'_WFV :
    iPAlgebra WF_invertLoc'_Name (WF_invertLoc'_P _ _ _ WFV) WFV}.
  Context {WFV_proj1_b_WFV : iPAlgebra WFV_proj1_b_Name (WFV_proj1_b_P D V _ WFV) WFV}.

  Context {wfvm_bind_alg :
    iPAlgebra wfvm_bind_Name (wfvm_bind_P D V MT ME _ WFV WFVM (TypContextCE := TypContextCE)) WFVM}.

  Context {EQV_proj1_EQV_E :
    forall A B, iPAlgebra EQV_proj1_Name (EQV_proj1_P E EQV_E A B) (EQV_E _ _)}.

  Global Instance eqv_soundness_X'_RefE_eqv eval_rec :
    iPAlgebra soundness_X'_Name
    (soundness_X'_P D V E MT ME _ EQV_E WFVM (fun e => typeof _ _ MT (proj1_sig e)) eval_rec
      (f_algebra (FAlgebra := Typeof_E _))
      (f_algebra (FAlgebra := evalM_E))) (RefE_eqv _ _).
  Proof.
    econstructor; unfold iAlgebra; intros.
    eapply ind_alg_RefE_eqv; try eassumption;
      unfold soundness_X'_P, eval_soundness'_P; unfold bevalM; simpl; intros.
      (* Ref case *)
    intros; destruct a as [aE aT]; destruct (IHa IH) as [eqv_a_a' IHa'].
    split; intros.
    apply (inject_i (subGF := Sub_RefE_eqv_EQV_E _ _));
      econstructor; eauto.
    rewrite e_eq, e'_eq.
    simpl; repeat rewrite out_in_fmap.
    repeat rewrite wf_functor.
    rewrite (wf_algebra (WF_FAlgebra := WF_eval_Ref_F));
      rewrite (wf_algebra (WF_FAlgebra := WF_RefE_Typeof_F _));
        simpl fmap; simpl f_algebra; unfold RefE_fmap;
          unfold RefE_typeof, RefE_evalM.
    eapply Ref.eval_soundness_H; eauto with typeclass_instances.
    eapply IH with (pb := (gamma, gamma')).
    split; destruct WF_Gamma; eauto.
    apply (EQV_proj1 _ EQV_E _ _ _ eqv_a_a'); simpl; eauto.
    generalize in_out_UP'_inverse; simpl; intros in_out';
      eapply (in_out' _ _ _ (proj2_sig a')).
    destruct WF_Gamma; eauto.
    apply (EQV_proj1 _ EQV_E _ _ _ eqv_a_a'); simpl; eauto.
    generalize in_out_UP'_inverse; simpl; intros in_out';
      eapply (in_out' _ _ _ (proj2_sig a')).
      (* DeRef case *)
    intros; destruct a as [aE aT]; destruct (IHa IH) as [eqv_a_a' IHa'].
    split; intros.
    apply (inject_i (subGF := Sub_RefE_eqv_EQV_E _ _));
      econstructor 2; eauto.
    rewrite e_eq, e'_eq.
    simpl; repeat rewrite out_in_fmap.
    repeat rewrite wf_functor.
    rewrite (wf_algebra (WF_FAlgebra := WF_eval_Ref_F));
      rewrite (wf_algebra (WF_FAlgebra := WF_RefE_Typeof_F _));
        simpl fmap; simpl f_algebra; unfold RefE_fmap;
          unfold RefE_typeof, RefE_evalM.
    eapply Ref.eval_soundness_H0; eauto with typeclass_instances.
    eapply IH with (pb := (gamma, gamma')).
    split; destruct WF_Gamma; eauto.
    apply (EQV_proj1 _ EQV_E _ _ _ eqv_a_a'); simpl; eauto.
    generalize in_out_UP'_inverse; simpl; intros in_out';
      eapply (in_out' _ _ _ (proj2_sig a')).
    destruct WF_Gamma; eauto.
    apply (EQV_proj1 _ EQV_E _ _ _ eqv_a_a'); simpl; eauto.
    generalize in_out_UP'_inverse; simpl; intros in_out';
      eapply (in_out' _ _ _ (proj2_sig a')).
    intros; destruct a as [aE aT]; destruct b as [bE bT];
      destruct (IHa IH) as [eqv_a_a' IHa'];
        destruct (IHb IH) as [eqv_b_b' IHn']; simpl in *|-*.
    split; intros.
      apply (inject_i (subGF := Sub_RefE_eqv_EQV_E _ _));
        econstructor 3.
      eapply eqv_a_a'.
      eapply eqv_b_b'.
      rewrite e_eq; reflexivity.
      rewrite e'_eq; reflexivity.
      rewrite e_eq, e'_eq; simpl; repeat rewrite out_in_fmap.
    simpl; repeat rewrite out_in_fmap.
    repeat rewrite wf_functor.
    rewrite (wf_algebra (WF_FAlgebra := WF_eval_Ref_F));
      rewrite (wf_algebra (WF_FAlgebra := WF_RefE_Typeof_F _));
        simpl fmap; simpl f_algebra; unfold RefE_fmap;
          unfold RefE_typeof, RefE_evalM.
    eapply Ref.eval_soundness_H1; eauto with typeclass_instances.
    eapply IH with (pb := (gamma, gamma')).
    split; destruct WF_Gamma; eauto.
    apply (EQV_proj1 _ EQV_E _ _ _ eqv_a_a'); simpl; eauto.
    generalize in_out_UP'_inverse; simpl; intros in_out';
      eapply (in_out' _ _ _ (proj2_sig a')).
    destruct WF_Gamma; eauto.
    apply (EQV_proj1 _ EQV_E _ _ _ eqv_a_a'); simpl; eauto.
    generalize in_out_UP'_inverse; simpl; intros in_out';
      eapply (in_out' _ _ _ (proj2_sig a')).
      intros; eapply IH with (pb := (gamma, gamma')).
      split; destruct WF_Gamma; eauto.
      apply (EQV_proj1 _ EQV_E _ _ _ eqv_b_b'); simpl; eauto.
      generalize in_out_UP'_inverse; simpl; intros in_out';
        eapply (in_out' _ _ _ (proj2_sig b')).
      eapply WF_eqv_environment_P_Sub; eauto.
      destruct WF_Gamma; eauto.
      apply (EQV_proj1 _ EQV_E _ _ _ eqv_b_b'); simpl; eauto.
      generalize in_out_UP'_inverse; simpl; intros in_out';
        eapply (in_out' _ _ _ (proj2_sig b')).
  Qed.

  Global Instance WF_invertClos_WFV_Unit :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P D E MT V EQV_E _ WFV) (WFValue_Unit D V _).
  Proof.
    constructor.
    unfold iAlgebra; intros; apply ind_alg_WFV_Unit with (Sub_UnitValue_V := Sub_UnitValue_V)
      (Sub_UnitType_D := Sub_UnitType_D); unfold WF_invertClos_P; simpl; intros; auto; split.
    apply (inject_i (subGF := Sub_WFV_Unit_WFV)); econstructor; eauto.
    rewrite T'_eq; intros.
    unfold tunit in H0; simpl in H0; apply in_t_UP'_inject in H0.
    repeat rewrite wf_functor in H0; simpl in H0.
    elimtype False; eapply (inj_discriminate _ _ _ H0).
  Qed.

  Global Instance WF_invertClos_WFV_Loc :
    iPAlgebra WF_invertClos_Name (WF_invertClos_P D E MT V EQV_E _ WFV) (WFValue_Loc D V _).
  Proof.
    constructor.
    unfold iAlgebra; intros; apply ind_alg_WFV_Loc with (Sub_LocValue_V := Sub_LocValue_V)
      (TypContext_S := TypContext_S)
      (Sub_RefType_D := Sub_RefType_D); unfold WF_invertClos_P; simpl; intros; auto; split.
    apply (inject_i (subGF := Sub_WFV_Loc_WFV)); econstructor; eauto.
    rewrite T'_eq; intros.
    unfold tref in H0; simpl in H0; apply in_t_UP'_inject in H0.
    repeat rewrite wf_functor in H0; simpl in H0.
    elimtype False; eapply (inj_discriminate _ _ _ H0).
  Qed.

  Context {SigGammaTypContext : SigGammaTypContextC D TypContext}.

  Global Instance WFV_Loc_Weaken' :
    iPAlgebra WFValue_Weaken'_Name (WFValue_Weaken'_P D V TypContext WFV) (WFValue_Loc D V _).
  Proof.
    constructor.
    unfold iAlgebra; intros; apply ind_alg_WFV_Loc with (Sub_LocValue_V := Sub_LocValue_V)
      (TypContext_S := TypContext_S)
      (Sub_RefType_D := Sub_RefType_D); unfold WFValue_Weaken'_P; simpl; intros; auto.
    apply (inject_i (subGF := Sub_WFV_Loc_WFV)); econstructor; eauto.
    rewrite SigLookup_GammaSet; auto.
  Qed.

  Global Instance WFV_Unit_Weaken' :
    iPAlgebra WFValue_Weaken'_Name (WFValue_Weaken'_P D V TypContext WFV) (WFValue_Unit D V _).
  Proof.
    constructor.
    unfold iAlgebra; intros; apply ind_alg_WFV_Unit with (Sub_UnitValue_V := Sub_UnitValue_V)
      (Sub_UnitType_D := Sub_UnitType_D); unfold WFValue_Weaken'_P; simpl; intros; auto.
    apply (inject_i (subGF := Sub_WFV_Unit_WFV)); econstructor; eauto.
  Qed.

End Lambda_Ref.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              July 1st 1995                               *)
(*                                                                          *)
(****************************************************************************)
(****************************************************************)
(*      Proof of a multiplier circuit                           *)
(*      C. Paulin-Mohring, June 95                              *)
(****************************************************************)
(*              Circ.v                                          *)
(*              Representation of Circuits                      *)
(****************************************************************)

Require Import GFP.
Require Import Streams.

Section Circuits.

Variable TI TR TO : Set.

Variable output : TI -> TR -> TO.
Variable update : TI -> TR -> TR.

Definition CIRC (ri : TR) (si : Str TI) : Str TO :=
  STRCOIT _ _
    (fun x : Str TI * TR =>
     let (s, r) return (TO * (Str TI * TR)) := x in
     (output (HD _ s) r, (TL _ s, update (HD _ s) r)))
    (si, ri).
Let Circ := CIRC.

Theorem Hd_Circ :
 forall (r : TR) (si : Str TI), HD _ (Circ r si) = output (HD _ si) r.
trivial.
Qed.

Theorem Tl_Circ :
 forall (r : TR) (si : Str TI),
 TL _ (Circ r si) = Circ (update (HD _ si) r) (TL _ si).
trivial.
Qed.

Definition Reg : Str TI * TR -> TR.
simple destruct 1; trivial.
Defined.

Definition Input : Str TI * TR -> Str TI.
simple destruct 1; trivial.
Defined.

Section CircProof.
Variable i0 : Str TI.
Variable r0 : TR.
Variable P : nat -> TO -> Prop.

Variable inv : nat -> TR -> Prop.
Hypothesis inv_init : inv 0 r0.
Hint Resolve inv_init.

Let inv_aux (n : nat) (s : Str TO) : Prop :=
  exists r : TR, inv n r /\ s = Circ r (NTHTL _ i0 n).

Remark inv_aux_init : inv_aux 0 (Circ r0 i0).
exists r0; auto.
Qed.
Hint Resolve inv_aux_init.

Hypothesis
  inv_stable :
    forall (n : nat) (r : TR),
    inv n r ->
    P n (output (NTH _ i0 n) r) /\ inv (S n) (update (NTH _ i0 n) r).

Remark inv_aux_stable :
 forall (n : nat) (s : Str TO),
 inv_aux n s -> P n (HD _ s) /\ inv_aux (S n) (TL _ s).
simple induction 1; simple induction 1; intros.
rewrite H2; rewrite Tl_Circ; rewrite Hd_Circ.
elim (inv_stable n x); intros; trivial.
split; trivial.
exists (update (NTH _ i0 n) x); auto.
Qed.
Hint Resolve inv_aux_stable.

Theorem Circ_property : forall n : nat, P n (NTH _ (Circ r0 i0) n).
intro; apply All_Q_Nth with (Inv := inv_aux); auto.
Qed.

End CircProof.

End Circuits.

Notation Circ := (CIRC _ _ _) (only parsing).
(* <Warning> : Syntax is discontinued *)


From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat div seq.
From mathcomp Require Import choice fintype prime tuple finfun finset bigop.
Require Import tree_traversal rank_select insert_delete.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section update.

  Variable T : Type.

  (* Simple wrapper around set_nth to stop the padding behavior
   * of set_nth, which is confusing
   *)
  Definition update (s : seq T) x i :=
    if i < size s then set_nth x s i x else s.

  Lemma set_nth_default_sizel (s : seq T) y y' x i :
    i < size s -> set_nth y s i x = set_nth y' s i x.
  Proof. elim: s i => [|h t IHt] [|j] //= H. by rewrite IHt. Qed.

  Lemma size_update (s : seq T) x i :
    size s = size (update s x i).
  Proof.
    rewrite /update. case: ifP => Hi.
    by rewrite size_set_nth maxnE subnKC. exact.
  Qed.

  Lemma update_cons (s : seq T) h x i :
    update (h::s) x i.+1 = h :: update s x i.
  Proof. rewrite /update /= ltnS; by case: ifPn. Qed.

  Lemma update_ith (s : seq T) x0 x i :
    i < size s -> nth x0 (update s x i) i = x.
  Proof.
    move => H. rewrite /update H.
    rewrite (set_nth_default_sizel x x0 x H).
    by rewrite nth_set_nth //= eq_refl.
  Qed.

  Lemma update_jth (s : seq T) x0 x i j :
    i != j -> nth x0 (update s x i) j = nth x0 s j.
  Proof.
    move => H. rewrite /update. case: ifP => // Hsize.
    rewrite (set_nth_default_sizel x x0 x Hsize).
    by rewrite nth_set_nth //= ifN // eq_sym.
  Qed.

  Lemma update_oversize (s : seq T) x i :
    i >= size s -> update s x i = s.
  Proof. by rewrite /update ltnNge => ->. Qed.

  Lemma update_cat (s t : seq T) x i :
    update (s ++ t) x i = if i < size s
                          then (update s x i) ++ t
                          else s ++ update t x (i - size s).
  Proof.
    elim: s i => [|h s IHs] [|i] //=.
    by rewrite !update_cons subSS cat_cons -(fun_if (cons _)) -IHs.
  Qed.

End update.

Section bit_set_clear.

  Definition bit_set (s : seq bool) i := update s true i.

  Definition bit_clear (s : seq bool) i := update s false i.

  Definition bit_toggle (s : seq bool) i :=
    update s (~~ (nth true s i)) i.

  Lemma size_bit_set (s : seq bool) i : size (bit_set s i) = size s.
  Proof. rewrite /bit_set. by rewrite (size_update s true i). Qed.

  Lemma size_bit_clear (s : seq bool) i : size (bit_clear s i) = size s.
  Proof. rewrite /bit_set. by rewrite (size_update s false i). Qed.

  Lemma bit_set_over (s : seq bool) i : i >= size s -> bit_set s i = s.
  Proof. rewrite /bit_set /update leqNgt. by move/negbTE => ->. Qed.

  Lemma bit_clear_over (s : seq bool) i : i >= size s -> bit_clear s i = s.
  Proof. rewrite /bit_clear /update leqNgt. by move/negbTE => ->. Qed.

  Lemma nth_bit_set (s : seq bool) b0 i :
    i < size s -> nth b0 (bit_set s i) i = true.
  Proof. move => H. by rewrite /bit_set update_ith. Qed.

  Lemma nth_bit_clear (s : seq bool) b0 i :
    i < size s -> nth b0 (bit_clear s i) i = false.
  Proof. move => H. by rewrite /bit_clear update_ith. Qed.

  Lemma count_bit_set (s : seq bool) b0 i : i < size s ->
    count_mem true (bit_set s i) = ~~ (nth b0 s i) + count_mem true s.
  Proof.
    elim: s i => [|b s IHs] [|j] //=.
      by case: b.
    rewrite ltnS => /= Hi.
    by rewrite addnCA -IHs // /bit_set update_cons.
  Qed.

  Lemma true_count_pos (s : seq bool) b0 i :
    i < size s -> nth b0 s i <= count_mem true s.
  Proof.
    elim: s i => [|b s IHs] //= [|i] Hi /=.
      by case: b => //; rewrite eqxx.
    move: Hi; rewrite ltnS => /IHs /leq_trans; apply.
    by apply leq_addl.
  Qed.

  Lemma count_bit_clear (s : seq bool) b0 i : i < size s ->
    count_mem true (bit_clear s i) = count_mem true s - nth b0 s i.
  Proof.
    elim: s i => [|b s IHs] [|j] //=.
      case: b => /=; by rewrite ?addKn ?subn0.
    rewrite ltnS => /= Hj.
    rewrite -addnBA; last by apply true_count_pos.
    by rewrite -IHs // /bit_clear update_cons.
  Qed.

  Lemma count_bit_toggle (s : seq bool) b0 i :
    i < size s -> count_mem true (bit_toggle s i) =
                  if nth b0 s i
                  then count_mem true s - 1
                  else count_mem true s + 1.
  Proof.
    rewrite /bit_toggle /update => H; rewrite H.
    elim: s i H => [|b s IHs] [|j] //=.
      by case Hb: b => //=; rewrite add1n add0n ?addn1 // subn1 succnK.
    rewrite ltnS => H.
    rewrite IHs //; case: ifP => Hnth.
      move: (true_count_pos b0 H); rewrite Hnth => Ht.
      by rewrite addnBA.
    by rewrite addnA.
  Qed.

End bit_set_clear.


Require Import Coq.micromega.Lia.
Require Import Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Crypto.Util.Strings.Ascii.

Local Open Scope list_scope.
Local Open Scope string_scope.

(** TODO: Remove this once we drop support for Coq 8.9 (it's in the stdlib in Coq 8.10 *)
(** *** Conversion to/from [list ascii] *)

Fixpoint string_of_list_ascii (s : list ascii) : string
  := match s with
     | nil => EmptyString
     | cons ch s => String ch (string_of_list_ascii s)
     end.

Fixpoint list_ascii_of_string (s : string) : list ascii
  := match s with
     | EmptyString => nil
     | String ch s => cons ch (list_ascii_of_string s)
     end.

Lemma string_of_list_ascii_of_string s : string_of_list_ascii (list_ascii_of_string s) = s.
Proof.
  induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ].
Defined.

Lemma list_ascii_of_string_of_list_ascii s : list_ascii_of_string (string_of_list_ascii s) = s.
Proof.
  induction s as [|? ? IHs]; [ reflexivity | cbn; apply f_equal, IHs ].
Defined.

(** *** String concatenation *)

Lemma string_of_list_ascii_app s1 s2 : string_of_list_ascii (s1 ++ s2) = string_of_list_ascii s1 ++ string_of_list_ascii s2.
Proof. induction s1 as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.
Lemma list_ascii_of_string_app s1 s2 : list_ascii_of_string (s1 ++ s2) = (list_ascii_of_string s1 ++ list_ascii_of_string s2)%list.
Proof. induction s1 as [|x xs IHxs]; cbn; [ | rewrite IHxs ]; reflexivity. Qed.

Definition lift_list_function (f : list ascii -> list ascii) (s : string) : string
  := string_of_list_ascii (f (list_ascii_of_string s)).

(** *** Mapping over a string *)
(** [map f s] applies function [f] in turn to all the characters of
    [s], creating a new string to return *)
Definition map (f : ascii -> ascii) : string -> string
  := lift_list_function (List.map f).
Lemma map_step f s
  : map f s = match s with
              | EmptyString => EmptyString
              | String x xs => String (f x) (map f xs)
              end.
Proof. destruct s; reflexivity. Qed.

(** *** Lower and upper case *)
Definition to_lower (s : string) : string := map Ascii.to_lower s.
Definition to_upper (s : string) : string := map Ascii.to_upper s.

(** *** string reversal *)
(** [rev s] reverses the string [s] *)
(** Note that we use [rev_append . []] for non-quadratic behavior *)
Definition rev : string -> string
  := lift_list_function (fun s => List.rev_append s nil).

Lemma rev_step s
  : rev s
    = match s with
      | EmptyString => EmptyString
      | String x xs => rev xs ++ String x EmptyString
      end.
Proof. destruct s; cbn; rewrite ?List.rev_append_rev, ?List.app_nil_r, ?string_of_list_ascii_app; reflexivity. Qed.

Fixpoint take_while_drop_while (f : ascii -> bool) (s : string) : string * string
  := match s with
     | EmptyString => (EmptyString, EmptyString)
     | String ch s
       => if f ch
          then let '(s1, s2) := take_while_drop_while f s in
               (String ch s1, s2)
          else (EmptyString, String ch s)
     end.

(** *** trimming a string *)
(** [trim s] returns a copy of the argument, without leading and trailing
    whitespace. The characters regarded as whitespace are: ' ',
    '\012', '\n', '\r', and '\t'. *)
Definition ltrim (s : string) : string
  := snd (take_while_drop_while Ascii.is_whitespace s).

Definition rtrim (s : string) : string
  := rev (ltrim (rev s)).

Definition trim (s : string) : string
  := rtrim (ltrim s).

(** Finds last occurence of [s1] in [s2], where the first character
    after [s1] is at position less than or equal to [n + 1].  Returns
    the location of the first character of [s1] in that occurence in
    [s2], if it exists. *)

Definition rindex (n : nat) (s1 s2 : string) : option nat :=
  option_map
    (fun n => length s2 - n - length s1)
    (index (length s2 - n - 1) (rev s1) (rev s2)).

Lemma append_alt s1 s2 : s1 ++ s2 = string_of_list_ascii (list_ascii_of_string s1 ++ list_ascii_of_string s2).
Proof. rewrite string_of_list_ascii_app, !string_of_list_ascii_of_string; reflexivity. Qed.
Lemma append_empty_r s : s ++ "" = s.
Proof.
  rewrite append_alt; cbn; rewrite List.app_nil_r, string_of_list_ascii_of_string. reflexivity.
Qed.
Lemma append_assoc s1 s2 s3 : s1 ++ (s2 ++ s3) = (s1 ++ s2) ++ s3.
Proof.
  rewrite !append_alt, !list_ascii_of_string_of_list_ascii; cbn; rewrite List.app_assoc; reflexivity.
Qed.

Lemma substring_alt n m s
  : substring n m s = string_of_list_ascii (List.firstn m (List.skipn n (list_ascii_of_string s))).
Proof.
  revert n m; induction s as [|ch s IHs]; intros [|n] [|m]; try reflexivity; cbn;
    rewrite IHs; cbn; try reflexivity.
Qed.

Lemma length_substring n1 n2 s
  : length (substring n1 n2 s) = Nat.min n2 (length s - n1).
Proof.
  revert n1 n2; induction s as [|a s IHs]; intros; cbn.
  { destruct n1, n2; cbn; reflexivity. }
  { destruct n1; [ destruct n2 | ]; cbn; rewrite ?IHs, <- ?Minus.minus_n_O; reflexivity. }
Qed.

Lemma length_append s1 s2 : length (s1 ++ s2) = length s1 + length s2.
Proof.
  revert s1; induction s1 as [|a s1 IHs1]; cbn; congruence.
Qed.

(** *** membership *)
(** [contains n s1 s2] returns [true] if [s1] occurs in [s2] starting
    at position [n], and false otherwise *)
Definition contains (n : nat) (s1 s2 : string) : bool :=
  match index n s1 s2 with
  | Some _ => true
  | None => false
  end.

(** [startswith prefix s] returns [true] iff [s] starts with [prefix] *)
Definition startswith (prefix s : string) : bool
  := (prefix =? (substring 0 (length prefix) s))%string.

Lemma startswith_correct prefix s
  : startswith prefix s = true <-> substring 0 (length prefix) s = prefix.
Proof.
  pose proof (String.eqb_spec prefix (substring 0 (length prefix) s)) as H'.
  cbv [startswith].
  split; intro H; destruct H'; congruence.
Qed.

(** [endswith postfix s] returns [true] iff [s] ends with [postfix] *)
Definition endswith (postfix s : string) : bool
  := (postfix =? (substring (length s - length postfix) (length postfix) s))%string.

Lemma endswith_correct postfix s
  : endswith postfix s = true <-> substring (length s - length postfix) (length postfix) s = postfix.
Proof.
  pose proof (String.eqb_spec postfix (substring (length s - length postfix) (length postfix) s)) as H'.
  cbv [endswith].
  split; intro H; destruct H'; congruence.
Qed.

Section strip_prefix_cps.
  Context {R} (found : string -> R)
          (remaining : string -> string -> R).

  Fixpoint strip_prefix_cps (sepch : ascii) (sep : string) (s2 : string) {struct s2} : R
    := match s2 with
       | EmptyString => remaining (String sepch sep) s2
       | String x xs
         => if (sepch =? x)%char
            then match sep with
                 | EmptyString => found xs
                 | String sepch sep
                   => strip_prefix_cps sepch sep xs
                 end
            else remaining (String sepch sep) s2
       end.

  Lemma strip_prefix_cps_found sepch sep s2 s2'
        (Hfound : String sepch sep ++ s2' = s2)
    : strip_prefix_cps sepch sep s2 = found s2'.
  Proof using Type.
    revert sepch sep Hfound; induction s2 as [|ch s2 IHs2]; intros; cbn in Hfound; inversion Hfound; clear Hfound; subst.
    destruct sep; cbn [strip_prefix_cps]; now rewrite Ascii.eqb_refl; auto.
  Qed.
End strip_prefix_cps.

(** *** splitting a string *)
(** [split sep s] returns the list of all (possibly empty) substrings
    of [s] that are delimited by the [sep] character.

    The function's output is specified by the following invariants:

    - The list is not empty.

    - Concatenating its elements using sep as a separator returns a
      string equal to the input

        [concat sep (split sep s) = s]

    - No string in the result contains [sep] as a substring, unless
      [sep] is the empty string, in which case this function returns
      [map (fun ch => String ch "") (list_ascii_of_string s)] if [s] is non-empty,
      and [""::nil] if [s] is also empty. *)

Fixpoint split_helper (sepch : ascii) (sep : string) (s : string) (rev_acc : string) {struct s}
  : list string
  := strip_prefix_cps
       (fun s => rev rev_acc :: split_helper sepch sep s "")
       (fun _ _
        => match s with
           | EmptyString => rev rev_acc :: nil
           | String x xs
             => split_helper sepch sep xs (String x rev_acc)
           end)
       sepch sep s.

Definition split (sep : string) (s : string) : list string
  := match sep with
     | EmptyString
       => if (s =? "")%string
          then "" :: nil
          else List.map (fun ch => String ch "") (list_ascii_of_string s)
     | String sepch sep
       => split_helper sepch sep s ""
     end.

Fixpoint split_helper_non_empty sepch sep s rev_acc {struct s}
  : split_helper sepch sep s rev_acc <> nil.
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; clear split_helper_non_empty; congruence | ].
  generalize (split_helper_non_empty sepch sep xs (String x rev_acc)).
  generalize (split_helper sepch sep xs (String x rev_acc)).
  intros ls H.
  generalize (String x xs).
  generalize sep at 2.
  generalize sepch at 2.
  fix H' 3.
  intros sepch' sep' s'.
  destruct s' as [|a s']; cbn; [ assumption | ].
  destruct (sepch' =? a)%char, sep'; try (clear H' split_helper_non_empty; congruence).
  apply H'.
Qed.

Lemma split_non_empty sep s : split sep s <> nil.
Proof.
  unfold split; destruct sep, s; try apply split_helper_non_empty; cbn;
    congruence.
Qed.

Lemma split_empty_empty : split EmptyString EmptyString = "" :: nil.
Proof. reflexivity. Qed.
Lemma split_empty_non_empty s
  : s <> EmptyString
    -> split EmptyString s = List.map (fun ch => String ch "") (list_ascii_of_string s).
Proof.
  intro H; destruct s; cbn; congruence.
Qed.

Fixpoint split_helper_no_substring sepch sep s rev_acc
  : List.Forall (fun s' => contains 0 (rev rev_acc ++ String sepch sep) s' = false)
                (split_helper sepch sep s rev_acc).
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; clear split_helper_no_substring;
      repeat constructor
    | ].
  { unfold contains.
    edestruct index eqn:H; [ | reflexivity ].
    apply index_correct1 in H.
    apply (f_equal length) in H.
    rewrite length_substring, !length_append in H.
    revert H; apply PeanoNat.Nat.min_case_strong; cbn; intros; lia. }
  { generalize (split_helper_no_substring sepch sep xs (String x rev_acc)).
    generalize (split_helper sepch sep xs (String x rev_acc)).
    intros ls.
    clear split_helper_no_substring; intro split_helper_no_substring.
Abort.
Lemma split_no_substring sep s (Hsep : sep <> EmptyString)
  : List.Forall (fun s' => contains 0 sep s' = false)
                (split sep s).
Proof.
  destruct sep as [|sepch sep]; [ congruence | ].
  unfold split.
Abort.

Fixpoint concat_split_helper sepch sep s rev_acc
  : concat (String sepch sep) (split_helper sepch sep s rev_acc)
    = rev rev_acc ++ s.
Proof.
  destruct s as [|x xs]; cbn [split_helper];
    [ cbn; rewrite append_empty_r; reflexivity | ].
  generalize (concat_split_helper sepch sep xs (String x rev_acc)).
  generalize (split_helper sepch sep xs (String x rev_acc)).
  intros ls H.
  rewrite rev_step, <- append_assoc in H; cbn in H; revert H.
  generalize (String x xs); clear x xs.
  revert sep.
  revert sepch.
  fix H' 3.
  intros sepch' sep' s'; intros.
  destruct s' as [|a s']; cbn; [ assumption | ].
  destruct (Ascii.eqb_spec sepch' a), sep'; try (clear H' concat_split_helper; congruence).
  { cbn [concat].
    rewrite (concat_split_helper sepch' "" s').
    destruct (split_helper sepch' "" s' "") eqn:H''.
    { apply split_helper_non_empty in H''; exfalso; assumption. }
    { cbn; subst; reflexivity. } }
  { subst.
Abort.

Lemma concat_split sep s : concat sep (split sep s) = s.
Proof.
  destruct sep; cbn.
  { destruct s as [|x xs]; [ reflexivity | cbn ].
    revert x; induction xs as [|x' xs' IHxs]; intro x; cbn; trivial.
    apply f_equal; auto. }
  {
Abort.

Definition replace (from to s : string) : string
  := concat to (split from s).

Notation NewLine := (String Ascii.NewLine "").
Notation CR := (String Ascii.CR "").
Notation LF := (String Ascii.LF "").
Notation CRLF := (String Ascii.CR (String Ascii.LF "")).
Notation Tab := (String Ascii.Tab "").

(** Given a list of strings, breaks all strings within the list at
    CFLF, CF, and LF.  Useful for normalizing a newline-separated list
    of strings, where some substrings might contain newlines *)
Definition split_newlines (s : list string) : list string
  := List.flat_map (split CR) (List.flat_map (split LF) (List.flat_map (split CRLF) s)).

(** Title case makes all words after a space begin with a capital letter *)
Definition capitalize_first_letter (s : string) : string
  := match s with
     | "" => ""
     | String ch s => String (Ascii.to_upper ch) s
     end.
Definition uncapitalize_first_letter (s : string) : string
  := match s with
     | "" => ""
     | String ch s => String (Ascii.to_lower ch) s
     end.
Definition to_title_case_sep (sep : string) (s : string) : string
  := concat sep (List.map capitalize_first_letter (split sep s)).
Definition to_title_case (s : string) : string
  := to_title_case_sep " " s.

Lemma substring_0_0 :
  forall s, substring 0 0 s = "".
Proof. destruct s; reflexivity. Qed.

Lemma append_eq_r_iff s1 s2 s3 :
  s1 ++ s2 = s1 ++ s3 <-> s2 = s3.
Proof.
  induction s1; cbn [append]; split;
    try inversion 1; intros; auto; [ ].
  apply IHs1. auto.
Qed.

Lemma append_eq_prefix :
  forall s1 s2 s3 s4,
    s1 ++ s2 = s3 ++ s4 ->
    prefix s1 s3 = true \/ prefix s3 s1 = true.
Proof.
  induction s1; destruct s3; cbn [append prefix] in *;
    intros; try tauto; [ ].
  match goal with H : String _ _ = String _ _ |- _ =>
                  inversion H; clear H; subst end.
  match goal with |- context [ascii_dec ?x ?y] =>
                  destruct (ascii_dec x y) end;
  subst; try tauto; [ ].
  eapply IHs1; eauto.
Qed.

Definition repeat (ch : ascii) (n : nat) : string
  := string_of_list_ascii (List.repeat ch n).

(** TODO: Better name for this? *)
Definition rfill (ch : ascii) (ls : list string) : list string
  := let len := List.fold_right Nat.max 0 (List.map String.length ls) in
     let fill s := s ++ repeat ch (len - String.length s) in
     List.map fill ls.

Definition strip_trailing_spaces (s : string) : string
  := concat NewLine (List.map rtrim (split NewLine s)).

Fixpoint strip_leading_newlines (s : list string) : list string
  := match s with
     | nil => nil
     | s :: ls => if (rtrim s =? "")%string
                  then strip_leading_newlines ls
                  else s :: ls
     end.

Definition strip_trailing_newlines (s : list string) : list string
  := List.rev_append (strip_leading_newlines (List.rev_append s nil)) nil.


Require Import TestSuite.admit.
Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.

Record SpecializedCategory (obj : Type) :=
  {
    Object :> _ := obj;
    Morphism : obj -> obj -> Type
  }.

Record > Category :=
  {
    CObject : Type;

    UnderlyingCategory :> @SpecializedCategory CObject
  }.

Record SpecializedFunctor `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) :=
  {
    ObjectOf :> objC -> objD;
    MorphismOf : forall s d, C.(Morphism) s d -> D.(Morphism) (ObjectOf s) (ObjectOf d)
  }.

(* Replacing this with [Definition Functor (C D : Category) :=
SpecializedFunctor C D.] gets rid of the universe inconsistency. *)
Section Functor.
  Variable C D : Category.

  Definition Functor := SpecializedFunctor C D.
End Functor.

Record SpecializedNaturalTransformation `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) (F G : SpecializedFunctor C D) :=
  {
    ComponentsOf :> forall c, D.(Morphism) (F c) (G c)
  }.

Definition FunctorProduct' `(F : Functor C D) : SpecializedFunctor C D.
admit.
Defined.

Definition TypeCat : @SpecializedCategory Type.
  admit.
Defined.

Definition CovariantHomFunctor `(C : @SpecializedCategory objC) : SpecializedFunctor C TypeCat.
  refine (Build_SpecializedFunctor C TypeCat
                                   (fun X : C => C.(Morphism) X X)
                                   _
         ); admit.
Defined.

Definition FunctorCategory `(C : @SpecializedCategory objC) `(D : @SpecializedCategory objD) : @SpecializedCategory (SpecializedFunctor C D).
  refine (@Build_SpecializedCategory _
                                     (SpecializedNaturalTransformation (C := C) (D := D))).
Defined.

Definition Yoneda `(C : @SpecializedCategory objC) : SpecializedFunctor C (FunctorCategory C TypeCat).
  match goal with
    | [ |- SpecializedFunctor ?C0 ?D0 ] =>
      refine (Build_SpecializedFunctor C0 D0
                                       (fun c => CovariantHomFunctor C)
                                       _
             )
  end;
  admit.
Defined.

Section FullyFaithful.
  Context `(C : @SpecializedCategory objC).
  Let TypeCatC := FunctorCategory C TypeCat.
  Let YC := (Yoneda C).
  Set Printing Universes.
  Check @FunctorProduct' C TypeCatC YC. (* Toplevel input, characters 0-37:
Error: Universe inconsistency. Cannot enforce Top.187 = Top.186 because
Top.186 <= Top.189 < Top.191 <= Top.187). *)


Require Import VST.floyd.functional_base VST.floyd.proofauto.
Require Import Coq.ZArith.BinInt.
Require Import indices.unordered_flat.
Require Import VST.floyd.library.
Require Import indices.definitions.

Infix ">=" := Z.geb : Z_scope.
Infix "<=" := Z.leb : Z_scope.
Infix "<" := Z.ltb: Z_scope.
Infix ">" := Z.gtb: Z_scope.
Infix "=" := Z.eqb: Z_scope.

Definition get_cursor_unordered {key: Type} {eq_dec: EqDec key} (k0: key) (l: flat key): Z :=
  (fix f l i :=
     match l with
     | nil => i
     | (k, v) :: tl =>
       if eq_dec k k0 then i
       else f tl (i + 1)
     end) (elements l) 0.

Fixpoint find{key value: Type} (equal: EqDec key) (l: list (key * value)) (k: key): option value :=
  match l with
  | nil => None
  | (k0, v0) :: t => if equal k0 k then Some v0 else find equal t k
  end.

Module UnorderedIndex.

Record index :=
  {
    key: Type;
    eq_dec_key: EqDec key;
    default_key: Inhabitant key;
    key_repr: share -> key -> val -> mpred;
    key_type: type;

    value := V;
    default_value: Inhabitant value;

    t: Type;
    t_repr: share -> t -> val -> mpred;
    t_type: type;

    kvpair := (key * value)%type;

    cursor := (t * Z)%type;
    cursor_repr: cursor -> val -> mpred;

    flatten: t -> flat key;

    cardinality := fun m => Zlength (elements (flatten m));

    create: t;

    get_cursor: t -> key -> cursor :=
        fun m k => (m, get_cursor_unordered k (flatten m));

    (* returns a valid kvpair from the list or None if cursor invalid
        or reached end of structure *)
    get_pair: cursor -> option kvpair :=
        fun '(m, c) => let lst := elements (flatten m) in
                              if c >= (Zlength lst) then None
                              else if c < 0 then None
                              else Some (Znth c (elements (flatten m)));

    (* moves cursor to next position *)
    move_to_next: cursor -> cursor:=
        fun '(m, c) => let newcur := (m, (c + 1)) in
                              let lst := elements (flatten m) in
                              let cond1 := Int64.ltu (Int64.repr (c+1)) (Int64.repr (Zlength lst)) in
                              let cond2 := Int64.ltu (Int64.repr 0) (Int64.repr (c+1)) in
                              if (andb cond1 cond2) then newcur
                              else (m, 0);

    move_to_first: t -> cursor := fun m => (m, 0);

    lookup: t -> key -> value :=
      fun m k => let v := find eq_dec_key (elements (flatten m)) k in
                         match v with
                         | None => nullV
                         | Some v0 => v0
                         end;

    insert: t -> key -> value -> t;
}.

Definition create_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH gv: globals, sh: share
  PRE [ ]
    PROP()
    PARAMS() GLOBALS(gv)
    SEP(mem_mgr gv)
  POST [tptr ui.(t_type)]
    EX p: val, EX m: ui.(t),
    PROP( elements(ui.(flatten) m) = [] )
    LOCAL(temp ret_temp p)
    SEP(ui.(t_repr) sh m p; mem_mgr gv).

Definition lookup_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH gv: globals, sh: share, p: val, q: val, m: ui.(t), k: ui.(key)
  PRE [ tptr ui.(t_type), tptr ui.(key_type)]
    PROP()
    PARAMS(p; q) GLOBALS()
    SEP(mem_mgr gv; ui.(t_repr) sh m p *  ui.(key_repr) sh k q)
  POST [tptr tvoid]
    PROP()
    LOCAL(temp ret_temp (proj1_sig (ui.(lookup) m k)))
    SEP(mem_mgr gv; ui.(t_repr) sh m p * ui.(key_repr) sh k q).

(* spec does not allow inserting into null structure *)
Definition insert_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH gv: globals, sh: share, mptr: val, kptr: val, m: ui.(t), k: ui.(key), v: V
  PRE [ tptr ui.(t_type), tptr ui.(key_type), tptr tvoid]
    PROP()
    PARAMS(mptr; kptr; (V_repr v)) GLOBALS(gv)
    SEP(mem_mgr gv; ui.(t_repr) sh m mptr *  ui.(key_repr) sh k kptr)
  POST [tptr tvoid]
    EX newm: ui.(t),
    PROP( ui.(lookup) newm k = v)
    LOCAL(temp ret_temp (proj1_sig (ui.(lookup) m k)))
    SEP(mem_mgr gv; ui.(t_repr) sh newm mptr * ui.(key_repr) sh k kptr).

(* takes t, returns Z *)
Definition cardinality_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH sh: share, p: val, m: ui.(t)
  PRE [tptr ui.(t_type)]
    PROP()
    PARAMS(p) GLOBALS()
    SEP(ui.(t_repr) sh m p)
  POST [tulong]
    PROP()
    LOCAL(temp ret_temp (Vptrofs (Ptrofs.repr (ui.(cardinality) m))))
    SEP(ui.(t_repr) sh m p).

(* takes t, k, returns cursor *)
(* for now, for simplicity, returns pointer to cursor *)
Definition get_cursor_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH gv: globals, sh: share, p: val, q: val, m: ui.(t), k: ui.(key)
  PRE [ tptr ui.(t_type), tptr ui.(key_type)]
    PROP()
    PARAMS(p; q) GLOBALS(gv)
    SEP(mem_mgr gv; ui.(t_repr) sh m p *  ui.(key_repr) sh k q)
  POST [tptr tvoid]
    EX r: val, EX c: ui.(cursor),
    PROP()
    LOCAL(temp ret_temp r)
    SEP(mem_mgr gv; ui.(t_repr) sh m p *  ui.(key_repr) sh k q *ui.(cursor_repr) c r).

(* takes t, returns cursor pointing to 0 *)
Definition move_to_first_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH gv: globals, sh: share, p: val, m: ui.(t), prevcur: Z
  PRE [ tptr tvoid]
    PROP()
    PARAMS(p) GLOBALS()
    SEP(mem_mgr gv; ui.(cursor_repr) (m,prevcur) p)
  POST [tptr tvoid]
    EX r: val,
    PROP()
    LOCAL(temp ret_temp r)
    SEP(mem_mgr gv; ui.(cursor_repr) (ui.(move_to_first) m) p).

(* takes t, returns cursor pointing to 0 *)
Definition move_to_next_spec
  (ui: UnorderedIndex.index): funspec :=
  WITH gv: globals, sh: share, p: val, m: ui.(t), prevcur: Z
  PRE [ tptr tvoid]
    PROP()
    PARAMS(p) GLOBALS()
    SEP(mem_mgr gv; ui.(cursor_repr) (m,prevcur) p)
  POST [tptr tvoid]
    EX r: val,
    PROP()
    LOCAL(temp ret_temp r)
    SEP(mem_mgr gv; ui.(cursor_repr) (ui.(move_to_next) (m,prevcur)) p).

End UnorderedIndex.