Require Import RamifyCoq.sample_mark.env_unionfind.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.UnionFindGraph.
Require Import RamifyCoq.msl_application.GList.
Require Import RamifyCoq.msl_application.GList_UnionFind.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_graph_glist.

Local Coercion UGraph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh P g:= (@vertices_at _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ P g).
Notation whole_graph sh g := (vertices_at sh (vvalid g) g).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ x g).
Notation Graph := (@Graph pSGG_VST).
Existing Instances maGraph finGraph liGraph RGF.

Definition vlabel_in_bound (g: Graph) := forall x, vvalid g x -> Int.min_signed <= Z.of_nat (vlabel g x) <= Int.max_signed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh: wshare, n:Z
  PRE [ 67%positive OF tint]
     PROP (0 <= n <= Int.max_signed)
     LOCAL (temp 67%positive (Vint (Int.repr n)))
     SEP ()
  POST [ tptr tvoid ]
     EX v: addr,
     PROP ()
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (data_at sh node_type (pointer_val_val null, (Vint (Int.repr 0)))
              (pointer_val_val v)).

Definition find_spec :=
 DECLARE _find
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (whole_graph sh g)
  POST [ tptr (Tstruct _Node noattr) ]
        EX g': Graph, EX rt : pointer_val,
        PROP (findS g x g' /\ uf_root g' x rt)
        LOCAL (temp ret_temp (pointer_val_val rt))
        SEP (whole_graph sh g').

Definition unionS_spec :=
 DECLARE _unionS
  WITH sh: wshare, g: Graph, x: pointer_val, y: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr)), _y OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x /\ vvalid g y)
          LOCAL (temp _x (pointer_val_val x); temp _y (pointer_val_val y))
          SEP   (whole_graph sh g)
  POST [ Tvoid ]
        EX g': Graph,
        PROP (uf_union g x y g')
        LOCAL()
        SEP (whole_graph sh g').

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, g: Graph
    PRE []
      PROP ()
      LOCAL ()
      SEP (whole_graph sh g)
    POST [tptr (Tstruct _Node noattr)]
      EX g': Graph, EX rt: pointer_val,
      PROP (~ vvalid g rt /\ vvalid g' rt /\ is_partial_graph g g')
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g').

Definition Gprog : funspecs := ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; unionS_spec]).

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function.
  forward_call (sh, 8).
  - compute. split; intros; inversion H.
  - Intros x.
    assert_PROP (x <> null) as x_not_null by (entailer !; destruct H0 as [? _]; apply H0).
    assert_PROP (~ vvalid g x) by (entailer; apply (@vertices_at_sepcon_unique_1x _ _ _ _ SGBA_VST _ _ (SGA_VST sh) (SGAvs_VST sh) g x (vvalid g) (O, null))).
    forward. forward. forward.
    Exists (make_set_Graph O tt tt x g x_not_null H). Exists x. entailer!.
    + split; simpl; [right | apply is_partial_make_set_pregraph]; auto.
    + assert (Coqlib.Prop_join (vvalid g) (eq x) (vvalid (make_set_Graph 0%nat tt tt x g x_not_null H))). {
        simpl; hnf; split; intros; [unfold graph_gen.addValidFunc | subst a]; intuition.
      } assert (vgamma (make_set_Graph O tt tt x g x_not_null H) x = (O, x)). {
        unfold vgamma, UnionFindGraph.vgamma. simpl. f_equal.
        - destruct (SGBA_VE x x); [| hnf in c; unfold Equivalence.equiv in c; exfalso]; auto.
        - unfold graph_gen.updateEdgeFunc. destruct (EquivDec.equiv_dec (x, tt) (x, tt)). 2: compute in c; exfalso; auto. destruct (SGBA_VE null null); auto.
          hnf in c. unfold Equivalence.equiv in c. exfalso; auto.
      } rewrite <- (vertices_at_sepcon_1x (make_set_Graph 0%nat tt tt x g x_not_null H) x (vvalid g) _ (O, x)); auto. apply sepcon_derives. 1: apply derives_refl.
      assert (vertices_at sh (vvalid g) g = vertices_at sh (vvalid g) (make_set_Graph O tt tt x g x_not_null H)). {
        apply vertices_at_vertices_identical. simpl. hnf. intros. destruct a as [y ?]. unfold Morphisms_ext.app_sig. simpl.
        unfold UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. f_equal.
        - destruct (SGBA_VE y x); [hnf in e; subst y; exfalso |]; auto.
        - destruct (EquivDec.equiv_dec (x, tt) (y, tt)); auto. hnf in e. inversion e. subst y. exfalso; auto.
      } rewrite <- H5. apply derives_refl.
Qed.

Lemma false_Cne_eq: forall x y, typed_false tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst; auto.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma true_Cne_neq: forall x y, typed_true tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + subst b0. pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro; apply H0. inversion H1. reflexivity.
  - intro. inversion H0. auto.
Qed.

Lemma graph_local_facts: forall sh x (g: Graph), vvalid g x -> whole_graph sh g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. eapply derives_trans; [apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (vgamma g x)); auto |].
  simpl vertex_at at 1. unfold binode. entailer!.
Qed.

(*
Lemma localize': forall R_L PureG Espec {cs: compspecs} Delta P Q R R_FR R_G c Post,
    split_FRZ_in_SEP R R_G R_FR ->
    (forall e, @derives (forall _ : environ, mpred) (@LiftNatDed' mpred Nveric) (PROPx P e) (!! PureG)) ->

  (let FR_L := @abbreviate _ R_L in
   let FR_G := @abbreviate _ R_G in
   exists  (w: FRZRw FR_L FR_G),
  @semax cs Espec Delta (PROPx (PureG :: P) (LOCALx Q (SEPx (R_L ++ @FRZR FR_L FR_G w :: R_FR)))) c Post) ->
  @semax cs Espec Delta (PROPx P (LOCALx Q (SEPx R))) c Post.
Proof.
  intros.
  destruct H1 as [? ?].
  eapply semax_pre; [clear H1 | exact H1].
  apply split_FRZ_in_SEP_spec in H.
  apply andp_left2.
  apply andp_derives; auto.
  simpl fold_right at 2.
  rewrite prop_and.
  apply andp_right. 2: apply derives_refl.
  eapply derives_trans. 2: apply H0.
  apply andp_right.
   apply derives_refl. apply derives_refl.

  apply prop_derives. intro.
  simpl.
  apply andp_derives; auto.
  unfold SEPx; intro.
  rewrite H.
  rewrite fold_right_sepcon_app.
  simpl.
  cancel.
  apply Freezer.FRZR1.
Qed.

Ltac localize' R_L PureG :=
  eapply (localize' R_L PureG); [prove_split_FRZ_in_SEP | |];
  let FR_L := fresh "RamL" in
  let FR_G := fresh "RamG" in
  intros FR_L FR_G;
  eexists;
  unfold_app.
*)

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function.
  remember (vgamma g x) as rpa eqn:?H. destruct rpa as [r pa].
  (* p = x -> parent; *)
  localize [data_at sh node_type (vgamma2cdata (vgamma g x)) (pointer_val_val x)]. rewrite <- H0. simpl vgamma2cdata.
  forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite <- H0; simpl vgamma2cdata; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (r, pa)); auto.
  assert (H_PARENT_Valid: vvalid g pa) by (eapply valid_parent; eauto).
  (* if (p != x) { *)
  forward_if
    (EX g': Graph, EX rt : pointer_val,
     PROP (findS g x g' /\ uf_root g' x rt)
     LOCAL (temp _p (pointer_val_val rt); temp _x (pointer_val_val x))
     SEP (whole_graph sh g')).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - (* p0 = find(p); *)
    forward_call (sh, g, pa). Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *.
    Opaque pointer_val_val. forward. Transparent pointer_val_val.
    (* Start ramification.  We need to get a bunch of pure facts from G1 that will
       be used both in the construction of L2 and also in the ramification entailment.
       Thus, we need to do them here.  Probably the engineering of "localize" could
       be improved to make this cleaner. *)
    (* *** *)

    pose proof (true_Cne_neq _ _ H1).
    assert ((vgamma g' x) = (r, pa)) by (apply (findS_preserves_vgamma g); auto).
    assert (weak_valid g' root) by (right; destruct H3; apply reachable_foot_valid in H3; auto).
    assert (vvalid g' x) by (destruct H2 as [_ [[? _] _]]; rewrite <- H2; apply H).
    assert (~ reachable g' root x) by (destruct H3; apply (vgamma_not_reachable' _ _ r pa); auto).
    remember (Graph_gen_redirect_parent g' x root H6 H7 H8) as g''.
    assert (ggrp_rel g' x root g''). { exists H6, H7, H8. trivial. }
    clear Heqg'' H6 H7 H8.
    (* *** *)
    localize [data_at sh node_type (Vint (Int.repr (Z.of_nat r)), pointer_val_val pa) (pointer_val_val x)].
    forward.
    Exists g''. Exists root.
    unlocalize [vertices_at sh (vvalid g'') g''] using g'' assuming H9.
    + assert (root <> null). {
        destruct H3. apply reachable_foot_valid in H3. intro. subst root. apply (valid_not_null g' null H3). simpl. auto. }
      eapply derives_trans.
      apply (@graph_gen_redirect_parent_ramify_rel _ (sSGG_VST sh)); eauto.
      apply sepcon_derives. apply derives_refl.
      apply allp_right. intro g'''.
      (* make the next 3 lines a lemma *)
      rewrite <- imp_andp_adjoint. rewrite andp_comm. rewrite imp_andp_adjoint.
      apply prop_left. intro Heqg''.
      rewrite <- imp_andp_adjoint. rewrite TT_andp.
      subst g''. apply derives_refl.
    + entailer!. split.
      * apply (graph_gen_redirect_parent_findS g g' x r r pa root _ _ _); auto.
      * simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto.
        -- apply (uf_root_edge _ (liGraph g') _ pa); auto. apply (vgamma_not_dst g' x r pa); auto.
        -- apply reachable_refl; auto.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H1. subst pa. split; split; [|split| |]; auto.
    + reflexivity.
    + apply (uf_equiv_refl _  (liGraph g)).
    + repeat intro; auto.
    + apply uf_root_vgamma with (n := r); auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed.

      assert (root <> null). {
        destruct H3. apply reachable_foot_valid in H3. intro. subst root. apply (valid_not_null g' null H3). simpl. auto. }
      eapply derives_trans.
      apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); eauto.
      apply sepcon_derives. apply derives_refl.
      apply allp_right. intro g''.
      (* make the next 3 lines a lemma *)
      rewrite <- imp_andp_adjoint. rewrite andp_comm. rewrite imp_andp_adjoint.
      apply prop_left. intro Heqg''.
      rewrite <- imp_andp_adjoint. rewrite TT_andp.
      subst g''.
      apply derives_refl.
    + entailer!. split.
      * apply (graph_gen_redirect_parent_findS g g' x r r pa root H5 H6 H8); auto.
      * simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto.
        -- apply (uf_root_edge _ (liGraph g') _ pa); auto. apply (vgamma_not_dst g' x r pa); auto.
        -- apply reachable_refl; auto.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H1. subst pa. split; split; [|split| |]; auto.
    + reflexivity.
    + apply (uf_equiv_refl _  (liGraph g)).
    + repeat intro; auto.
    + apply uf_root_vgamma with (n := r); auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed.

    assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' x root H5 H6 H8)) (Graph_gen_redirect_parent g' x root H5 H6 H8) =
              vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' x root H5 H6 H8)). {
      apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
(*    rewrite H9. *)
    (* Existentialize g'', drag it from L2 to G2. *)
    + assert (root <> null). {
        destruct H3. apply reachable_foot_valid in H3. intro. subst root. apply (valid_not_null g' null H3). simpl. auto. }
      eapply derives_trans.
      apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); eauto.
      apply sepcon_derives. apply derives_refl.
      apply allp_right. intro g''.
      (* make the next 3 lines a lemma *)
      rewrite <- imp_andp_adjoint. rewrite andp_comm. rewrite imp_andp_adjoint.
      apply prop_left. intro Heqg''.
      rewrite <- imp_andp_adjoint. rewrite TT_andp.
      subst g''.
      apply derives_refl.
    + entailer!. split.
      * apply (graph_gen_redirect_parent_findS g g' x r r pa root H5 H6 H8); auto.
      * simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto.
        -- apply (uf_root_edge _ (liGraph g') _ pa); auto. apply (vgamma_not_dst g' x r pa); auto.
        -- apply reachable_refl; auto.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H1. subst pa. split; split; [|split| |]; auto.
    + reflexivity.
    + apply (uf_equiv_refl _  (liGraph g)).
    + repeat intro; auto.
    + apply uf_root_vgamma with (n := r); auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed.

   apply wand_derives. apply derives_refl.
      Exists (Graph_gen_redirect_parent g' x root H5 H6 H8).
      apply andp_right.
      * apply prop_right. split.
        -- apply (graph_gen_redirect_parent_findS g g' x r r pa root H5 H6 H8); auto.
        -- simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto.
           ++ apply (uf_root_edge _ (liGraph g') _ pa); auto. apply (vgamma_not_dst g' x r pa); auto.
           ++ apply reachable_refl; auto.
      * rewrite H9. apply derives_refl.

        dag sh x g2] using g2 assuming H3.

    (* *** *)
    unlocalize [EX g'' : Graph, !!(findS g x g'' /\ uf_root g'' x root) && (vertices_at sh (vvalid g'') g'')].
    + (* Now for the magic: proving the ramification entailment. *)
  (*     Lemma uf_parent_ramif: forall sh g g' r pa x root, *)
  (*       vertices_at sh (vvalid g') g' *)
  (* |-- data_at sh node_type (Vint (Int.repr (Z.of_nat r)), pointer_val_val pa) *)
  (*       (pointer_val_val x) * *)
  (*     (data_at sh node_type (Vint (Int.repr (Z.of_nat r)), pointer_val_val root) *)
  (*        (pointer_val_val x) -* *)
  (*      (EX g'' : Graph, *)
  (*       !! (findS g x g'' /\ uf_root g'' x root) && vertices_at sh (vvalid g'') g'')). *)
      pose proof (true_Cne_neq _ _ H1).
      assert (weak_valid g' root) by (right; destruct H3; apply reachable_foot_valid in H3; auto).
      assert (vvalid g' x) by (destruct H2 as [_ [[? _] _]]; rewrite <- H2; apply H).
      assert ((vgamma g' x) = (r, pa)) by (apply (findS_preserves_vgamma g); auto).
      assert (~ reachable g' root x) by (destruct H3; apply (vgamma_not_reachable' _ _ r pa); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' x root H5 H6 H8)) (Graph_gen_redirect_parent g' x root H5 H6 H8) =
              vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' x root H5 H6 H8)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      assert (root <> null). {
        destruct H3. apply reachable_foot_valid in H3. intro. subst root. apply (valid_not_null g' null H3). simpl. auto. }
      eapply derives_trans.
      apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); eauto.
      apply sepcon_derives. apply derives_refl.
      apply wand_derives. apply derives_refl.
      Exists (Graph_gen_redirect_parent g' x root H5 H6 H8).
      apply andp_right.
      * apply prop_right. split.
        -- apply (graph_gen_redirect_parent_findS g g' x r r pa root H5 H6 H8); auto.
        -- simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto.
           ++ apply (uf_root_edge _ (liGraph g') _ pa); auto. apply (vgamma_not_dst g' x r pa); auto.
           ++ apply reachable_refl; auto.
      * rewrite H9. apply derives_refl.
      (* End ramification entailment. *)
    + clear. entailer!. Exists g''. Exists root. entailer!.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H1. subst pa. split; split; [|split| |]; auto.
    + reflexivity.
    + apply (uf_equiv_refl _  (liGraph g)).
    + repeat intro; auto.
    + apply uf_root_vgamma with (n := r); auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed. (* Original: 47.715 secs; VST 2.*: 2.335 secs *)

(* Print Assumptions body_find. *)

Lemma true_Ceq_eq: forall x y, typed_true tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst. reflexivity.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma false_Ceq_neq: forall x y, typed_false tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro. apply H0. inversion H1. reflexivity.
  - intro. apply n. inversion H0; reflexivity.
Qed.

Lemma body_unionS: semax_body Vprog Gprog f_unionS unionS_spec.
Proof.
  start_function.
  destruct H.
  forward_call (sh, g, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *.
  assert (vvalid g1 y) by (destruct H1 as [_ [[? _] _]]; rewrite <- H1; apply H0).
  forward_call (sh, g1, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *. destruct H1 as [_ [? _]]. destruct H4 as [_ [? _]].
  assert (H_VALID_XROOT: vvalid g2 x_root) by (destruct H4 as [? _]; rewrite <- H4; destruct H2; apply reachable_foot_valid in H2; apply H2).
  assert (H_VALID_YROOT: vvalid g2 y_root) by (destruct H5; apply reachable_foot_valid in H5; apply H5).
  assert (H_XROOT_NOT_NULL: x_root <> null) by (intro; subst x_root; apply (valid_not_null g2 null H_VALID_XROOT); simpl; auto).
  assert (H_YROOT_NOT_NULL: y_root <> null) by (intro; subst y_root; apply (valid_not_null g2 null H_VALID_YROOT); simpl; auto).
  forward_if
    (PROP (x_root <> y_root)
     LOCAL (temp _yRoot (pointer_val_val y_root); temp _xRoot (pointer_val_val x_root);
     temp _x (pointer_val_val x); temp _y (pointer_val_val y))
     SEP (vertices_at sh (vvalid g2) g2)).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - forward. Exists g2. entailer !; auto. apply true_Ceq_eq in H6. subst y_root. apply (the_same_root_union g g1 g2 x y x_root); auto.
  - forward. apply false_Ceq_neq in H6. entailer!.
  - Intros. (* xRank = xRoot -> rank; *)
    remember (vgamma g2 x_root) as rpa eqn:?H. destruct rpa as [rankXRoot paXRoot]. symmetry in H7.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
    rewrite H7. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H7; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) x_root (rankXRoot, paXRoot)); auto.
    (* yRank = yRoot -> rank; *)
    remember (vgamma g2 y_root) as rpa eqn:?H. destruct rpa as [rankYRoot paYRoot]. symmetry in H8.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
    rewrite H8. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H8; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) y_root (rankYRoot, paYRoot)); auto.
    forward_if
      (EX g': Graph,
       PROP (uf_union g x y g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
    + assert (weak_valid g2 y_root) by (right; auto). rename H_VALID_XROOT into H11.
      assert (~ reachable g2 y_root x_root) by (intro; destruct H5; specialize (H13 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)) (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      (* xRoot -> parent = yRoot; *)
      localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
      rewrite H7. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12)].
      1: rewrite H7; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Exists (Graph_gen_redirect_parent g2 x_root y_root H10 H11 H12). rewrite H13. entailer!. apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
    + assert (weak_valid g2 x_root) by (right; auto). rename H_VALID_YROOT into H11.
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H2; auto; destruct H2; specialize (H13 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)) (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      forward_if
      (EX g': Graph,
       PROP (uf_union g x y g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H8. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)].
        1: rewrite H8; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        Exists (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12). rewrite H13. entailer!. apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H8. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)].
        1: rewrite H8; simpl vgamma2cdata; rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        set (g3 := (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12)).
        assert (uf_union g x y g3) by (subst g3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        (* xRoot -> rank = xRank + 1; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
        rewrite H7. simpl vgamma2cdata. forward.
        rewrite add_repr. replace (Z.of_nat rankXRoot + 1) with (Z.of_nat (rankXRoot + 1)) by (rewrite Nat2Z.inj_add; simpl; auto).
        unlocalize [whole_graph sh (Graph_vgen g3 x_root (rankXRoot + 1)%nat)].
        -- assert (vertices_at sh (vvalid (Graph_vgen g3 x_root (rankXRoot + 1)%nat)) (Graph_vgen g3 x_root (rankXRoot + 1)%nat) =
                   vertices_at sh (vvalid g3) (Graph_vgen g3 x_root (rankXRoot + 1)%nat)). {
             apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition.
           } rewrite H16. clear H16. rewrite H7. simpl vgamma2cdata. apply (@graph_vgen_ramify _ (sSGG_VST sh)).
           ++ subst g3. simpl. auto.
           ++ subst g3. remember (Graph_gen_redirect_parent g2 y_root x_root H10 H11 H12) as g3.
              apply (graph_gen_redirect_parent_vgamma _ _ _ rankXRoot paXRoot) in Heqg3; auto. intros. inversion H16; auto.
        -- Exists (Graph_vgen g3 x_root (rankXRoot + 1)%nat). entailer!.
    + Intros g3. forward. Exists g3. entailer!.
Qed. (* Original: 205.811 secs; VST 2.*: 4.232 secs *)


Require Import VST.floyd.proofauto.
Require Import sll_dupleton.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: val) (s: (list Z)) (self_card: sll_card) {struct self_card} : mpred := match self_card with
    | sll_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | sll_card_1 _alpha_513 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_513 : sll_card))
end.

Definition sll_dupleton_spec :=
  DECLARE _sll_dupleton
   WITH x: val, y: val, r: val, a: val
   PRE [ tint, tint, (tptr (Tunion _sslval noattr)) ]
   PROP( ssl_is_valid_int((x : val)); ssl_is_valid_int((y : val)); is_pointer_or_null((r : val)); is_pointer_or_null((a : val)) )
   PARAMS(x; y; r)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (a : val))] (r : val)))
   POST[ tvoid ]
   EX elems: (list Z),
   EX z: val,
   EX _alpha_514: sll_card,
   PROP( ((elems : list Z) = ([(force_signed_int (x : val)); (force_signed_int (y : val))] : list Z)); is_pointer_or_null((z : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (z : val))] (r : val)); (sll (z : val) (elems : list Z) (_alpha_514 : sll_card))).

Lemma sll_x_valid_pointerP x s self_card: sll x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve sll_x_valid_pointerP : valid_pointer.
Lemma sll_local_factsP x s self_card :
  sll x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = sll_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_513, self_card = sll_card_1 _alpha_513))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve sll_local_factsP : saturate_local.
Lemma unfold_sll_card_0  (x: val) (s: (list Z)) : sll x s (sll_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_sll_card_1 (_alpha_513 : sll_card) (x: val) (s: (list Z)) : sll x s (sll_card_1 _alpha_513) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_513 : sll_card)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [sll_dupleton_spec; malloc_spec]).

Lemma body_sll_dupleton : semax_body Vprog Gprog f_sll_dupleton sll_dupleton_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr r). { entailer!. }
try rename a into a2.
forward.
forward_call (tarray (Tunion _sslval noattr) 2).
Intros z2.
assert_PROP (isptr z2). { entailer!. }
forward_call (tarray (Tunion _sslval noattr) 2).
Intros nxtz2.
assert_PROP (isptr nxtz2). { entailer!. }
forward.
forward.
forward.
forward.
forward.
forward; entailer!.
Exists ([(x : Z); (y : Z)] : list Z).
Exists (z2 : val).
Exists (sll_card_1 (sll_card_1 (sll_card_0  : sll_card) : sll_card) : sll_card).
ssl_entailer.
rewrite (unfold_sll_card_1 (sll_card_1 (sll_card_0  : sll_card) : sll_card)) at 1.
Exists (x : Z).
Exists (([(y : Z)] : list Z) ++ ([] : list Z)).
Exists (nxtz2 : val).
ssl_entailer.
rewrite (unfold_sll_card_1 (sll_card_0  : sll_card)) at 1.
Exists (y : Z).
Exists ([] : list Z).
Exists nullval.
ssl_entailer.
rewrite (unfold_sll_card_0 ) at 1.
ssl_entailer.

Qed.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal27.

From lfind Require Import LFind.
Lemma lfind_state  (x:lst):@eq lst (rev x) (append (rev x) Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal27_theorem0_61_append_nil/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (x:lst) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From mathcomp Require Import eqtype choice finfun finmap tuple.
From eventstruct Require Import utils inhtype ident lts relaxed.

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

Local Open Scope order_scope.
Local Open Scope fset_scope.
Local Open Scope ident_scope.

Module SharedMem.

Section Def.
Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}.

Local Notation null := (inh : Addr).
Local Notation v0   := (inh : Val).

Definition state :=
  { fsfun Addr -> Val for fun x => v0 }.

Variant label :=
  | Read  of Addr & Val
  | Write of Addr & Val
  | Bot
  .

Definition typ : label -> Lab.typ :=
  fun l => match l with
  | Read  _ _ => Lab.Read
  | Write _ _ => Lab.Write
  | Bot       => Lab.Undef
  end.

Definition addr : label -> Addr :=
  fun l => match l with
  | Read  x _ => x
  | Write x _ => x
  | Bot       => null
  end.

Definition value : label -> Val :=
  fun l => match l with
  | Read  _ v => v
  | Write _ v => v
  | Bot       => v0
  end.

End Def.

Arguments state {_ _} _ _ .
Arguments label {_ _} _ _ .

Section Encode.
Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}.

Definition enc_lab : (label Addr Val) -> Addr * Val + Addr * Val + unit :=
  fun l => match l with
  | Read  x v => inl (inl (x, v))
  | Write x v => inl (inr (x, v))
  | Bot       => inr tt
  end.

Definition dec_lab : Addr * Val + Addr * Val + unit -> (label Addr Val) :=
  fun l => match l with
  | inl (inl (x, v)) => Read x v
  | inl (inr (x, v)) => Write x v
  | inr _            => Bot
  end.

Lemma enc_dec_labK :
  cancel enc_lab dec_lab.
Proof. by case. Qed.

End Encode.

Module Export Exports.
Section Exports.
Context {dA dV : unit} {A : inhType dA} {V : inhType dV}.

Definition label_eqMixin :=
  CanEqMixin (@enc_dec_labK _ _ A V).
Canonical label_eqType :=
  Eval hnf in EqType _ label_eqMixin.

Definition label_choiceMixin :=
  CanChoiceMixin (@enc_dec_labK _ _ A V).
Canonical label_choiceType :=
  Eval hnf in ChoiceType _ label_choiceMixin.

End Exports.
End Exports.

Module Export LTS.
Section LTS.
Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}.
Local Notation state := (state Addr Val).
Local Notation label := (label Addr Val).
Implicit Types (m : state) (l : label).

Definition read_trans l m m' :=
  let x := addr l in
  let v := value l in
  (typ l == Lab.Read) && (m x == v) && (m' == m).

Definition write_trans l m m' :=
  let x := addr l in
  let v := value l in
  (typ l == Lab.Write) && (m' == [fsfun m with x |-> v]).

Definition ltrans l m m' :=
  (read_trans l m m') || (write_trans l m m').

Definition enabled l m :=
  match l with
  | Read  x v => m x == v
  | Write x v => true
  | Bot       => false
  end.

Lemma enabledP l m :
  reflect (exists m', ltrans l m m') (enabled l m).
Proof.
  rewrite /ltrans /read_trans /write_trans /enabled.
  case: l=> [x v | x v |]; try constructor=> //=; last first.
  - by move=> [[]].
  - by exists ([fsfun m with x |-> v]).
  case: (m x == v)=> //=; constructor; last by move=> [].
  by exists m; rewrite eqxx.
Qed.

End LTS.

Module Export Exports.
Section Exports.
Context {dA dV : unit} {A : inhType dA} {V : inhType dV}.

Definition ltsMixin :=
  let S := (state A V) in
  let L := (label A V) in
  @LTS.LTS.Mixin S L _ _ _ enabledP.
Definition ltsType :=
  Eval hnf in (LTSType _ _ ltsMixin).

End Exports.
End Exports.

End LTS.

Export LTS.Exports.

Module Export Label.
Section Label.
Context {dA dV : unit} {Addr : inhType dA} {Val : inhType dV}.
Local Notation label := (label Addr Val).
Implicit Types (ls : {fset label}) (l : label).

Definition rf : rel label :=
  fun w r => match w, r with
  | Write x a, Read y b => (x == y) && (a == b)
  | _ , _ => false
  end.

Definition com ws r :=
  let w := odflt Bot (fset_pick ws) in
  (#|` ws | == 1) && (rf w r).

Definition cf_typ l1 l2 :=
  match (typ l1), (typ l2) with
  | Lab.Read , Lab.Write  => true
  | Lab.Write, Lab.Read   => true
  | Lab.Write, Lab.Write  => true
  | _        , _          => false
  end.

Definition cf l1 l2 :=
  (cf_typ l1 l2) && (addr l1 == addr l2).

Definition is_write l :=
  typ l == Lab.Write.

Definition is_read l :=
  typ l == Lab.Read.

Lemma is_writeP w :
  reflect (exists ws r, com ws r /\ w \in ws) (is_write w).
Proof.
  apply/(equivP idP); split; rewrite /com /rf.
  - move=> isW; exists [fset w].
    move: w isW; case=> //= x v _.
    exists (Read x v); rewrite inE; split=> //=.
    by rewrite fset_pick1 cardfs1 /= !eqxx.
  move=> /= [ws] [r] [] /andP[] /cardfs1P[w'] ->.
  rewrite fset_pick1 inE /=.
  by move=> /[swap] /eqP<-; case: w.
Qed.

Lemma is_readP r :
  reflect (exists ws, com ws r) (is_read r).
Proof.
  apply/(equivP idP); split; rewrite /com /rf.
  - case: r=> // x v _.
    exists [fset (Write x v)].
    by rewrite fset_pick1 cardfs1 /= !eqxx.
  move=> [ws] /andP[] /cardfs1P[w] ->.
  rewrite fset_pick1 /=.
  by case: w; case: r.
Qed.

Lemma bot_nwrite :
  ~~ is_write Bot.
Proof. done. Qed.

Lemma bot_nread :
  ~~ is_read Bot.
Proof. done. Qed.

End Label.

Module Export Exports.
Section Exports.
Context {dA dV : unit} {A : inhType dA} {V : inhType dV}.

Definition inhMixin := @Inhabited.Mixin (label A V) _ Bot.
Canonical inhType := Eval hnf in InhType (label A V) Bottom.disp inhMixin.

Definition labMixin :=
  @Lab.Lab.Mixin (label A V) _ com cf is_write is_read
    is_writeP is_readP bot_nwrite bot_nread.
Canonical labType :=
  Lab.Lab.Pack (Lab.Lab.Class labMixin).

End Exports.
End Exports.

End Label.

End SharedMem.

Export SharedMem.Exports.
Export SharedMem.LTS.Exports.
Export SharedMem.Label.Exports.


Require Import Core.

Notation "x >> y" := (Z.shiftr x y) (at level 70) : Z_scope.
Notation "x << y" := (Z.shiftl x y) (at level 70) : Z_scope.
Infix "&" := Z.land (at level 70) : Z_scope.
Infix "or" := Z.lor (at level 70): Z_scope.

(* Notations for integers and ptrofs *)

Delimit Scope ByteScope with byte.
Infix "==" := Byte.eq (at level 70) : ByteScope.
Notation "x ~= y" := (negb (Byte.eq x y)) (at level 70) : ByteScope.
Notation "x >> y" := (Byte.shru x y) (at level 70) : ByteScope.
Notation "0" := Byte.zero : ByteScope.
Notation "1" := Byte.one : ByteScope.
Infix "+" := Byte.add  : ByteScope.
Infix "-" := Byte.sub : ByteScope.
Infix "*" := Byte.mul : ByteScope.
Infix "<" := Byte.lt : ByteScope.
Infix "<u" := Byte.ltu (at level 70) : ByteScope.
Notation "x <=u y" := (negb (Byte.ltu y x)) (at level 70) : ByteScope.
Notation "x <= y" := (negb (Byte.lt y x)) (at level 70) : ByteScope.
Infix "%" := Byte.mods (at level 70) : ByteScope.
Infix "//" := Byte.divs (at level 70) : ByteScope.
Infix "&" := Byte.and (at level 70) : ByteScope.

Delimit Scope IntScope with int.
Infix "==" := Int.eq (at level 70) : IntScope.
Notation "x ~= y" := (negb Int.eq x y) (at level 70) : IntScope.
Notation "x >> y" := (Int.shr x y) (at level 70) : IntScope.
Notation "x >>u y" := (Int.shru x y) (at level 70) : IntScope.
Notation "x << y" := (Int.shl x y) (at level 70) : IntScope.
Notation "0" := Int.zero : IntScope.
Notation "1" := Int.one : IntScope.
Infix "+" := Int.add : IntScope.
Infix "-" := Int.sub : IntScope.
Infix "*" := Int.mul : IntScope.
Infix "<" := Int.lt : IntScope.
Infix "<u" := Int.ltu (at level 70) : IntScope.
Notation "x <=u y" := (negb (Int.ltu y x)) (at level 70) : IntScope.
Notation "x <= y" := (negb (Int.lt y x)) (at level 70) : IntScope.
Infix "%" := Int.mods (at level 70) : IntScope.
Infix "//" := Int.divs (at level 70) : IntScope.
Infix "&" := Int.and (at level 70) : IntScope.
Infix "or" := Int.or (at level 70) : IntScope.

Delimit Scope Int64Scope with int64.
Infix "==" := Int64.eq (at level 70) : Int64Scope.
Notation "x ~= y" := (negb Int64.eq x y) (at level 70) : Int64Scope.
Notation "x >> y" := (Int64.shru x y) (at level 70) : Int64Scope.
Notation "0" := Int64.zero : Int64Scope.
Notation "1" := Int64.one : Int64Scope.
Infix "+" := Int64.add : Int64Scope.
Infix "-" := Int64.sub : Int64Scope.
Infix "*" := Int64.mul : Int64Scope.
Infix "<" := Int64.lt : Int64Scope.
Notation "x <= y" := (negb (Int64.lt y x)) (at level 70) : Int64Scope.
Notation "x <=u y" := (negb (Int64.ltu y x)) (at level 70) : Int64Scope.
Infix "%" := Int64.mods (at level 70) : Int64Scope.
Infix "//" := Int64.divs (at level 70) : Int64Scope.

Delimit Scope PtrofsScope with ptrofs.
Infix "==" := Ptrofs.eq (at level 70) : PtrofsScope.
Notation "x ~= y" := (negb Ptrofs.eq x y) (at level 70) : PtrofsScope.
Notation "x >> y" := (Ptrofs.shru x y) (at level 70) : PtrofsScope.
Notation "0" := Ptrofs.zero : PtrofsScope.
Notation "1" := Ptrofs.one : PtrofsScope.
Infix "+" := Ptrofs.add : PtrofsScope.
Infix "-" := Ptrofs.sub : PtrofsScope.
Infix "*" := Ptrofs.mul : PtrofsScope.
Infix "<" := Ptrofs.lt : PtrofsScope.
Infix "<u" := Ptrofs.ltu (at level 70) : PtrofsScope.
Notation "x <= y" := (negb (Ptrofs.lt y x)) (at level 70) : PtrofsScope.
Notation "x <=u y" := (negb (Ptrofs.ltu y x)) (at level 70) : PtrofsScope.
Infix "%" := Ptrofs.mods (at level 70) : PtrofsScope.
Infix "//" := Ptrofs.divs (at level 70) : PtrofsScope.

Delimit Scope PTreeScope with ptree.
Notation "a <~ b" := (a, b) (at level 85, only parsing).
Definition s {A : Type} (a : (positive * A)) := PTree.set (fst a) (snd a).
Notation "'in' env 'set' [ x ; .. ; y ]" :=
  ((s x) .. ((s y) env) ..)
    (at level 85, right associativity).

Delimit Scope ByteScope with byte.
Infix "==" := Byte.eq (at level 70) : ByteScope.
Notation "x ~= y" := (negb Byte.eq x y) (at level 70) : ByteScope.
Notation "x >> y" := (Byte.shru x y) (at level 70) : ByteScope.
Notation "0" := Byte.zero : ByteScope.
Notation "1" := Byte.one : ByteScope.
Infix "+" := Byte.add : ByteScope.
Infix "-" := Byte.sub : ByteScope.
Infix "*" := Byte.mul : ByteScope.
Infix "<" := Byte.lt (at level 70) : ByteScope.
Notation "x <=u y" := (negb (Byte.ltu y x)) (at level 70) : ByteScope.
Notation "x <= y" := (negb (Byte.lt y x)) (at level 70) : ByteScope.
Infix "%" := Byte.mods (at level 70) : ByteScope.
Infix "//" := Byte.divs (at level 70) : ByteScope.

(* Byte list notations *)
Notation all_zero := Byte.zero.
Definition all_one  := Byte.repr (Byte.max_unsigned).
Notation default_byte := all_zero.
Notation "t @ n" := (Byte.testbit t n) (at level 50).
Notation len a := (Zlength a).
Definition flatten {A} l := fold_right (@app _) (@nil A) l.

Class Nth A :=
  { default : A;
    n_th : Z -> list A -> A;
    hd_nth : list A -> A }.

Notation "ls # n" := (n_th n ls) (at level 70).

Instance Nth_Byte : Nth byte :=
  { default := default_byte ;
    n_th := fun n ls => nth (Z.to_nat n) ls default_byte;
    hd_nth := fun ls => List.hd default_byte ls
    }.

Instance Nth_Bool : Nth bool :=
  { default := false ;
    n_th := fun n ls => nth (Z.to_nat n)  ls false;
    hd_nth := fun ls => List.hd false ls
 }.

Instance Nth_List {A} : Nth (list A) :=
  { default := [] ;
    n_th := fun n ls => nth (Z.to_nat n) ls [];
    hd_nth := fun ls => List.hd [] ls
 }.

Require Import ExtLib.Structures.Monad.

Inductive DWT_Error := .

 Delimit Scope monad_scope with monad.

  Notation "c >>= f" := (@bind _ _ _ _ c f) (at level 58, left associativity) : monad_scope.
  Notation "f =<< c" := (@bind _ _ _ _ c f) (at level 61, right associativity) : monad_scope.
  Notation "f >=> g" := (@mcompose _ _ _ _ _ f g) (at level 55, right associativity) : monad_scope.

  Notation "x <- c1 ;; c2" := (@bind _ _ _ _ c1 (fun x => c2))
    (at level 61, c1 at next level, right associativity) : monad_scope.

  Notation "e1 ;; e2" := (_ <- e1%monad ;; e2%monad)%monad
    (at level 61, right associativity) : monad_scope.

  Notation "' pat <- c1 ;; c2" :=
    (@bind _ _ _ _ c1 (fun x => match x with pat => c2 end))
    (at level 61, pat pattern, c1 at next level, right associativity) : monad_scope.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Compilers.Named.ContextProperties.
Require Import Crypto.Compilers.Named.ContextDefinitions.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.Wf.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.Option.

Section language.
  Context {base_type_code Name : Type}
          {op : flat_type base_type_code -> flat_type base_type_code -> Type}
          {base_type_code_dec : DecidableRel (@eq base_type_code)}
          {Name_dec : DecidableRel (@eq Name)}.

  Section with_var.
    Context {var}
            (uContext : @Context base_type_code Name (fun _ => unit))
            (uContextOk : ContextOk uContext)
            (vContext : @Context base_type_code Name var)
            (vContextOk : ContextOk vContext).

    Local Ltac t :=
      repeat first [ progress simpl in *
                   | progress intros
                   | progress subst
                   | progress inversion_option
                   | congruence
                   | tauto
                   | solve [ eauto ]
                   | break_innermost_match_step
                   | break_innermost_match_hyps_step
                   | progress destruct_head'_and
                   | progress autorewrite with push_prop_of_option push_eq_Some_trivial in *
                   | rewrite !(@lookupb_extend base_type_code _ Name _) by auto
                   | rewrite (@find_Name_and_val_split base_type_code _ Name _) with (default := lookupb _ _)
                   | match goal with
                     | [ H : ?x = Some _ |- _ ]
                       => assert (x = None) by (split_iff; eauto); congruence
                     | [ |- _ /\ _ ] => split
                     | [ H : _ |- prop_of_option _ ] => eapply H; [ | eassumption ]; clear H
                     | [ |- context[find_Name_and_val ?tdec ?ndec ?b _ _ _ _ = None] ]
                       => rewrite <- !(@find_Name_and_val_None_iff _ tdec _ ndec _ b)
                     end ].

    Lemma wff_from_unit
          (vctx : vContext)
          (uctx : uContext)
          (Hctx : forall t n, lookupb t vctx n = None <-> lookupb t uctx n = None)
          {t} (e : @exprf base_type_code op Name t)
      : wff_unit uctx e = Some trivial -> prop_of_option (wff vctx e).
    Proof using Name_dec base_type_code_dec uContextOk vContextOk.
      revert uctx vctx Hctx; induction e; t.
    Qed.

    Lemma wf_from_unit
          (vctx : vContext)
          (uctx : uContext)
          (Hctx : forall t n, lookupb t vctx n = None <-> lookupb t uctx n = None)
          {t} (e : @expr base_type_code op Name t)
      : wf_unit uctx e = Some trivial -> wf vctx e.
    Proof using Name_dec base_type_code_dec uContextOk vContextOk.
      intros H ?; revert H; apply wff_from_unit; t.
    Qed.
  End with_var.

  Lemma Wf_from_unit
        (Context : forall var, @Context base_type_code Name var)
        (ContextOk : forall var, ContextOk (Context var))
        {t} (e : @expr base_type_code op Name t)
    : wf_unit (Context:=Context _) empty e = Some trivial -> Wf Context e.
  Proof using Name_dec base_type_code_dec.
    intros H ?; revert H; apply wf_from_unit; auto; intros.
    rewrite !lookupb_empty by auto; tauto.
  Qed.
End language.

Hint Resolve wf_from_unit Wf_from_unit wff_from_unit : wf.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableWalk.Spec.
Require Import AbsAccessor.Spec.
Require Import TableAux3.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_create_spec0 (g_rd: Pointer) (map_addr: Z64) (level: Z64) (g_rtt: Pointer) (rtt_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, level, g_rtt, rtt_addr with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _level, (_g_rtt_base, _g_rtt_ofst), VZ64 _rtt_addr =>
      let _ret := 0 in
      rely is_int64 (_level - 1);
      rely is_int64 _map_addr;
      when adt == table_walk_lock_unlock_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 (_level - 1)) adt;
      when'' _g_llt_base, _g_llt_ofst == get_wi_g_llt_spec  adt;
      rely is_int _g_llt_ofst;
      when' _index == get_wi_index_spec  adt;
      rely is_int64 _index;
      when _t'6 == is_null_spec (_g_llt_base, _g_llt_ofst) adt;
      rely is_int _t'6;
      if (_t'6 =? 1) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _ll_table_base, _ll_table_ofst, adt == granule_map_spec (_g_llt_base, _g_llt_ofst) 5 adt;
        rely is_int _ll_table_ofst;
        when' _llt_pte == pgte_read_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) adt;
        rely is_int64 _llt_pte;
        when _t'5 == entry_is_table_spec (VZ64 _llt_pte) adt;
        rely is_int _t'5;
        if (_t'5 =? 1) then
          let _ret := 1 in
          when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
          when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
          Some (adt, (VZ64 _ret))
        else
          rely is_int64 _level;
          rely is_int64 _rtt_addr;
          when adt == table_create_aux_spec (_g_rd_base, _g_rd_ofst) (_g_llt_base, _g_llt_ofst) (_g_rtt_base, _g_rtt_ofst) (VZ64 _llt_pte) (_ll_table_base, _ll_table_ofst) (VZ64 _level) (VZ64 _index) (VZ64 _map_addr) (VZ64 _rtt_addr) adt;
          when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
          when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
          Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require Import PerformanceExperiments.Harness.

Fixpoint foralln n (x : nat) (k : nat -> Prop) :=
  match n with
  | O => k x
  | S n =>
    forall x : nat, foralln n x k
  end.

Definition args_of_size (s : size) : list nat
  := match s with
     | Sanity => seq 0 3
     | SuperFast => seq 0 100
     | Fast => List.map (fun x => 50 * x) (seq 0 40)
     | Medium => []
     | Slow => []
     | VerySlow => []
     end.

Ltac mkgoal n := constr:(foralln n O (fun _ => True)).
Ltac redgoal _ := idtac.
Ltac time_solve_goal0 n :=
  cut True;
  [ intros _;
    time "abstract-intros"
         abstract (
           cbv beta iota delta [foralln];
           time "intros" intros;
           restart_timer;
           exact I
         )
  | finish_timing ("Tactic call close-abstract") ].
Ltac run0 sz := Harness.runtests args_of_size default_describe_goal mkgoal redgoal time_solve_goal0 sz.
(*
Goal True. run0 Fast.
 *)


Require Export RecTypes.SpecTypes.
Require Export RecTypes.InstTy.
Require Export RecTypes.Contraction.
Require Export RecTypes.ValidTy.
Require Export RecTypes.LemmasTypes.

Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.SpecTyping.
Require Import StlcEqui.LemmasTyping.

(* Lemma can_form_tarr {Γ t τ₁ τ₂} *)
(*   (v: Value t) (wt: ⟪ Γ e⊢ t : τ₁ e⇒ τ₂ ⟫)  : *)
(*   ∃ σ₁ t₂, *)
(*     ⟪ τ₁ ≗ σ₁ ⟫ → *)
(*     t = abs σ₁ t₂ ∧ *)
(*     ⟪ Γ e▻ τ₁ e⊢ t₂ : τ₂ ⟫. *)
(* Proof. depind wt; try contradiction; eauto. *)
(*        depind T; try inversion H; eauto. *)
(*        - (* tarr *) *)
(*          subst. *)
(*          apply (IHwt _ _ v). *)

(*        - (* trec *) idtac. *)
(* Qed. *)

Lemma trec_tunit_eq_tunit : ⟪ tunit ≗ trec tunit ⟫.
Proof.
  constructor;
  eauto with simple_contr_rec.
  cbn.
  apply tyeq_refl.
Qed.

Lemma can_form_tarr {Γ t τ τ₁ τ₂}
  (v: Value t) (wt: ⟪ Γ e⊢ t : τ ⟫) (tyeq: ⟪ τ ≗ τ₁ r⇒ τ₂ ⟫) :
  ValidEnv Γ ->
  ValidTy τ ->
  ValidTy τ₁ →
  ValidTy τ₂ →
  ∃ t₂ τ₁',
    ⟪ τ₁' ≗ τ₁ ⟫ ∧
      ValidTy τ₁' /\
    t = abs τ₁' t₂ ∧
    ⟪ Γ r▻ τ₁ e⊢ t₂ : τ₂ ⟫.
Proof.
  depind wt; try inversion tyeq; try contradiction; eauto;
  subst; intros.
  - exists t, τ₁0.
    destruct (ValidTy_invert_arr H1) as [τ1_v τ2_v].
    repeat (split; eauto).
    apply (WtEq _ H5); eauto.
    eapply (eqctx_implies_eqty (Γ r▻ τ₁0));
    eauto using enveq_refl with tyvalid tyeq.
  - apply IHwt; eauto.
    unshelve eapply (eq_trans_contr _ H tyeq); eauto with simple_contr_rec tyvalid.
  - apply IHwt; eauto.
    unshelve eapply (eq_trans_contr _ H tyeq); eauto with simple_contr_rec tyvalid.
Qed.

Lemma can_form_tunit {Γ t τ}
  (v: Value t) (wt: ⟪ Γ e⊢ t : τ ⟫) (tyeq: ⟪ τ ≗ tunit ⟫) :
    t = unit.
Proof.
  depind wt; try inversion tyeq; try contradiction; eauto.
  subst.
  apply (IHwt v H).
  apply (IHwt v).
  subst.
  unshelve eapply (eq_trans_contr _ H tyeq);
    eauto with simple_contr_rec.
Qed.

Lemma can_form_tunit' {Γ t}
  (v: Value t) (wt: ⟪ Γ e⊢ t : tunit ⟫) :
    t = unit.
Proof.
  apply (can_form_tunit v wt).
  eapply tyeq_refl.
Qed.

Lemma can_form_tbool {Γ t τ}
  (v: Value t) (wt: ⟪ Γ e⊢ t : τ ⟫) (tyeq: ⟪ τ ≗ tbool ⟫):
    t = true ∨ t = false.
Proof.
  depind wt; try inversion tyeq; try contradiction; eauto;
  subst;
  apply (IHwt v).
  assumption.
  unshelve eapply (eq_trans_contr _ H tyeq);
    eauto with simple_contr_rec.
Qed.

Lemma can_form_tbool' {Γ t}
  (v: Value t) (wt: ⟪ Γ e⊢ t : tbool ⟫) :
    t = true ∨ t = false.
Proof. apply (can_form_tbool v wt); apply tyeq_refl. Qed.

Lemma can_form_tprod {Γ t τ τ₁ τ₂}
  (v: Value t) (wt: ⟪ Γ e⊢ t : τ ⟫) (tyeq: ⟪ τ ≗ τ₁ r× τ₂ ⟫) :
  ValidEnv Γ →
  ValidTy τ₁ ->
  ValidTy τ₂ ->
  ∃ t₁ t₂, t = pair t₁ t₂ ∧
  ⟪ Γ e⊢ t₁ : τ₁ ⟫ ∧
  ⟪ Γ e⊢ t₂ : τ₂ ⟫.
Proof.
  depind wt; try inversion tyeq; try contradiction;
  subst; intros.
  - exists t₁, t₂. repeat split; eapply WtEq; eauto using typed_terms_are_valid with tyvalid.
  - apply IHwt; eauto.
    refine (eq_trans_contr _ H _);
    eauto with simple_contr_rec.
  - apply IHwt; eauto.
    (refine (eq_trans_contr _ H _); eauto with simple_contr_rec).
Qed.

Lemma can_form_tsum {Γ t τ τ₁ τ₂}
  (v: Value t) (wt: ⟪ Γ e⊢ t : τ ⟫) (tyeq: ⟪ τ ≗ τ₁ r⊎ τ₂ ⟫) :
  ValidEnv Γ ->
  ValidTy τ₁ →
  ValidTy τ₂ →
    (∃ t₁, t = inl t₁ ∧ ⟪  Γ e⊢ t₁ : τ₁ ⟫) ∨
    (∃ t₂, t = inr t₂ ∧ ⟪  Γ e⊢ t₂ : τ₂ ⟫).
Proof.
  depind wt; try inversion tyeq; try contradiction; subst.
  - left;
    exists t; repeat split; eapply WtEq; eauto using typed_terms_are_valid.
  - right;
    exists t; repeat split; eapply WtEq; eauto using typed_terms_are_valid .
  - intros.
    apply IHwt; eauto.
    refine (eq_trans_contr _ H _); eauto with simple_contr_rec tyvalid.
  - intros.
    apply IHwt; eauto.
    refine (eq_trans_contr _ H _); eauto with simple_contr_rec tyvalid.
Qed.

Ltac stlcCanForm1 :=
  match goal with
    | [ wt: ⟪ _ e⊢ ?t : tarr ?τ₁ ?τ₂ ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tarr (τ₁ := τ₁) (τ₂ := τ₂) vt wt); subst; clear wt
    | [ wt: ⟪ _ e⊢ ?t : tunit ⟫, vt: Value ?t |- _ ] =>
      pose proof (can_form_tunit vt wt); subst; clear wt
    | [ wt: ⟪ _ e⊢ ?t : tbool ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tbool vt wt); subst; clear wt
    | [ wt: ⟪ _ e⊢ ?t : tprod ?τ₁ ?τ₂ ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tprod (τ₁ := τ₁) (τ₂ := τ₂) vt wt) as (? & ? & ? & ? & ?);
      eauto with tyeq tyvalid;
      subst; clear wt
    | [ wt: ⟪ _ e⊢ ?t : tsum ?τ₁ ?τ₂ ⟫, vt: Value ?t |- _ ] =>
      destruct (can_form_tsum (τ₁ := τ₁) (τ₂ := τ₂) vt wt) as [[? [? ?]]|[? [? ?]]];
      eauto with tyeq tyvalid;
      subst; clear wt; simpl in vt
  end.

Ltac stlcCanForm :=
  repeat stlcCanForm1.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Import CpdtTactics.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.
Require Import wyv_common.
Require Import rhs_mat_tree.
Set Implicit Arguments.

Import WfExtensionality.

Lemma subtype_sel_low_sel_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_upp x2 L2 T2') ->
                                  subtype T1 T2 = andb (eq_var x1 x2)
                                                       (eq_label L1 L2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_sel_low_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_low x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1 T2').
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_sel_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_equ x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (subtype T1 T2').
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_sel_nom_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_nom x2 L2 T2') ->
                                  subtype T1 T2 = andb (eq_var x1 x2)
                                                       (eq_label L1 L2).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_upp_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_upp L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_low_low_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_low L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_low_equ_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 L2 T2', T2 = (t_equ L2 T2') ->
                               subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_low_nom_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 L2 t T2', T2 = (t_nom L2 t T2') ->
                                 subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.

Qed.

Lemma subtype_sel_low_rfn_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 Ts, T2 = (t_rfn_top Ts) ->
                           subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_rfn_sel_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall x2 L2 T2 Ts T', T2 = (t_rfn_sel x2 L2 Ts T') ->
                                    subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_sha_top_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 ss2, T2 = (t_sha_top x2 L2 ss2) ->
                                  subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_sha_sel_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 x2 L2 ss2 T', T2 = (t_sha_sel x2 L2 ss2 T') ->
                                     subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_all_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 T T', T2 = (t_all T T') ->
                             subtype T1 T2 = false.
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_bot_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  subtype T1 t_bot = false.
Proof.
  intros.

  remember (subtype T1 t_bot) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_nil_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  subtype T1 t_nil = false.
Proof.
  intros.

  remember (subtype T1 t_bot) as sub_fn; subst T1.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.

Lemma subtype_sel_low_con_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_low x1 L1 T1') ->
                  forall T2 T Ts, T2 = t_con T Ts ->
                             subtype T1 T2 = false.
Proof.
  intros; subst.

  unfold subtype, subtype_func;
    simpl;
    rewrite fix_sub_eq_ext;
    simpl;
    fold subtype_func;
    auto.
Qed.

Lemma subtype_sel_low_reduce :
  forall T1 x1 L1 T1',
    T1 = (t_sel_low x1 L1 T1') ->
    forall T2, subtype T1 T2 = match T2 with
                          | t_top => true
                          | t_sel_low x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                          | t_sel_equ x2 L2 T2' => orb (andb (eq_var x1 x2) (eq_label L1 L2)) (subtype T1 T2')
                          | t_sel_upp x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                          | t_sel_nom x2 L2 _ => andb (eq_var x1 x2) (eq_label L1 L2)
                          | _ => false
                          end.
Proof.
  intros.

  destruct T2.

  apply subtype_top;
    subst;
    intros;
    intro Hcontra;
    inversion Hcontra.

  subst;
    apply subtype_sel_low_bot_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_upp_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_low_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_equ_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sel_nom_reduce
      with (x1:=x1)(L1:=L1)(T2':=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_rfn_top_reduce
      with (x1:=x1)(L1:=L1)(Ts:=T2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_rfn_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(Ts:=T2_1)(T':=T2_2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_sha_top_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T1':=T1')(ss2:=d);
    auto.

  subst;
    apply subtype_sel_low_sha_sel_reduce
      with (x1:=x1)(L1:=L1)(x2:=v)(L2:=l)(T':=T2)(T1':=T1')(ss2:=d);
    auto.

  subst;
    apply subtype_sel_low_all_reduce
      with (x1:=x1)(L1:=L1)(T:=T2_1)(T':=T2_2)(T1':=T1');
    auto.

  subst;
    apply subtype_sel_low_upp_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_low_low_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_low_equ_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst;
    apply subtype_sel_low_nom_reduce
      with (x1:=x1)(L1:=L1)(T1':=T1')(L2:=l)(T2':=T2);
    auto.

  subst; eapply subtype_sel_low_nil_reduce; eauto.

  subst; eapply subtype_sel_low_con_reduce; eauto.
Qed.


From Flocq Require Core Binary.
From Coquelicot Require Import Coquelicot.
Require Import Reals Gappa.Gappa_library Psatz.
Import Defs Raux FLT Generic_fmt Gappa_definitions Binary Ulp.
Require Import FunInd Recdef.
Require Import float_lemmas.

From compcert.lib Require Import Floats Integers.

Transparent Float32.div Float32.add Float32.cmp.

(* Correctness of floating-point absolute value.  We don't need this
   for sqrt, but it's useful elsewhere. *)
Lemma fabs_float32_lemma:
  forall x: float32,
  Float32.of_bits (Int.and (Float32.to_bits x) (Int.repr 2147483647)) =
  Float32.abs x.
Proof.
Admitted.

Definition sqrt_approx_f (x: float32) : float32 :=
  Float32.of_bits
  (Int.add (Int.shru (Float32.to_bits x) (Int.repr 1))
     (Int.repr 532676608)).

Definition float32_to_real := Binary.B2R 24 128.

Lemma bits_of_b32_range:
  forall x, 0 <= Bits.bits_of_b32 x < 2^32.
Proof.
intros.
apply (Bits.bits_of_binary_float_range); reflexivity.
Qed.

Lemma bits_of_b32_range':
  forall x, 0 <= Bits.bits_of_b32 x <= Int.max_unsigned.
Proof.
intros.
pose proof (bits_of_b32_range x).
change Int.max_unsigned with (2^32-1).
lia.
Qed.

Lemma add_repr: forall i j, Int.add (Int.repr i) (Int.repr j) = Int.repr (i+j).
Proof. intros.
  rewrite Int.add_unsigned.
 apply Int.eqm_samerepr.
 unfold Int.eqm.
 apply Int.eqm_add; apply Int.eqm_sym; apply Int.eqm_unsigned_repr.
Qed.

Lemma sqrt_approx_eq:
 forall x, sqrt_approx_f x =
       Bits.b32_of_bits (Bits.bits_of_b32 x / 2 + 532676608).
Proof.
intros.
unfold sqrt_approx_f.
Transparent Float32.of_bits.
Transparent Float32.to_bits.
unfold Float32.of_bits, Float32.to_bits.
Opaque Float32.of_bits.
Opaque Float32.to_bits.
unfold Int.shru.
rewrite Int.unsigned_repr by apply bits_of_b32_range'.
rewrite Int.unsigned_repr by (compute; split; congruence).
rewrite add_repr.
rewrite <- Z.div2_spec, Z.div2_div.
assert  (0 <= Bits.bits_of_b32 x / 2 < 2 ^ 31)%Z.
 apply Coqlib.Zdiv_interval_1.
 compute; congruence. reflexivity. reflexivity.
 apply bits_of_b32_range.
rewrite Int.unsigned_repr
  by (change Int.max_unsigned with (2^31 + 2^31 -1)%Z; lia).
auto.
Qed.

Lemma bound_mantissa_Z :
  forall (m: positive) (e: Z), bounded ms es m e = true ->
     (Z.pos m < 2 ^ ms)%Z.
Proof.
intros.
apply bound_mantissa_nat in H.
apply inj_lt in H.
rewrite positive_nat_Z in H.
change 2%nat with (Z.to_nat 2) in H.
rewrite <- Zto_nat_pow in H by (compute; congruence).
rewrite Z2Nat.id in H; auto.
apply Z.pow_nonneg.
compute; congruence.
Qed.

Lemma sqrt_approx_correct:
 forall x,
  is_finite_strict ms es x = true ->
  Bsign ms es x = false ->
  (Rbasic_fun.Rabs (float32_to_real (sqrt_approx_f x) - R_sqrt.sqrt (float32_to_real x)) <=
       (1 + 1/16) * R_sqrt.sqrt (float32_to_real x))%R.
Proof.
intros.
rewrite sqrt_approx_eq.
unfold float32_to_real.
fold ms. fold es.
match goal with |- context [_ / 2 + ?zz] =>
     change zz with (2^(ms'-1) * (es-1))
end.
unfold Bits.b32_of_bits, Bits.bits_of_b32.
unfold Bits.binary_float_of_bits.
change 23 with ms'.
match goal with |- context [Bits.bits_of_binary_float _ ?y] =>
  change y with (Z.log2 es + 1)
end.
rewrite B2R_FF2B.
unfold Bits.bits_of_binary_float.
set (ebits := Z.log2 es).
destruct x; inversion H; clear H.
rename e0 into H1.
destruct s; inversion H0; clear H0.
set (x := (B754_finite _ _ _ _ _ _)).
destruct (Z.leb_spec 0 (Z.pos m - 2 ^ ms')).
{
set (e' := (e - (3 - 2 ^ (ebits + 1 - 1) - (ms' + 1)) + 1)).
unfold Bits.join_bits.
rewrite Z.shiftl_mul_pow2 by (compute; congruence).
change (2^ms') with (2^(ms'-1)*2) at 1.
rewrite Z.mul_assoc.
rewrite Z.div_add_l by lia.
rewrite (Z.add_comm (_ * _ ^ _)).
rewrite <- Z.add_assoc.
rewrite (Z.mul_comm (_ ^ _)).
rewrite <- Z.mul_add_distr_r.
rewrite Z.add_0_l.
subst e'.
rewrite <- Z.sub_sub_distr.
rewrite <- Z.sub_sub_distr.
rewrite <- (Z.add_opp_r e).
rewrite (Z.add_simpl_r ebits 1).
replace (- (3 - 2 ^ ebits - (ms' + 1) - 1 - (es - 1)))
  with ( 2 ^ ebits + ms' + (es - 2))
  by lia.
rewrite <- Z.div_add by lia.
rewrite <- Z.mul_assoc.
rewrite <- Z.sub_sub_distr.
rewrite <- (Z.mul_1_l (_ ^ _)) at 1.
rewrite <- Z.mul_sub_distr_r.
replace (1 - (e + (2 ^ ebits + ms' + (es - 2))))
     with (-(e+(2^ebits + ms' + es - 3))) by lia.
rewrite Z.mul_opp_l, Z.sub_opp_r.
rewrite Z.mul_assoc.
rewrite Z.div_add by lia.
admit.
}
{
admit.
}
Admitted.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj18eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (mult lv0 lv1) (mult lv0 lv1)).
Admitted.
QuickChick conj18eqsynthconj5.


From cbpv Require Export fundamental.
From iris.proofmode Require Import tactics.
From iris.program_logic Require Import adequacy.

Lemma wp_soundness `{irisG stlc_lang Σ} e τ : [] ⊢ₜ e : τ → ⊢ WP e {{ ⟦ τ ⟧ }}.
Proof.
  iIntros (?).
  replace e with e.[env_subst[]] by by asimpl.
  iApply fundamental; eauto. iApply interp_env_nil.
Qed.

Theorem soundness e τ e' thp :
  [] ⊢ₜ e : τ → rtc erased_step ([e], ()) (thp, ()) → e' ∈ thp → not_stuck e' ().
Proof.
  set (Σ := invΣ). intros.
  cut (adequate NotStuck e () (λ _ _, True));
    first by intros [_ Hsafe]; eapply Hsafe; eauto.
  eapply (wp_adequacy Σ _). iIntros (Hinv ?).
  iModIntro. iExists (λ _ _, True%I), (λ _, True%I). iSplit=>//.
  set (HΣ := IrisG _ _ Hinv (λ _ _ _ _, True)%I (λ _, True)%I).
  iApply (wp_wand with "[]"). by iApply wp_soundness. eauto.
Qed.


Require Import Pip_state Lib.

Require Import ProofIrrelevance  Coq.Program.Equality Arith List Omega.
Import List.ListNotations.

(** Internals *)

Definition readPhysicalInternal p i memory :option page :=
match (lookup p i memory beqPage beqIndex) with
                            | Some (PP a) => Some a
                            | _ => None
                       end.

Definition readVirtualInternal p i memory : option vaddr:=
  match (lookup p i memory beqPage beqIndex) with
  | Some (VA a) => Some a
  | _ => None
  end.

Definition succIndexInternal (idx:index) : option index :=
let (i,_):=idx in
  if lt_dec i tableSize
  then Some (CIndex (i+1))
  else None.

Definition writeVirtualInternal (p:page) (i:index) (v:vaddr) :=
fun s => {| currentPartition := s.(currentPartition);
  memory :=   add p i (VA v)  s.(memory) beqPage beqIndex|}.

Module Index.
Definition geb (a b : index) : bool := b <=? a.
Definition leb (a b : index) : bool := a <=? b.
Definition ltb (a b : index) : bool := a <? b.
Definition gtb (a b : index) : bool := b <? a.
Definition eqb (a b : index) : bool := a =? b.
End Index.

Module Page.
Definition eqb (p1 : page)  (p2 : page) : bool := (p1 =? p2).
End Page.

Module Level.
Definition gtb (a b : level) : bool := b <? a .
Definition eqb (a b : level) : bool:= a =? b.
Program Definition pred (n : level) : option level :=
if gt_dec n 0 then
let ipred := n-1 in
Some (Build_level ipred _ )
else  None.
Next Obligation.
destruct n.
simpl.
omega.
Qed.
End Level.

Module VAddr.
Definition eqbList(vaddr1 : vaddr) (vaddr2 : vaddr) : bool :=
 beqVAddr vaddr1 vaddr2.
End VAddr.

(** For conditions *)

(** The [getCurPartition] function returns the current partition descriptor of a given state *)
Definition getCurPartition s :page:=
currentPartition s.

(** The [getMaxIndex] function returns the last position into a page table *)
Definition getMaxIndex : option index:=
match gt_dec tableSize 0 with
| left x =>
    Some (CIndex (tableSize-1))
| right _ => None
end.

(** The [readPhysical] function returns the physical page stored into a given
    page at a given position in physical memory. The table should contain only Physical pages
    (The type [PP] is already defined into [Model.ADT]) *)
Definition readPhysical (paddr : page) (idx : index) memory: option page :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PP a) => Some a
  | _ => None
 end.

(**  The [getPd] function returns the physical page of the page directory of
     a given partition  *)
Definition getPd partition memory: option page:=
match succIndexInternal PDidx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(**  The [getFstShadow] returns the physical page of the first shadow page of
     a given partition  *)
Definition getFstShadow partition memory: option page:=
match succIndexInternal sh1idx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(**  The [getSndShadow] returns the physical page of the second shadow page  of
     a given partition *)
Definition getSndShadow partition memory: option page:=
match succIndexInternal sh2idx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(**  The [getConfigTablesLinkedList] returns the physical address of the indirection tables
 reverse translation of a given partition  *)
Definition getConfigTablesLinkedList partition memory: option page:=
match succIndexInternal sh3idx with
|None => None
|Some idx => readPhysical partition idx memory
end.

(** The [readPDflag] function returns the flag value stored into a given table
    at a given position in memory. The table should contain only virtual entries
    (The type [VE] is already defined in [Model.ADT])  *)
Definition readPDflag  (paddr : page) (idx : index) memory : option bool:=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (VE a) => Some a.(pd)
  | Some _ => None
  | None => None
 end.

(** The [getNbLevel] function returns the number of translation levels of the MMU *)
Definition getNbLevel : option level:=
if gt_dec nbLevel 0
then Some (CLevel (nbLevel-1))
else None.

(** The [readPresent] function returns the flag value stored into a given table
    at a given position in memory. The table should contain only Physical entries *)
Definition readPresent  (paddr : page) (idx : index) memory : option bool:=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PE a) => Some a.(present)
  | Some _ => None
  | None => None
 end.

(** The [readAccessible] function returns the flag value stored into a given table
    at a given position in memory. The table should contain only Physical entries  *)
Definition readAccessible  (paddr : page) (idx : index) memory : option bool:=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PE a) => Some a.(user)
  | Some _ => None
  | None => None
 end.

Definition getIndexOfAddr (va : vaddr) (l : level) : index:=
nth ((length va) - (l + 2))  va defaultIndex .

(** The [checkVAddrsEqualityWOOffset] function compares two given virtual addresses
    without taking into account the last index *)
Fixpoint checkVAddrsEqualityWOOffset (timeout : nat) (va1 va2 : vaddr) (l : level) :=
match timeout with
|0 => true
|S timeout1 =>
let idx1 := getIndexOfAddr va1 l in
 let idx2 := getIndexOfAddr va2 l in
if Level.eqb l fstLevel
then
      (idx1 =? idx2)
    else
      match Level.pred l with
      | Some levelpred =>  if idx1 =? idx2
                              then checkVAddrsEqualityWOOffset timeout1 va1 va2 levelpred
                              else false
      | _ => true
      end
end.

(** The [readPhyEntry] function returns the physical page stored into a given table
    at a given position in memory. The table should contain only Physical entries *)
Definition readPhyEntry(paddr : page) (idx : index) memory: option page :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (PE a) => Some a.(pa)
  | Some _ => None
  | None => None
 end.

(** The [readIndex] function returns the index stored into a given table
    at a given position in memory. The table should contain only indices  *)
Definition readIndex  (paddr : page) (idx : index) memory : option index :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (I indexValue) => Some indexValue
  | Some _ => None
  | None => None
 end.

 (** The [readVirtual] function returns the virtual address strored into a given table
    at a given position in memory. The table should contain a virtual address at this position *)
Definition readVirtual (paddr : page) (idx : index) memory : option vaddr :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (VA addr) => Some addr
  | Some _ => None
  | None => None
 end.

(** The [readVirEntry] function returns the virtual address strored into a given table
    at a given position in memory. The table should contain a VEntry at this position *)
Definition readVirEntry (paddr : page) (idx : index) memory : option vaddr :=
let entry :=  lookup paddr idx memory beqPage beqIndex  in
  match entry with
  | Some (VE addr) => Some (vad addr)
  | Some _ => None
  | None => None
 end.

(** The [getDefaultPage] function returns the value of the default page *)
Definition getDefaultPage := defaultPage.

(** The [getIndirection] function returns the configuration table entry that corresponds
    to the given level and virtual address *)
Fixpoint  getIndirection (pd : page) (va : vaddr) (currentlevel : level) (stop : nat) s :=
match stop with
|0 => Some pd
|S stop1 =>
if (Level.eqb currentlevel fstLevel)
then Some pd
  else
    let idx :=  getIndexOfAddr va currentlevel in
       match readPhyEntry pd idx s.(memory) with
       | Some addr =>  if  defaultPage =? addr
                          then Some defaultPage
                          else
                            match Level.pred currentlevel with
                            |Some p =>  getIndirection addr va p stop1 s
                            |None => None
                            end
      |None => None
    end
   end.

(** The [getMappedPage] function returns the physical page stored into a leaf node,
   which corresponds to a given virtual address, if the present flag is equal to true **)
Definition getMappedPage pd s va: option page :=
match getNbLevel  with
 |None => None
 |Some level => let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection pd va level (nbLevel - 1) s with
                | Some tbl =>  if defaultPage =? tbl
                                   then None
                                   else match (readPresent tbl idxVA s.(memory)) with
                                         |Some true => readPhyEntry tbl idxVA s.(memory)
                                         | _ =>  None
                                        end
                | _ => None
               end
end.

(** The [getVirtualAddressSh2] function returns the virtual address stored into the
    second shadow structure which corresponds to a given virtual address **)
Definition getVirtualAddressSh2 sh2 s va: option vaddr :=
match getNbLevel  with
 |None => None
 |Some level => let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection sh2 va level (nbLevel - 1) s with
                | Some tbl =>  if defaultPage =? tbl
                                   then None
                                   else readVirtual tbl idxVA s.(memory)
                | _ => None
               end
end.

(** The [getVirtualAddressSh2] function returns the virtual address stored into the
    parent **)
Definition getVAInParent partition s va: option vaddr :=
match getSndShadow partition (memory s) with
|Some sh2 => match getVirtualAddressSh2 sh2 s va with
             | Some vainparent =>  if (VAddr.eqbList defaultVAddr vainparent)
                                     then None
                                     else Some vainparent
             | _ => None
             end
| _ => None
end.

(** The [getVirtualAddressSh1] function returns the virtual address stored into the first
   shadow structure which corresponds to a given virtual address **)
Definition getVirtualAddressSh1 sh1 s va: option vaddr :=
match getNbLevel  with
 |None => None
 |Some level => let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection sh1 va level (nbLevel - 1) s with
                | Some tbl =>  if defaultPage =? tbl
                                   then None
                                   else readVirEntry tbl idxVA s.(memory)
                | _ => None
               end
end.

(** The [getAccessibleMappedPage] function returns the physical page stored into a leaf node,
   which corresponds to a given virtual address, if the present and user flags are equal to true **)
Definition getAccessibleMappedPage pd s va: option page :=
match getNbLevel  with
 |None => None
 |Some level =>let idxVA := getIndexOfAddr va fstLevel  in
               match getIndirection pd va level (nbLevel - 1) s with
                | Some tbl => if defaultPage =? tbl
                                   then None
                                   else  match (readPresent tbl idxVA s.(memory)),
                                                   (readAccessible tbl idxVA s.(memory)) with
                                           |Some true, Some true => readPhyEntry tbl idxVA s.(memory)
                                           | _, _ =>  None
                                          end
                | _ => None
               end
end.

(** The [geTrdShadows] returns physical pages used to keep informations about
    configuration pages
*)
Fixpoint getTrdShadows (sh3 : page) s bound :=
match bound with
|0 => []
|S bound1 => match getMaxIndex with
            |None => []
            |Some maxindex =>  match readPhysical sh3 maxindex s.(memory) with
                                |None => [sh3]
                                |Some addr => if addr =? defaultPage then [sh3] else sh3 :: getTrdShadows addr s bound1
                               end
           end
end.

(** The [checkChild] function returns true if the given virtual address corresponds
    to a child of the given partition
    *)
Definition checkChild partition level (s:state) va : bool :=
let idxVA :=  getIndexOfAddr va fstLevel in
match getFstShadow partition s.(memory)  with
| Some sh1  =>
   match getIndirection sh1 va level (nbLevel -1) s with
    |Some tbl => if tbl =? defaultPage
                    then false
                    else match readPDflag tbl idxVA s.(memory) with
                          |Some true => true
                          |_ => false
                          end
    |None => false
    end
| _ => false
end.

(** The [getTablePages] function returns the list of physical pages stored into
    a given configuration table from a given index *)
Fixpoint getTablePages (table : page ) (idx : nat) s : list page :=
match idx with
| 0 => []
|S idx1 => match  lookup table (CIndex idx1) s.(memory) beqPage beqIndex  with
              | Some (PE entry) => if (pa entry =? defaultPage ) then getTablePages table idx1 s
                                      else getTablePages table idx1 s ++ [pa entry]
              | _ => getTablePages table idx1 s
            end
end.

Fixpoint getIndirectionsAux (pa : page) (s : state) level {struct level} : list page :=
  match level with
    | O => []
    | S level1 => pa :: flat_map (fun p => getIndirectionsAux p s level1)
                                    (getTablePages pa tableSize s)
  end.

(** The [getIndirectionsAux] function returns the list of physical pages
    used into a configuration tables tree *)
Definition getIndirections pd s : list page :=
  getIndirectionsAux pd s nbLevel.

Fixpoint getAllIndicesAux (pos count: nat) : list index :=
  match count with
    | 0        => []
    | S count1 => match lt_dec pos tableSize with
                   | left pf => Build_index pos pf :: getAllIndicesAux (S pos) count1
                   | _       => []
                 end
  end.

(** The [getAllIndicesAux] function returns the list of all indices  *)
Definition getAllIndices := getAllIndicesAux 0 tableSize.

Fixpoint getAllVAddrAux (levels: nat) : list (list index) :=
  match levels with
    | 0         => [[]]
    | S levels1 => let alls := getAllVAddrAux levels1 in
                  flat_map (fun (idx : index) => map (cons idx) alls) getAllIndices
  end.

(** The [getAllVAddr] function returns the list of all virtual addresses *)
Definition getAllVAddr := map CVaddr (getAllVAddrAux (S nbLevel)).

(** The [getPdsVAddr] function returns the list of virtual addresses used as
    partition descriptor into a given partition *)
Definition getPdsVAddr partition l1 (vaList : list vaddr) s :=
filter (checkChild partition l1 s) vaList.

(** The [getMappedPagesOption] function Return all physical pages marked as
    present into a partition *)
Definition getMappedPagesOption (pd : page) (vaList : list vaddr) s : list (option page) :=
map (getMappedPage pd s) vaList.

(** The [getAccessibleMappedPagesOption] function Return all physical pages
    marked as present and accessible into a partition *)
Definition getAccessibleMappedPagesOption (pd : page) (vaList : list vaddr) s : list (option page) :=
map (getAccessibleMappedPage pd s) vaList.

(** The [filterOption] function Remove option type from list *)
Fixpoint filterOption (l : list (option page)) :=
match l with
| [] => []
| Some a :: l1 => a:: filterOption l1
|None :: l1 => filterOption l1
end.

(** The [getMappedPagesAux] function removes option type from mapped pages list *)
Definition getMappedPagesAux (pd :page)  (vaList : list vaddr) s : list page :=
filterOption (getMappedPagesOption pd vaList s).

(** The [getAccessibleMappedPagesAux] function removes option type from
    accessible mapped pages list *)
Definition getAccessibleMappedPagesAux (pd :page)  (vaList : list vaddr) s : list page :=
filterOption (getAccessibleMappedPagesOption pd vaList s).

(** The [getConfigPagesAux] function returns all configuration pages of a
    given partition *)
Definition getConfigPagesAux (partition : page) (s : state) : list page :=
let vaList := getAllVAddr in
match getPd partition s.(memory),
      getFstShadow partition s.(memory),
      getSndShadow partition s.(memory),
      getConfigTablesLinkedList partition s.(memory)  with
| Some pd , Some sh1, Some sh2 , Some sh3  => (getIndirections pd s)++
                         (getIndirections sh1 s)++
                         (getIndirections sh2 s )++
                         (getTrdShadows sh3 s (nbPage+1))
|_,_,_,_ => []
end.

Definition getConfigPages (partition : page) (s : state) :=
partition :: (getConfigPagesAux partition s).

(** The [getMappedPages] function Returns all present pages of a given partition *)
Definition getMappedPages (partition : page) s : list page :=
  match getPd partition s.(memory) with
    |None => []
    |Some pd => let vaList := getAllVAddr in getMappedPagesAux pd vaList s
  end.

(** The [getAccessibleMappedPages] function Returns all present and
    accessible pages of a given partition *)
Definition getAccessibleMappedPages (partition : page) s : list page :=
  match getPd partition s.(memory) with
    |None => []
    |Some pd => let vaList := getAllVAddr in getAccessibleMappedPagesAux pd vaList s
  end.

(** The [getUsedPages] function Returns all used pages (present and config pages)
    of a given partition including the partition descriptor itself *)
Definition getUsedPages (partition: page) s : list page :=
  getConfigPages partition s ++ getMappedPages partition s.

Lemma  eqPageDec : forall n m : page, {n = m} + {n <> m}.
Proof.
intros.
destruct n. destruct m.
assert ({p = p0} + {p <> p0}).
apply eq_nat_dec.
destruct H.
left.
subst.
assert(Hp = Hp0) by apply proof_irrelevance.
subst.
trivial.
right.
unfold not in *.
intros. apply n.
clear n.
inversion H. trivial.
Qed.

(** The [getChildren] function Returns all children of a given partition *)
Definition getChildren (partition : page) s :=
let vaList := getAllVAddr in
match getNbLevel, getPd partition s.(memory) with
|Some l1,Some pd => getMappedPagesAux pd (getPdsVAddr partition l1 vaList s) s
|_, _ => []
end.

(** The [getPartitionsAux] function returns all pages marked as descriptor partition *)
Fixpoint getPartitionAux (partitionRoot : page) (s : state) bound {struct bound} : list page :=
  match bound with
    | O => []
    | S bound1 => partitionRoot :: flat_map (fun p => getPartitionAux p s bound1)
                                    (getChildren partitionRoot s )
  end.

(** The [getPartitions] function fixes the sufficient timeout value to retrieve all partitions *)
Definition getPartitions (root : page) s : list page  :=
(getPartitionAux root s (nbPage+1)).

(** The [getParent] function returns the parent partition descriptor of a given partition *)
Definition getParent partition memory :=
match succIndexInternal PPRidx with
| Some idx =>  readPhysical partition idx memory
| _ => None
end.

(** The [getAncestorsAux] function returns the ancestors list of a given partition *)
Fixpoint getAncestorsAux (partition : page) memory depth : list page :=
match depth with
|0 => []
| S depth1 => match getParent partition memory with
               | Some parent => parent :: getAncestorsAux parent memory depth1
               | _ => []
              end
end.

(** The [getAncestors] function fixes the sufficient timeout value to retrieve all ancestors *)
Definition getAncestors (partition : page) s :=
getAncestorsAux partition s.(memory) (nbPage+1).

(** Propositions *)
(** The [isPE] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PE] *)
Definition isPE table idx s: Prop :=
match lookup table idx s.(memory) beqPage beqIndex with
             |Some (PE _) => True
             |_ => False
end.

(** The [isVE] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [VE] *)
Definition isVE table idx s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (VE _) => True
             |_ => False
end.

(** The [isVA] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [VA] *)
Definition isVA table idx s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (VA _) => True
             |_ => False
end.

(** The [isPP] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PE] *)
Definition isPP table idx s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (PP _) => True
             |_ => False
end.

(** The [isPP'] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PP] and physical page stored into this entry
    is equal to a given physical page [pg]*)
Definition isPP' table idx pg s: Prop :=
 match lookup table idx s.(memory) beqPage beqIndex with
             |Some (PP p) => p = pg
             |_ => False
end.

(** The [nextEntryIsPP] proposition reutrns True if the entry at position [idx+1]
    into the given physical page [table] is type of [PP] and physical page stored into
    this entry is equal to a given physical page [pg] *)
Definition nextEntryIsPP table idxroot tableroot s : Prop:=
match succIndexInternal idxroot with
| Some idxsucc => match lookup table idxsucc (memory s) beqPage beqIndex with
                  | Some (PP table) => tableroot = table
                  |_ => False
                  end
| _ => False
end.

(** The [entryPresentFlag] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [PP] and the present flag stored into
    this entry is equal to a given flag [flag] *)
Definition entryPresentFlag table idx flag s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (PE entry) => flag =  entry.(present)
| _ => False
end.

(** The [entryPDFlag]  proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the pd flag stored into
    this entry is equal to a given flag [flag] *)
Definition entryPDFlag table idx flag s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (VE entry) => flag =  entry.(pd)
| _ => False
end.

(** The [entryUserFlag] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the user flag stored into
    this entry is equal to a given flag [flag] *)
Definition entryUserFlag table idx flag s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (PE entry) => flag =  entry.(user)
| _ => False
end.

(** The [VEDerivation] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the given boolean value
    [res] specifies if the virtual address stored into
    this entry is equal or not to the default virtual address *)
Definition VEDerivation table idx (res : bool) s:=
match lookup table idx s.(memory) beqPage beqIndex with
| Some (VE entry) => ~ (beqVAddr entry.(vad) defaultVAddr) = res
| _ => False
end.

(** The [isEntryVA] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VE] and the virtual address
    stored into this entry is equal to a given virtual address [v1] *)
Definition isEntryVA table idx v1 s:=
 match lookup table idx (memory s) beqPage beqIndex with
 | Some (VE entry)  => entry.(vad) = v1
 | _ => False
 end.

(** The [isVA'] proposition reutrns True if the entry at position [idx]
    into the given physical page [table] is type of [VA] and the virtual address
    stored into this entry is equal to a given virtual address [v1] *)
Definition isVA' table idx v1 s:=
 match lookup table idx (memory s) beqPage beqIndex with
 | Some (VA entry)  => entry = v1
 | _ => False
 end.

(** The [isEntryPage] proposition reutrns True if the entry at position [idx]
    into the given page [table] is type of [PE] and physical page stored into this entry
    is equal to a given physical page [page1]*)
Definition isEntryPage table idx page1 s:=
 match lookup table idx (memory s) beqPage beqIndex with
 | Some (PE entry)  => entry.(pa) = page1
 | _ => False
 end.

(** The [getTableAddrRoot'] proposition returns True if the given physical page [table]
is a configuration table into different structures (pd, shadow1 or shadow2). This table should be associated to the
given virtual address [va]  *)
Definition getTableAddrRoot' (table : page) (idxroot : index)
(currentPart : page) (va : vaddr) (s : state) : Prop :=
(idxroot = PDidx \/ idxroot = sh1idx \/ idxroot = sh2idx) /\
(forall tableroot : page,
 nextEntryIsPP currentPart idxroot tableroot s ->
 exists nbL : level,
   Some nbL = getNbLevel /\
   (exists stop : nat, stop > 0 /\ stop <= nbL /\ getIndirection tableroot va nbL stop s = Some table)).

(** The [getTableAddrRoot] proposition returns True if the given physical page [table]
is the last page table into a structure (pd, shadow1 or shadow2) that corresponds to a given virtual address [va] *)
Definition getTableAddrRoot table idxroot currentPart va s : Prop :=
(idxroot = PDidx \/ idxroot = sh1idx \/ idxroot = sh2idx)/\
   forall (tableroot : page), nextEntryIsPP  currentPart idxroot tableroot s ->
   exists nbL, Some nbL = getNbLevel  /\ exists (stop :nat) , stop = nbL+1  /\
    getIndirection tableroot va nbL stop s = Some table .

(** The [getAllPages] returns the list of all physical pages *)
Definition getAllPages: list page:=
map CPage (seq 0 nbPage ).

(** The [getPDFlag] checks if the given virtual address corresponds to a partition
    descriptor **)
Definition getPDFlag sh1 va s :=
let idxVA := getIndexOfAddr va fstLevel in
match getNbLevel with
|Some nbL =>  match getIndirection sh1 va nbL (nbLevel - 1) s with
  | Some tbl =>
      if tbl =? defaultPage
      then false
      else
       match readPDflag tbl idxVA (memory s) with
       | Some true => true
       | Some false => false
       | None => false
       end
  | None => false
  end
| None => false
end.

(** The [isAccessibleMappedPageInParent] function returns true if the given physical
    page is accessible in the parent of the given partition **)
Definition isAccessibleMappedPageInParent partition va accessiblePage s  :=
match getSndShadow partition (memory s) with
| Some sh2 =>
  match  getVirtualAddressSh2 sh2 s va  with
   | Some vaInParent =>
     match getParent partition (memory s) with
      | Some parent =>
        match getPd parent (memory s) with
         | Some pdParent =>
           match getAccessibleMappedPage pdParent s vaInParent with
            | Some sameAccessiblePage => accessiblePage =? sameAccessiblePage
            | None => false
           end
         | None => false
        end
    | None => false
           end
| None => false
           end
| None => false
end.

(** The [isPartitionFalse] returns true if the partition descriptor flag of a given
     entry is equal to false or there is no data stored into this entry **)
Definition isPartitionFalse ptPDChildSh1 idxPDChild s :=
readPDflag ptPDChildSh1 idxPDChild (memory s) = Some false \/
readPDflag ptPDChildSh1 idxPDChild (memory s) = None.

(** The [isAncestor] funtion returns true if the given partitions are equal
    or the descParent partition is an ancestor of currentPart **)
Definition isAncestor  currentPart descParent s :=
( currentPart = descParent \/ In descParent (getAncestors currentPart s)).

Definition isWellFormedFstShadow nbL table  s:=
(nbL <> fstLevel /\
(forall idx, readPhyEntry table  idx s.(memory) = Some defaultPage /\
readPresent table idx (memory s) = Some false )) \/
(nbL = fstLevel /\
( forall idx : index,
(readVirEntry table idx (memory s) = Some defaultVAddr) /\
readPDflag table idx (memory s) = Some false) ).

Definition isWellFormedSndShadow nbL table  s:=
(nbL <> fstLevel /\ (
forall idx, readPhyEntry table  idx s.(memory) = Some defaultPage /\
readPresent table idx (memory s) = Some false )) \/
(nbL = fstLevel /\ ( forall idx : index,
(readVirtual table idx (memory s) = Some defaultVAddr) ) ).

(** The [isDerived] funtion returns true if a physical page is derived
    into the given partition , this physical page is associated to the given
    virtual address [va] **)
Definition isDerived partition va  s  :=
match getFstShadow partition (memory s) with
| Some sh1 =>
  match  getVirtualAddressSh1 sh1 s va  with
   | Some va0 => beqVAddr defaultVAddr va0 = false
   | _ => False
  end
| None => False
end.

Lemma  pageDec :
forall x y : page, {x = y} + {x <> y}.
Proof.
intros.
destruct x; destruct y.
assert({p = p0} + {p <> p0}).
apply Nat.eq_dec.
destruct H.
left.
subst.
f_equal.
apply proof_irrelevance.
right.
contradict n.
inversion n.
subst;trivial.
Qed.

Fixpoint closestAncestorAux part1 part2 s bound : option page :=
match bound  with
| 0 => None
| S bound1 => match getParent part1 (memory s) with
              | Some parent => match in_dec pageDec part2
                                    (getPartitionAux parent s (nbPage+1)) with
                               | left _  => Some parent
                               | _ =>  closestAncestorAux parent part2 s bound1
                               end
              | None =>  Some multiplexer
              end
end.

Definition closestAncestor part1 part2 s :=
closestAncestorAux part1 part2 s (nbPage+1).

Ltac symmetrynot :=
match goal with
| [ |- ?x <> ?y ] => unfold not ; let Hk := fresh in intro Hk ; symmetry in Hk ;contradict Hk
end.