Require Import JaSyntax.
Require Import String.
Require Import Lists.List.
Import ListNotations.
Open Scope list_scope.
Require Import NPeano.
Require Import PeanoNat.
Require Export Arith.
Open Scope nat_scope.
Require Import JaTactics.

From Hammer Require Import Reconstr.

(* Require Import Arith_base.
Require Import BinPos.
Require Import BinInt.
Require Import Zorder. *)

(** The boolean function that returns [true] when [cname] is the name of the class declared as [cdecl]. *)
Definition is_class_name cn cd :=
  match cd with
    | JFCDecl dn _ _ _ => if JFClassName_dec dn cn then true else false
  end.

Lemma is_class_name_name:
  forall cn ex fields methods,
    is_class_name cn (JFCDecl cn ex fields methods) = true.
Proof.
  intros.
  unfold is_class_name.
  destruct (JFClassName_dec cn cn).
  auto.
  tauto.
Qed.

Lemma is_class_name_name_cd:
  forall cd,
    is_class_name (name_of_cd cd) cd = true.
Proof.
  intros.
  destruct cd.
  unfold name_of_cd.
  unfold is_class_name.
  destruct (JFClassName_dec cn cn); try contradiction;auto.
Qed.

Lemma is_class_name_neq:
  forall cn dn ex fields methods,
    cn<>dn ->
    is_class_name cn (JFCDecl dn ex fields methods) = false.
Proof.
  intros.
  unfold is_class_name.
  destruct (JFClassName_dec dn cn).
  auto.
  rewrite e in *.
  tauto.
  auto.
Qed.

Lemma is_class_name_equal:
  forall cn dn ex fields methods,
    is_class_name cn (JFCDecl dn ex fields methods) = true ->
    cn = dn.
Proof.
  intros.
  unfold is_class_name in H.
  destruct (JFClassName_dec dn cn).
  auto.
  discriminate H.
Qed.

Lemma is_class_name_nequal:
  forall cn dn ex fields methods,
    is_class_name cn (JFCDecl dn ex fields methods) = false ->
    cn <> dn.
Proof.
  intros.
  unfold is_class_name in H.
  destruct (JFClassName_dec dn cn).
  discriminate H.
  auto.
Qed.

Lemma program_contains_counts_occ:
  forall CC cn,
    program_contains CC cn = true ->
    (count_occ Bool.bool_dec (map (is_class_name cn) CC) true > 0)%nat.
Proof.
  induction CC.
  * intros.
    simpl in H.
    discriminate H.
  * intros.
    destruct a.
    destruct (JFClassName_dec cn0 cn).
    ** subst.
       rewrite map_cons.
       unfold is_class_name.
       destruct (JFClassName_dec cn cn); try contradiction.
       rewrite count_occ_cons_eq; auto.
       auto with zarith.
    ** rewrite map_cons.
       unfold is_class_name.
       destruct (JFClassName_dec cn0 cn); subst; try contradiction.
       rewrite count_occ_cons_neq; auto.
       fold (is_class_name cn0).
       apply IHCC;eauto 2.
       eapply program_contains_further_neq;eauto.
Qed.

(** The property to check that class name [cname] occurs only once in the program [P]. *)
Definition name_once (CC:JFProgram) (cn:JFClassName) :=
 count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 1%nat.

Lemma in_head_not_in_tail:
  forall (CC:JFProgram) (cn:JFClassName) (cd:JFClassDeclaration),
    (is_class_name cn cd) = true ->
    name_once (cd :: CC) cn -> ~ name_once CC cn.
Proof.
  induction CC.
  * intros.
    compute.
    intro.
    discriminate H1.
  * intros.
    unfold name_once in H0.
    rewrite map_cons in H0.
    rewrite H in H0.
    rewrite count_occ_cons_eq in H0.
    set (XX := (count_occ Bool.bool_dec (map (is_class_name cn) (a :: CC)) true)) in H0.
    injection H0.
    intros.
    unfold XX in *.
    intro.
    unfold name_once in H2.
    rewrite H1 in H2.
    discriminate H2.
    auto.
Qed.

Lemma name_once_further:
  forall cn dn CC ex fields methods,
  cn<>dn ->
  name_once (JFCDecl cn ex fields methods :: CC) dn -> name_once CC dn.
Proof.
  intros.
  unfold name_once in H0.
  rewrite map_cons in H0.
  rewrite is_class_name_neq in H0.
  rewrite count_occ_cons_neq in H0.
  auto.
  auto.
  auto.
Qed.

Lemma name_once_further_neq:
  forall cn dn CC ex ms fs,
    cn <> dn ->
    name_once CC dn ->
    name_once (JFCDecl cn ex ms fs :: CC) dn.
Proof.
  intros.
  unfold name_once in *.
  rewrite map_cons.
  rewrite is_class_name_neq; auto.
Qed.

Lemma name_once_further_eq:
  forall cn CC ex fields methods,
    count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0%nat ->
    name_once (JFCDecl cn ex fields methods :: CC) cn.
Proof.
  unfold name_once.
  intros.
  rewrite map_cons.
  rewrite is_class_name_name.
  rewrite count_occ_cons_eq; auto.
Qed.

Lemma count_occ_zero_is_class_name_false:
  forall CC cn cd,
    count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0%nat ->
    In cd CC ->
    is_class_name cn cd = false.
Proof.
  induction CC.
  * intros.
    unfold In in H0.
    tauto.
  * intros.
    apply in_inv in H0.
    destruct H0.
    - rewrite H0 in *.
      rewrite map_cons in H.
      apply <- count_occ_not_In in H.
      apply not_in_cons in H.
      destruct H.
      destruct (is_class_name cn cd).
      + tauto.
      + auto.
    - apply IHCC.
      rewrite map_cons in H.
      assert (is_class_name cn a <> true).
      apply <- count_occ_not_In in H.
      apply not_in_cons in H.
      intuition.
      rewrite <- (count_occ_cons_neq  Bool.bool_dec (map (is_class_name cn) CC) H1).
      auto.
      trivial.
Qed.

(** The property to check that declaraion [cdecl] occurs only once in the program [P]. *)
Definition decl_once (CC:JFProgram) (cd:JFClassDeclaration) :=
  match cd with
    | JFCDecl cn _ _ _ => name_once CC cn
  end.

Lemma count_occ_zero_decl_once:
  forall CC cn ex ms fs ex1 ms1 fs1,
    count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0%nat ->
    decl_once (JFCDecl cn ex ms fs :: CC) (JFCDecl cn ex1 ms1 fs1).
Proof.
  intros.
  unfold decl_once.
  apply name_once_further_eq.
  auto.
Qed.

Lemma decl_in_head_not_in_tail:
  forall (CC:JFProgram) (cn:JFClassName) (cd:JFClassDeclaration),
    (is_class_name cn cd) = true ->
    (decl_once (cd :: CC) cd) ->
    ~ (decl_once CC cd).
Proof.
  intros.
  unfold decl_once in *.
  destruct cd.
  unfold is_class_name in H.
  destruct (JFClassName_dec cn0 cn).
  rewrite e in *.
  apply (in_head_not_in_tail CC cn (JFCDecl cn ex fields methods)).
  apply is_class_name_name.
  auto.
  discriminate H.
Qed.

Lemma decl_in_head_false_in_tail:
  forall (CC:JFProgram) (cn:JFClassName) (cd:JFClassDeclaration),
    (is_class_name cn cd) = true ->
    (decl_once (cd :: CC) cd) ->
    Forall (fun x0 => is_class_name cn x0 = false) CC.
Proof.
  intros.
  unfold decl_once in *.
  destruct cd.
  apply is_class_name_equal in H.
  rewrite H in *.
  unfold name_once in H0.
  rewrite map_cons in H0.
  rewrite is_class_name_name in H0.
  rewrite count_occ_cons_eq in H0; auto.
  injection H0; intros.
  apply Forall_forall.
  intros.
  eapply count_occ_zero_is_class_name_false; try apply H1; auto.
Qed.

Lemma decs_once_monotone:
  forall (CC:JFProgram) (cd:JFClassDeclaration)
         (dd:JFClassDeclaration) (cn:JFClassName),
    decl_once (cd :: CC) dd ->
    is_class_name cn cd = true ->
    is_class_name cn dd = false ->
    decl_once CC dd.
Proof.
  intros.
  unfold decl_once.
  destruct dd.
  unfold decl_once in H.
  destruct cd.
  apply is_class_name_equal in H0.
  rewrite H0 in *.
  eapply name_once_further.
  apply is_class_name_nequal in H1.
  eapply H1.
  apply H.
Qed.

(** The property that all class names occur in the program uniquely. *)
Definition names_unique (CC:JFProgram) :=
  Forall (decl_once CC) CC.

Lemma names_unique_zero:
  forall CC cn ex fields methods,
    names_unique (JFCDecl cn ex fields methods :: CC) ->
    count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0%nat.
Proof.
  intros.
  unfold names_unique in H.
  apply Forall_inv in H.
  unfold decl_once in H.
  unfold name_once in H.
  rewrite map_cons in H.
  rewrite is_class_name_name in H.
  rewrite count_occ_cons_eq in H; auto.
Qed.

Lemma names_unique_cons:
  forall CC cn ex ms fs,
    count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0%nat ->
    names_unique CC ->
    names_unique (JFCDecl cn ex ms fs :: CC).
Proof.
  intros.
  unfold names_unique.
  apply Forall_cons.
  + apply count_occ_zero_decl_once.
    auto.
  + apply Forall_forall.
    intros.
    unfold names_unique in H0.
    assert (forall y, In y CC -> (decl_once CC) y).
    apply (Forall_forall (decl_once CC) CC).
    auto.
    destruct x.
    assert (is_class_name cn (JFCDecl cn0 ex0 fields methods) = false). {
      eapply count_occ_zero_is_class_name_false.
      apply H.
      auto.
    }
    apply (is_class_name_nequal) in H3.
    unfold decl_once.
    apply name_once_further_neq; auto.
    assert (decl_once CC (JFCDecl cn0 ex0 fields methods)).
    apply H2; auto.
    unfold decl_once in H4; auto.
Qed.

Lemma names_unique_further:
  forall (CC:JFProgram) (cd:JFClassDeclaration),
    names_unique (cd :: CC) ->
    names_unique CC.
Proof.
  intros.
  unfold names_unique in H.
  inversion H.
  unfold names_unique.
  assert (forall x, In x CC -> (decl_once CC) x).
  intros.
  assert (forall x, In x CC -> (decl_once (cd :: CC)) x).
  apply -> (Forall_forall (decl_once (cd :: CC)) CC).
  auto.
  assert (decl_once (cd :: CC) x0).
  apply H5.
  auto.
  destruct cd.
  apply (decs_once_monotone CC (JFCDecl cn ex fields methods) x0 cn).
  auto.
  unfold is_class_name.
  destruct (JFClassName_dec cn cn).
  auto.
  tauto.
  assert (Forall (fun x0 => is_class_name cn x0 = false) CC).
  apply (decl_in_head_false_in_tail CC cn (JFCDecl cn ex fields methods)).
  unfold is_class_name.
  destruct (JFClassName_dec cn cn);auto.
  auto.
  assert (forall x, In x CC -> (is_class_name cn x = false)).
  apply Forall_forall.
  auto.
  apply H8.
  auto.
  apply Forall_forall.
  auto.
Qed.

Lemma names_unique_decompose_program:
  forall (CC1 CC2:JFProgram),
    names_unique (CC1 ++ CC2) ->
    names_unique CC2.
Proof.
  induction CC1.
  + intros.
    simpl in *.
    auto.
  + intros.
    simpl in H.
    unfold names_unique in H.
    apply IHCC1.
    unfold names_unique.
    assert (forall x, In x (a :: CC1 ++ CC2) -> (decl_once (a :: CC1 ++ CC2)) x)
      by (apply -> Forall_forall;auto).
    apply <- Forall_forall.
    intros.
    destruct (JFClassName_dec (name_of_cd a) (name_of_cd x)).
    ++ subst.
       assert (decl_once (a :: CC1 ++ CC2) a) by eauto using in_eq.
       assert (decl_once (a :: CC1 ++ CC2) x).
       {
         unfold decl_once.
         unfold decl_once in H2.
         destruct x.
         destruct a.
         simpl in e.
         rewrite <- e.
         auto.
       }
       assert (decl_once (x :: CC1 ++ CC2) x).
       {
         unfold decl_once.
         unfold decl_once in H3.
         destruct x.
         destruct a.
         simpl in e.
         rewrite e in H3.
         unfold name_once.
         unfold name_once in H3.
         simpl in H3.
         simpl.
         auto.
       }
       assert (~ decl_once (CC1 ++ CC2) x).
       {
         apply (decl_in_head_not_in_tail (CC1 ++ CC2) (name_of_cd x)).
         apply is_class_name_name_cd; auto.
         auto.
       }
       destruct x.
       assert (In (is_class_name cn (JFCDecl cn ex fields methods))
                  (map (is_class_name cn) (CC1 ++ CC2))) by eauto using in_map.
       assert (count_occ Bool.bool_dec (map (is_class_name cn) (CC1 ++ CC2))
                         (is_class_name cn (JFCDecl cn ex fields methods)) > 0)
         by (apply count_occ_In; eauto).
       unfold decl_once in H4.
       unfold name_once in H4.
       simpl in H4.
       simpl in H7.
       destruct (JFClassName_dec cn cn);try contradiction.
       destruct (Bool.bool_dec true true);try contradiction.
       injection H4;intros.
       rewrite H8 in H7.
       apply gt_irrefl in H7.
       contradiction.
    ++ eapply decs_once_monotone.
       apply H0.
       apply in_cons;auto.
       apply is_class_name_name_cd.
       unfold is_class_name.
       destruct x.
       destruct (JFClassName_dec cn (name_of_cd a)).
       +++ rewrite <-  e in n.
           simpl in n.
           contradiction.
       +++ trivial.
Qed.

Lemma names_unique_further_further:
  forall (CC:JFProgram) (cd dd:JFClassDeclaration),
    names_unique (cd::dd::CC) ->
    names_unique (cd::CC).
Proof.
  intros.
  destruct cd.
  apply  names_unique_cons.
  - apply (names_unique_zero CC cn ex fields methods).
    apply (names_unique_cons).
    assert (count_occ Bool.bool_dec (map (is_class_name cn)
                                         (dd :: CC)) true = 0). {
      apply (names_unique_zero (dd :: CC) cn ex fields methods).
      auto.
    }
    rewrite map_cons in H0.
    destruct (is_class_name cn dd).
    rewrite count_occ_cons_eq in H0; discriminate H0; auto.
    rewrite count_occ_cons_neq in H0; auto.
    eauto using names_unique_further.
  - eauto using names_unique_further.
Qed.

Lemma count_zero_count_nzero:
  forall CC cn ex fields methods,
         count_occ JFClassDeclaration_dec CC
         (JFCDecl cn ex fields methods) > 0 ->
         count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0 ->
         False.
Proof.
  induction CC; intros.
  - rewrite count_occ_nil in H.
    assert (0<>0).
    apply Lt.lt_0_neq.
    auto.
    tauto.
  - destruct a.
    destruct (JFClassName_dec cn0 cn).
    + rewrite e in *.
      rewrite map_cons in H0.
      rewrite is_class_name_name in H0.
      rewrite count_occ_cons_eq in H0.
      discriminate H0.
      auto.
    + rewrite map_cons in H0.
      rewrite is_class_name_neq in H0.
      rewrite count_occ_cons_neq in H0.
      rewrite count_occ_cons_neq in H.
      eauto using IHCC.
      congruence.
      congruence.
      auto.
Qed.

Lemma names_unique_find_class_unique:
  forall CC cn cd cd',
         names_unique CC ->
         find_class CC cn = Some cd ->
         find_class CC cn = Some cd' ->
         cd = cd'.
Proof.
  induction CC.
  + intros.
    simpl in H0.
    discriminate H0.
  + intros.
    destruct a.
    destruct (JFClassName_dec cn cn0).
    ++ subst.
       simpl in H1.
       simpl in H0.
       destruct (JFClassName_dec cn0 cn0); try contradiction.
       rewrite H0 in *.
       injection H1.
       tauto.
    ++ apply find_class_further_neq in H0; auto.
       apply find_class_further_neq in H1; auto.
       eapply IHCC;eauto using names_unique_further.
Qed.

Hint Resolve names_unique_zero names_unique_cons names_unique_further names_unique_further_further names_unique_decompose_program count_zero_count_nzero is_class_name_name is_class_name_name_cd names_unique_find_class_unique.

Lemma in_names_unique_eq:
  forall CC cn ex fields methods ex0 fields0 methods0,
    In (JFCDecl cn ex fields methods)
       (JFCDecl cn ex0 fields0 methods0 :: CC) ->
    names_unique  (JFCDecl cn ex0 fields0 methods0 :: CC) ->
    (ex = ex0 /\ fields = fields0 /\ methods = methods0).
Proof.
  intros.
  simpl in H.
  destruct H.
  - injection H; auto.
  - apply -> (count_occ_In JFClassDeclaration_dec) in H.
    apply names_unique_zero in H0.
    clear -H H0.
    auto with zarith.
    assert False by eauto.
    tauto.
Qed.

Hint Resolve  in_names_unique_eq.

Lemma is_class_and_occ_zero:
  forall CC cn dn cd, names_unique CC ->
            find_class CC cn = Some cd ->
            count_occ Bool.bool_dec (map (is_class_name dn) CC) true = 0 ->
            cn <> dn.
Proof.
  induction CC.
  + sauto.
  + intros.
    destruct a.
    assert ({cn=dn} + {cn<>dn}) by apply JFClassName_dec.
    destruct H2.
    * rewrite e in *.
      rewrite map_cons in H1.
      unfold is_class_name in H1.
      destruct (JFClassName_dec cn0 dn).
      - pose count_occ_cons_eq; scrush.
      - pose count_occ_cons_neq; pose names_unique_further;
          pose find_class_further_neq; scrush.
    * auto.
Qed.

Lemma names_unique_count_class_name:
  forall CC cn ex flds mthds,
    names_unique CC ->
    count_occ Bool.bool_dec (map (is_class_name cn) CC)
              true = 0 ->
    count_occ JFClassDeclaration_dec CC (JFCDecl cn ex flds mthds) = 0.
Proof.
  induction CC.
  - intros; simpl; auto.
  - intros.
    rewrite map_cons in H0.
    destruct (Bool.bool_dec (is_class_name cn a) true).
    + rewrite count_occ_cons_eq in H0; auto.
      discriminate H0.
    + rewrite count_occ_cons_neq.
      eapply IHCC.
      eauto using names_unique_further.
      rewrite count_occ_cons_neq in H0; auto.
      destruct a.
      assert (is_class_name cn (JFCDecl cn0 ex fields methods) = false).
      simpl in n.
      destruct (JFClassName_dec cn0 cn).
      tauto.
      simpl. destruct (JFClassName_dec cn0 cn); tauto.
      apply is_class_name_nequal in H1.
      congruence.
Qed.

Lemma in_find_class_raw:
  forall CC cn ex fields methods,
    In (JFCDecl cn ex fields methods) CC ->
    exists ex1 fields1 methods1,
    find_class CC cn = Some (JFCDecl cn ex1 fields1 methods1).
Proof.
  induction CC.
  * intros.
    inversion H.
  *  intros.
     destruct (JFClassDeclaration_dec (JFCDecl cn ex fields methods) a).
     ** rewrite <- e.
        simpl.
        destruct (JFClassName_dec cn cn); try contradiction.
        clear.
        do 3 eexists.
        auto.
     ** simpl.
        destruct a.
        destruct (JFClassName_dec cn0 cn).
        *** subst.
            clear. do 3 eexists. auto.
        *** eapply IHCC.
            eapply in_inv in H.
            destruct H.
            + injection H;intros;clear H.
              contradiction.
            + eauto.
Qed.

Lemma in_find_class:
  forall CC cn ex fields methods,
    names_unique CC ->
    In (JFCDecl cn ex fields methods) CC ->
    find_class CC cn = Some (JFCDecl cn ex fields methods).
Proof.
  induction CC;intros.
  - assert (~ In (JFCDecl cn ex fields methods) []) by  auto using in_nil.
    tauto.
  - destruct (JFClassDeclaration_dec (JFCDecl cn ex fields methods) a).
    + rewrite <- e. simpl.
      destruct (JFClassName_dec cn cn); eauto.
      tauto.
    + destruct a.
      simpl.
      destruct (JFClassName_dec cn0 cn).
      rewrite e in *.
      assert (ex = ex0 /\ fields = fields0 /\ methods = methods0)
        by eauto.
      decompose [and] H1; clear H1.
      congruence.
      apply in_inv in H0.
      destruct H0.
      injection H0;intros.
      tauto.
      eapply IHCC; eauto.
Qed.

Hint Resolve in_find_class.

Lemma names_unique_in_neq:
  forall CC cn dn ex fields methods ex1 fields1 methods1,
    names_unique (JFCDecl cn ex fields methods :: CC) ->
    In (JFCDecl dn ex1 fields1 methods1) CC ->
    cn <> dn.
Proof.
  intros.
  assert (dn<>cn).
  assert (count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0) by eauto.
  assert (find_class CC dn = Some (JFCDecl dn ex1 fields1 methods1)) by eauto.
  eapply is_class_and_occ_zero.
  eapply names_unique_further; eauto.
  eauto.
  eauto.
  auto.
Qed.

Hint Resolve names_unique_in_neq : myhints.

Lemma names_unique_count_zero:
  forall CC cn ex fields methods,
    names_unique (JFCDecl cn ex fields methods :: CC) ->
    count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0.
Proof.
  scrush.
Qed.

Lemma names_unique_neq_but_in:
  forall CC cd dd,
         In cd (cd :: CC) ->
         dd <> cd ->
         names_unique (cd :: CC) ->
         In dd CC -> name_of_cd dd <> name_of_cd cd.
Proof.
  intros.
  destruct cd.
  destruct dd.
  simpl.
  assert (count_occ Bool.bool_dec (map (is_class_name cn) CC) true = 0) by eauto.
  assert (count_occ Bool.bool_dec (map (is_class_name cn0) CC) true > 0).
  apply count_occ_In.
  assert (names_unique CC) by eauto using names_unique_further.
  unfold names_unique in H4.
  assert (forall x,In x CC -> decl_once CC x) by (apply Forall_forall; auto).
  assert (decl_once CC (JFCDecl cn0 ex0 fields0 methods0)) by auto.
  unfold decl_once in H6.
  unfold name_once in H6.
  assert (count_occ Bool.bool_dec (map (is_class_name cn0) CC) true >0) by
      try (rewrite H6; apply Gt.gt_Sn_O).
  apply <- count_occ_In; eauto.
  intro.
  rewrite H5 in *.
  rewrite H3 in H4.
  apply (Gt.gt_irrefl 0 H4).
Qed.

Lemma in_find_class_eq:
  forall CC cd cd',
    names_unique CC ->
    In cd CC ->
    find_class CC (name_of_cd cd) = Some cd' -> cd = cd'.
Proof.
  induction CC;intros.
  - assert (~ In cd []) by  auto using in_nil.
    tauto.
  - destruct (JFClassDeclaration_dec cd a).
    + simpl in H1. rewrite e in *.
      destruct a.
      simpl in H1.
      destruct (JFClassName_dec cn cn);
      try injection H1;
      tauto.
    + assert (names_unique CC) by eauto using names_unique_further.
      assert (a = cd \/ In cd CC) by eauto.
      destruct H3. symmetry in H3. contradiction.
      assert (name_of_cd cd <> name_of_cd a).
      apply (names_unique_neq_but_in CC a cd); auto.
      auto using in_eq.
      assert (find_class CC (name_of_cd cd) = Some cd').
      destruct a.
      eapply find_class_further_neq.
      simpl in H4.
      assert (cn <> name_of_cd cd) by auto.
      eauto.
      eauto.
      apply IHCC; auto.
Qed.

(**
   Calculates the list of fields in an object of the given class name
   [cname] traversing recursively its subtyping hierarchy up to _Object_.
   The parameter [n] is added to ensure the correcntess of
   structural recursion. The parameter [res] contains the triples
   of fields collected so far in possibly earlier computation.

   The function returns [Some] value in case its calculation is
   correct. In case the calculation is not correct (when
   - the structural induction parameter is too small,
   - there is a non _Object_ class, which is not extended,
   - there is no class of the given name in the program),
   the function returns [None].
 *)
Fixpoint flds_aux (CC:JFProgram) cn n res {struct n} : option (list JFFieldDeclaration) :=
  match find_class CC cn with
  | None => None
  | Some cd =>
    let fr := flds_of_cd cd in
    match cd with
    | JFCDecl _ None _ _ => Some (res ++ fr)
    | JFCDecl _ (Some ex) _ _ =>
      match n with
      | 0 => None
      | S k => flds_aux CC ex k (res ++ fr)
      end
    end
  end.

Lemma flds_aux_not_object_not_find_class:
  forall CC cn n fds,
    find_class CC cn = None ->
    cn <> JFObjectName ->
    flds_aux CC cn n fds = None.
Proof.
  destruct n.
  * intros. simpl.
    rewrite H.
    auto.
  * intros. simpl.
    rewrite H.
    auto.
Qed.

Lemma flds_aux_not_object_find_class_ex_zero:
  forall CC cn dn fields methods fds,
    find_class CC cn = Some (JFCDecl cn (Some dn) fields methods) ->
    flds_aux CC cn 0 fds = None.
Proof.
  intros.
  simpl.
  rewrite H.
  auto.
Qed.

Lemma flds_aux_not_object_in_first_none:
  forall CC n cn fields methods fds,
    exists flds',
    flds_aux ((JFCDecl cn None fields methods) :: CC) cn n fds = Some flds'.
Proof.
  intros.
  destruct n.
  + simpl.
    destruct_eq.
    eexists.
    auto.
  + simpl.
    destruct_eq.
    eexists.
    auto.
Qed.

Lemma flds_aux_nil:
    forall n CC cn fds,
      flds_aux CC cn n fds = Some [] ->
      fds = [].
Proof.
  induction n.
  * intros.
    simpl in H.
    destruct (find_class CC cn).
    ** destruct j.
       destruct ex.
       *** discriminate H.
       *** injection H;intros Hnil.
           apply app_eq_nil in Hnil.
           intuition.
    ** discriminate H.
  * intros.
    simpl in H.
    destruct (find_class CC cn).
    ** destruct j.
       destruct ex.
       + assert (fds ++ (flds_of_cd (JFCDecl cn0 (Some j) fields methods))
                 = []) as Hnil by (eapply IHn; eassumption).
         apply app_eq_nil in Hnil.
         intuition.
       + injection H;intros Hnil.
         eapply app_eq_nil in Hnil.
         intuition.
    ** discriminate H.
Qed.

Lemma flds_monotone_n_Sn:
  forall CC n cn fd fds,
         flds_aux CC cn n fd = Some fds ->
         flds_aux CC cn (S n) fd = Some fds.
Proof.
  induction n.
  + intros.
    simpl in H.
    simpl.
    destruct (find_class CC cn); try discriminate H.
    destruct j.
    destruct ex; try discriminate H.
    auto.
  + intros.
    unfold flds_aux.
    fold flds_aux.
    simpl in H.
    destruct (find_class CC cn); try discriminate H.
    destruct j.
    destruct ex; try discriminate H.
    assert (flds_aux CC j (S n) (fd ++ flds_of_cd (JFCDecl cn0 (Some j) fields methods)) = Some fds).
    auto.
    Opaque flds_of_cd.
    simpl in H0.
    auto.
    auto.
Qed.

Lemma flds_monotone_n:
  forall CC n m cn fd fds,
    flds_aux CC cn n fd = Some fds ->
    m > n ->
    flds_aux CC cn m fd = Some fds.
Proof.
  induction m.
  + intros.
    assert (n >=0) by auto with zarith.
    assert (0 > 0) by auto with zarith.
    assert (0<>0) by auto with zarith.
    contradiction.
  + intros.
    apply flds_monotone_n_Sn.
    assert (m > n \/ n=m) by auto using gt_S.
    destruct H1.
    ++ apply IHm; auto.
    ++ rewrite <- H1.
       auto.
Qed.

Lemma flds_aux_decompose_acc:
  forall n fds fd CC cn,
    flds_aux CC cn n fd = Some fds ->
    exists fds',
      fds = fd ++ fds'.
Proof.
  induction n.
  * intros.
    simpl in H.
    destruct (find_class CC cn).
    ** destruct j.
       destruct ex.
       *** discriminate H.
       *** injection H;intros.
           rewrite <- H0.
           eexists;auto.
    ** discriminate H.
  * intros.
    simpl in H.
    destruct (find_class CC cn).
    ** destruct j.
       destruct ex.
       *** assert ( exists fds', fds =
                            (fd ++ flds_of_cd (JFCDecl cn0 (Some j) fields methods)) ++ fds').
           {
             eapply IHn.
             apply H. }
           destruct H0.
           rewrite H0.
           eexists.
           auto using app_assoc.
       *** injection H;intros.
           rewrite <- H0.
           eexists. auto.
    ** discriminate H.
Qed.

Lemma flds_aux_decompose_second_same:
  forall n fd1 fd2 fd1' fd' CC cn,
    flds_aux CC cn n (fd1 ++ fd1') = Some (fd1 ++ fd1' ++ fd') ->
    flds_aux CC cn n (fd2 ++ fd1') = Some (fd2 ++ fd1' ++ fd').
Proof.
  induction n.
  * simpl.
    intros.
    destruct (find_class CC cn); try discriminate H.
    destruct j.
    destruct ex;try discriminate H.
    injection H;intros.
    rewrite app_assoc in H0.
    apply app_inv_head in H0.
    rewrite H0.
    rewrite app_assoc.
    auto.
  * simpl.
    intros.
    destruct (find_class CC cn); try discriminate H.
    destruct j.
    destruct ex;try discriminate H.
    **  rewrite <- 1 app_assoc in H.
        assert (exists ff, fd1 ++ fd1' ++ fd' = (fd1 ++ fd1' ++ (flds_of_cd (JFCDecl cn0 (Some j) fields methods))) ++ ff)
          by eauto 2 using flds_aux_decompose_acc.
        destruct H0.
        rewrite <- 2 app_assoc in H0.
        apply app_inv_head in H0.
        apply app_inv_head in H0.
        rewrite <- app_assoc.
        assert (flds_aux CC j n (fd2 ++ fd1' ++ flds_of_cd (JFCDecl cn0 (Some j) fields methods)) =
               Some (fd2 ++ (fd1'  ++ flds_of_cd (JFCDecl cn0 (Some j) fields methods)) ++ x)). {
         eapply IHn.
         rewrite H.
         rewrite H0.
         repeat rewrite app_assoc.
         auto 1.
        }
        rewrite H1.
        rewrite H0.
        repeat rewrite app_assoc.
        auto 1.
    ** injection H. intros.
       rewrite <- app_assoc in H0.
       apply app_inv_head in H0.
       apply app_inv_head in H0.
       rewrite H0.
       rewrite app_assoc.
       congruence.
Qed.

Lemma flds_aux_decompose_first_same:
  forall (n : nat) (fd1 fd1' fd2' fd' : list JFFieldDeclaration) (CC : JFProgram) (cn : JFClassName),
    flds_aux CC cn n (fd1 ++ fd1') = Some (fd1 ++ fd1' ++ fd') ->
    flds_aux CC cn n (fd1 ++ fd2') = Some (fd1 ++ fd2' ++ fd').
Proof.
  intros.
  rewrite app_assoc in H.
  replace (fd1 ++ fd1') with ((fd1 ++ fd1') ++ []) in H by
      (rewrite <- app_assoc;rewrite app_nil_r;auto).
  replace (((fd1 ++ fd1') ++ []) ++ fd') with ((fd1 ++ fd1') ++ [] ++ fd') in H
    by (rewrite app_assoc;rewrite app_nil_r;auto).
  eapply flds_aux_decompose_second_same in H.
  rewrite app_nil_r in H.
  rewrite H.
  repeat rewrite app_assoc.
  rewrite app_nil_r.
  auto 1.
Qed.

Lemma flds_aux_flds_aux:
  forall n CC cn fds x7 x7',
    flds_aux CC cn n x7 = Some fds ->
    (exists fds',
        flds_aux CC cn n x7' = Some fds').
Proof.
  induction n.
  * intros.
    simpl.
    simpl in H.
    destruct (find_class CC cn).
    ** destruct j.
       destruct ex.
       *** discriminate H.
       *** eexists. auto 1.
    ** discriminate H.
  * intros.
    simpl.
    simpl in H.
    destruct (find_class CC cn).
    ** destruct j.
       destruct ex.
       *** eapply IHn.
           apply H.
       *** eexists. auto 1.
    ** discriminate H.
Qed.

(** How many extends steps there are to reach Object. *)
Fixpoint get_class_height (CC:JFProgram) (cn:JFClassName) : nat :=
  match CC with
  | [] => 0
  | (JFCDecl name (Some name') _ _) :: CC' =>
    if (JFClassName_dec name cn)
    then S (get_class_height CC' name')
    else get_class_height CC' cn
  | (JFCDecl name None _ _) :: CC' =>
    if (JFClassName_dec name cn)
    then 1
    else get_class_height CC' cn
  end.

Lemma get_class_height_non_zero:
  forall CC cn ex fields methods,
  In (JFCDecl cn ex fields methods) CC ->
         get_class_height CC cn <> 0.
Proof.
  induction CC.
  + intros.
    auto 2 using in_nil.
  + intros.
    simpl.
    destruct a.
    destruct ex0.
    ++ destruct (JFClassName_dec cn0 cn).
       +++ auto 1.
       +++ apply in_inv in H.
           destruct H.
           ++++ injection H;intros;contradiction.
           ++++ eauto 2.
    ++ destruct (JFClassName_dec cn0 cn).
       +++ auto 1.
       +++ apply in_inv in H.
           destruct H.
           ++++ injection H;intros;contradiction.
           ++++ eauto 2.
Qed.

Lemma find_class_get_class_height:
  forall CC cn cd,
    find_class CC cn = Some cd ->
    get_class_height CC cn <> 0.
Proof.
  induction CC.
  + intros.
    discriminate H.
  + intros.
    destruct a.
    simpl.
    simpl in H.
    intro.
    destruct (JFClassName_dec cn0 cn).
    +++ destruct ex;discriminate H0.
    +++ destruct ex;eapply IHCC;eauto.
Qed.

(** Calculates the list of field declarations in an object of the given
    class identifier [C]. In case [C] is the bottom class
    the function returns [None]. Otherwise it traverses the
    object hierarchy and collects filelds.

    Defined in Figure {fig:auxiliary-notation} as the function flds with overline bar. *)
Definition flds_overline (CC:JFProgram) (C:JFCId)
: option (list JFFieldDeclaration) :=
  match C with
    | JFClass cn =>
      flds_aux CC cn (get_class_height CC cn) []
    | JFBotClass => None
  end.

Lemma flds_overline_find_class :
  forall CC C flds,
    flds_overline CC (JFClass C) = Some flds ->
    exists cdecl, find_class CC C = Some cdecl.
Proof.
  intros ? ? ? Htmp.
  simpl in Htmp.
  destruct get_class_height in Htmp.
  + simpl in Htmp.
    destruct find_class; eauto 2.
    discriminate Htmp.
  + simpl in Htmp.
    destruct find_class; eauto 2.
    discriminate Htmp.
Qed.

Hint Resolve flds_overline_find_class.

(** Calculates the list of field identifiers in an object of the given
    class identifier [C]. In case [C] is the bottom class
    the function returns [None]. Otherwise it traverses the
    object hierarchy and collects filelds.

    Defined in Figure {fig:syntax} as the function flds. *)
Definition flds (CC:JFProgram) (C:JFCId) :=
  match flds_overline CC C with
  | Some fields => Some (map name_of_fd fields)
  | None => None
  end.

(** Calculates the type of the parameter [n] in the method [md] in
    the class [C]. In case [C] is the bottom class the function
    returns [None]. Otherwise it looks up the method [md] in the class
    declaration of [C] in [CC]. If it succeeds it returns the type
    of the paramter. Otherwise it returns None. We use here the
    operation (.)^rwr in case method has no annotations. The value
    n=0 is for the type of this.

    Defined in Figure {fig:auxiliary-notation} as the function parTypM.
  *)
Definition parTypM_of_md (C:JFCId) (md: JFMethodDeclaration) (n:nat) : JFACId :=
  match md with
  | JFMDecl D mu mn vs excs E =>
    match n with
    | 0 => (C, mu)
    | _ => nth (n-1) (map snd vs) (JFObject, JFrwr)
    end
  | JFMDecl0 D mn vs excs E =>
    match n with
    | 0 => (C, JFrwr)
    | _ => (nth (n-1) (map snd vs) JFObject, JFrwr)
    end
  end.

Definition parTypM (CC:JFProgram) (C:JFCId) (m:JFMId) (n:nat)
  : option JFACId :=
  match C with
    | JFClass cn =>
      let mdo := methodLookup CC cn m in
      match mdo with
      | Some md => Some (parTypM_of_md C md n)
      | None => None
      end
    | JFBotClass => None
  end.

Definition retTypM (CC:JFProgram) (C:JFCId) (m:JFMId)
  : option JFACId :=
  match C with
    | JFClass cn =>
      let mdo := methodLookup CC cn m in
      match mdo with
        | Some md => Some (rettyp_of_md md)
        | None => None
      end
    | JFBotClass => None
  end.

Definition thrs (CC:JFProgram) (C:JFCId) (m:JFMId)
  : option (list JFACId) :=
  match C with
    | JFClass cn =>
      let mdo := methodLookup CC cn m in
      match mdo with
        | Some md => Some (thrs_of_md md)
        | None => None
      end
    | JFBotClass => None
  end.

Lemma thrs_thrs_of_md:
  forall CC cn md,
    methodLookup CC cn (name_of_md md) = Some md ->
    thrs CC (JFClass cn) (name_of_md md) =
    Some (thrs_of_md md).
Proof.
  intros.
  simpl.
  rewrite H.
  auto.
Qed.

Definition body (CC:JFProgram) (C:JFCId) (m:JFMId)
  : option JFExpr :=
  match C with
    | JFClass cname =>
      let mdo := methodLookup CC cname m in
      match mdo with
        | Some md =>
          Some (body_of_md md)
        | None => None
      end
    | JFBotClass => None
  end.


(** Camera definitions and proofs for the keyset RA. *)

From iris.algebra Require Import gset.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Export iprop.
From iris.base_logic.lib Require Export invariants.

Set Default Proof Using "All".
Require Export search_str flows auth_ext.

Section keyset_ra.

(* The set of keys. *)
Context `{Countable K}.

(* The keyspace is some arbitrary finite subset of K. *)
Parameter KS : gset K.

Inductive prodT :=
  prod : gset K*gset K → prodT
| prodTop : prodT
| prodBot : prodT.

Canonical Structure prodRAC := leibnizO prodT.

Global Instance prodOp : Op prodT :=
  λ p1 p2,
  match p1, p2 with
  | prod (K1, C1), prod (K2, C2) =>
    if (decide(C1 ⊆ K1)) then
      (if (decide(C2 ⊆ K2)) then
         (if (decide (K1 ## K2)) then
            (if (decide (C1 ## C2)) then (prod (K1 ∪ K2, C1 ∪ C2))
             else prodTop)
          else prodTop)
       else prodTop)
    else prodTop
  | prodTop, _ => prodTop
  | _, prodTop => prodTop
  | p1, prodBot => p1
  | prodBot, p2 => p2 end.

Global Instance prodValid : Valid prodT :=
λ p, match p with
       | prod (K, C) => C ⊆ K
       | prodTop => False
       | prodBot => True end.

Global Instance prodCore : PCore prodT :=
  λ p, Some prodBot.

Global Instance prodUnit : Unit prodT := prodBot.

Definition prodRA_mixin : RAMixin prodT.
Proof.
  split; try apply _; try done.
  - (* Core is unique? *)
    intros ? ? cx -> ?. exists cx. done.
  - unfold op, prodOp. intros [] [] []; try (simpl; done).
    case_eq p. intros g g0 Hp. case_eq p0. intros g1 g2 Hp0. case_eq p1. intros g3 g4 Hp1.
    destruct (decide (g2 ⊆ g1)). destruct (decide (g4 ⊆ g3)). destruct (decide (g1 ## g3)).
    destruct (decide (g2 ## g4)). destruct (decide (g0 ⊆ g)). destruct (decide (g2 ∪ g4 ⊆ g1 ∪ g3)).
    destruct (decide (g ## g1 ∪ g3)). destruct (decide (g0 ## g2 ∪ g4)).
    destruct (decide (g ## g1)). destruct (decide (g0 ## g2)). destruct (decide (g0 ∪ g2 ⊆ g ∪ g1)).
    destruct (decide (g ∪ g1 ## g3)). destruct (decide (g0 ∪ g2 ## g4)). apply leibniz_equiv_iff.
    assert (g ∪ (g1 ∪ g3) = g ∪ g1 ∪ g3). { set_solver. }
    assert (g0 ∪ (g2 ∪ g4) = g0 ∪ g2 ∪ g4). { set_solver. }
    rewrite H0. rewrite H1. reflexivity.
    unfold not in n. exfalso. apply n. set_solver.
    unfold not in n. exfalso. apply n. set_solver.
    unfold not in n. exfalso. apply n. set_solver.
    unfold not in n. exfalso. apply n. set_solver.
    unfold not in n. exfalso. apply n. set_solver.
    destruct (decide (g ## g1)). destruct (decide (g0 ## g2)). destruct (decide (g ∪ g1 ## g3)).
    destruct (decide (g0 ∪ g2 ## g4)).
    unfold not in n. exfalso. apply n. set_solver.
    unfold not in n. exfalso. apply n. set_solver.
    destruct (decide (g0 ∪ g2 ⊆ g ∪ g1)); try done. done. done.
    destruct (decide (g ## g1)). destruct (decide (g0 ## g2)). destruct (decide (g0 ∪ g2 ⊆ g ∪ g1)).
    destruct (decide (g ∪ g1 ## g3)). destruct (decide (g0 ∪ g2 ## g4)).
    unfold not in n. exfalso. apply n. set_solver. done. done. done. done. done.
    unfold not in n. exfalso. apply n. set_solver. done.
    unfold not in n. exfalso. apply n. set_solver.
    destruct (decide (g0 ⊆ g)). destruct (decide (g ## g1)); try done.
    destruct (decide (g0 ## g2)). destruct (decide (g0 ∪ g2 ⊆ g ∪ g1)).
    destruct (decide (g ∪ g1 ## g3)). unfold not in n. exfalso. apply n. set_solver.
    done. done. done. done. destruct (decide (g0 ⊆ g)).
    destruct (decide (g ## g1)). destruct (decide (g0 ## g2)).
    destruct (decide (g0 ∪ g2 ⊆ g ∪ g1)). done. done. done. done. done.
    destruct (decide (g0 ⊆ g)). done. done.
    case_eq p. intros g g0 Hp. case_eq p0. intros g1 g2 Hp0. destruct (decide (g0 ⊆ g)).
    destruct (decide (g2 ⊆ g1)). destruct (decide (g ## g1)).
    destruct (decide (g0 ## g2)). done. done. done. done. done.
    case_eq p. intros g g0 Hp. case_eq p0. intros g1 g2 Hp0. destruct (decide (g0 ⊆ g)).
    destruct (decide (g2 ⊆ g1)). destruct (decide (g ## g1)).
    destruct (decide (g0 ## g2)). done. done. done. done. done.
    case_eq p; try done. case_eq p; try done. case_eq p; try done. case_eq p; try done.
    case_eq p; try done. case_eq p; try done. case_eq p. intros g g0 Hp. case_eq p0. intros g1 g2 Hp0.
    destruct (decide (g0 ⊆ g)). destruct (decide (g2 ⊆ g1)). destruct (decide (g ## g1)).
    destruct (decide (g0 ## g2)). done. done. done. done. done.
    case_eq p; try done. case_eq p; try done.
  - unfold op, prodOp. intros [] []. case_eq p. intros g g0 Hp. case_eq p0. intros g1 g2 Hp0.
    destruct (decide (g0 ⊆ g)); try done. destruct (decide (g2 ⊆ g1)); try done.
    destruct (decide (g ## g1)). destruct (decide (g0 ## g2)). destruct (decide (g1 ## g)).
    destruct (decide (g2 ## g0)). assert (g1 ∪ g = g ∪ g1 ∧ g2 ∪ g0 = g0 ∪ g2) as [H1 H2]. { set_solver. }
    rewrite H1; rewrite H2. done. unfold not in n. exfalso. apply n. done.
    unfold not in n. exfalso. apply n. done. destruct (decide (g1 ## g)). destruct (decide (g2 ## g0)).
    unfold not in n. exfalso. apply n. done. done. done. destruct (decide (g1 ## g)).
    unfold not in n. exfalso. apply n. done. done. destruct (decide (g2 ⊆ g1)); try done.
    case_eq p; try done. case_eq p; try done. case_eq p; try done. done. done.
    case_eq p; try done. done. done.
  - unfold pcore, prodCore. intros x cx. intros Hx. inversion Hx.
    unfold op, prodOp. destruct x; try done.
  - unfold pcore, prodCore. intros x cx Hx. inversion Hx. done.
  - intros x y cx Hxy HS. inversion HS. exists prodBot. split; try done. exists prodBot; done.
  - unfold valid, prodValid. intros x y. destruct x. destruct p.
    destruct y. destruct p. unfold op, prodOp. destruct (decide (g0 ⊆ g)).
    destruct (decide (g2 ⊆ g1)). destruct (decide (g ## g1)). destruct (decide (g0 ## g2)).
    intros. done. intros; done. intros; done. intros; done. intros; done.
    unfold op, prodOp. intros; done. unfold op, prodOp. done. unfold op, prodOp. done.
    destruct y. destruct p. unfold op, prodOp. done. unfold op, prodOp. done. unfold op, prodOp. done.
Qed.

Canonical Structure KsetRA := discreteR prodT prodRA_mixin.

Global Instance prodRA_cmra_discrete : CmraDiscrete KsetRA.
Proof. apply discrete_cmra_discrete. Qed.

Lemma prod_ucmra_mixin : UcmraMixin prodT.
Proof.
  split; try apply _; try done. unfold LeftId. intros x. unfold ε, prodUnit.
  unfold op, prodOp. destruct x; try done.
Qed.

Canonical Structure keysetUR : ucmra := Ucmra prodT prod_ucmra_mixin.

Lemma auth_ks_included (a1 a2 b1 b2: gset K) :
  ✓ prod (a1, b1) → ✓ prod (a2, b2) → prod (a1, b1) ≼ prod (a2, b2)
  → (a1 = a2 ∧ b1 = b2) ∨
    (∃ a0 b0, a2 = a1 ∪ a0 ∧ b2 = b1 ∪ b0 ∧ a1 ## a0 ∧ b1 ## b0 ∧ b1 ⊆ a1 ∧ b2 ⊆ a2 ∧ b0 ⊆ a0).
Proof.
  intros H1 H2 H0. destruct H0 as [z H0]. assert (✓ z). { apply (cmra_valid_op_r (prod (a1, b1))).
  rewrite <- H0. done. } rewrite /(✓ prod (a1, b1)) /= in H1. rewrite /(✓ prod (a2, b2)) /= in H2.
  destruct z.
  - destruct p. rewrite /(✓ prod (g, g0)) /= in H3. rewrite /(⋅) /= in H0.
    destruct (decide (b1 ⊆ a1)). destruct (decide (g0 ⊆ g)). destruct (decide (a1 ## g)).
    destruct (decide (b1 ## g0)). right. exists g, g0. set_solver. inversion H0. inversion H0.
    inversion H0. inversion H0.
  - rewrite /(✓ prodTop) /= in H0. exfalso. done.
  - rewrite /(⋅) /= in H0. inversion H0. left. done.
Qed.

Lemma auth_ks_local_update_insert K1 C Cn k:
  ✓ prod (KS, C) ∧ ✓ prod (K1, Cn) ∧ k ∈ K1 ∧ k ∉ Cn ∧ k ∈ KS →
  (prod (KS, C), prod (K1, Cn)) ~l~> (prod (KS, C ∪ {[k]}), prod (K1, Cn ∪ {[k]})).
Proof.
  intros [H1 [H2 [H3 [H4 HKS]]]]. apply local_update_discrete. intros z.
  intros _. intros. split. rewrite /(✓ prod (KS, C ∪ {[k]})) /=.
  rewrite /(cmra_valid KsetRA) /=. rewrite /(✓ prod (KS, C)) /= in H1.
  set_solver. rewrite /(opM) /= in H0.
  destruct z. rewrite /(opM) /=. destruct c. destruct p. rewrite /(op) /= in H0.
  rewrite /(cmra_op KsetRA) /= in H0. destruct (decide (Cn ⊆ K1)).
  destruct (decide (g0 ⊆ g)). destruct (decide (K1 ## g)). destruct (decide (Cn ## g0)).
  inversion H0. rewrite /(op) /=. rewrite /(cmra_op KsetRA) /=. destruct (decide (Cn ∪ {[k]} ⊆ K1)).
  destruct (decide (g0 ⊆ g)). destruct (decide (K1 ## g)). destruct (decide (Cn ∪ {[k]} ## g0)).
  assert (Cn ∪ g0 ∪ {[k]} = Cn ∪ {[k]} ∪ g0). { set_solver. } rewrite H6. rewrite H5. done.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  rewrite /(op) /= in H0. rewrite /(cmra_op KsetRA) /= in H0. inversion H0.
  rewrite /(op) /= in H0. rewrite /(cmra_op KsetRA) /= in H0. inversion H0.
  rewrite /(op) /=. rewrite /(cmra_op KsetRA) /=. done.
  rewrite /(opM) /=. inversion H0. done.
Qed.

Lemma auth_ks_local_update_delete K1 C Cn k:
            ✓ prod (KS, C) ∧ ✓ prod (K1, Cn) ∧ k ∈ K1 ∧ k ∈ Cn →
           (prod (KS, C), prod (K1, Cn)) ~l~> (prod (KS, C ∖ {[k]}), prod (K1, Cn ∖ {[k]})).
Proof.
  intros [H1 [H2 [H3 H4]]]. apply local_update_discrete. intros z.
  intros _. intros. split. rewrite /(✓ prod (KS, C ∖ {[k]})) /=.
  rewrite /(cmra_valid KsetRA) /=. rewrite /(✓ prod (KS, C)) /= in H1.
  set_solver. rewrite /(opM) /= in H0.
  destruct z. rewrite /(opM) /=. destruct c. destruct p. rewrite /(op) /= in H0.
  rewrite /(cmra_op KsetRA) /= in H0. destruct (decide (Cn ⊆ K1)).
  destruct (decide (g0 ⊆ g)). destruct (decide (K1 ## g)). destruct (decide (Cn ## g0)).
  inversion H. rewrite /(op) /=. rewrite /(cmra_op KsetRA) /=. destruct (decide (Cn ∖ {[k]} ⊆ K1)).
  destruct (decide (g0 ⊆ g)). destruct (decide (K1 ## g)). destruct (decide (Cn ∖ {[k]} ## g0)).
  assert (k ∉ g0). { set_solver. }
  assert ((Cn ∪ g0) ∖ {[k]} = Cn ∖ {[k]} ∪ g0). { set_solver. } rewrite <- H6. inversion H0. done.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  unfold not in n. exfalso. apply n. set_solver. unfold not in n. exfalso. apply n. set_solver.
  rewrite /(op) /= in H0. rewrite /(cmra_op KsetRA) /= in H0. inversion H0.
  rewrite /(op) /= in H0. rewrite /(cmra_op KsetRA) /= in H0. inversion H0.
  rewrite /(op) /=. rewrite /(cmra_op KsetRA) /=. done.
  rewrite /(opM) /=. inversion H0. done.
Qed.

End keyset_ra.

Arguments keysetUR _ {_ _}.

Section keyset_updates.
  Context `{Countable K}.

  (** RA for pairs of keysets and contents *)

  Class keysetG Σ := KeysetG { keyset_inG :> inG Σ (authUR (keysetUR K)) }.
  Definition keysetΣ : gFunctors := #[GFunctor (authUR (keysetUR K))].

  Global Instance subG_keysetΣ {Σ} : subG keysetΣ Σ → keysetG Σ.
  Proof. solve_inG. Qed.

  Context `{!keysetG Σ}.

  (** Some useful lemmas  *)

  Lemma keyset_valid γ_k Ks C:
    own γ_k (◯ prod (Ks, C)) -∗ ⌜C ⊆ Ks⌝.
  Proof.
    iIntros "Hks".
    iPoseProof (own_valid with "Hks") as "HvldCn".
    iDestruct "HvldCn" as %HvldCn.
    rewrite auth_frag_valid in HvldCn *; intros HvldCn.
    unfold valid, cmra_valid in HvldCn.
    simpl in HvldCn. unfold ucmra_valid in HvldCn. simpl in HvldCn.
      by iPureIntro.
  Qed.

  (** Ghost update of abstract search structure state *)

  Lemma ghost_update_keyset γ_k dop (k: K) Cn Cn' res K1 C:
    ⊢ ⌜Ψ dop k Cn Cn' res⌝ ∗ own γ_k (● prod (KS, C)) ∗ own γ_k (◯ prod (K1, Cn))
    ∗ ⌜Cn' ⊆ K1⌝ ∗ ⌜k ∈ K1⌝ ∗ ⌜k ∈ KS⌝
    ==∗ ∃ C', ⌜Ψ dop k C C' res⌝ ∗ own γ_k (● prod (KS, C'))
      ∗ own γ_k (◯ prod (K1, Cn')).
  Proof.
    iIntros "(#HΨ & Ha & Hf & % & % & HKS)". iPoseProof (auth_own_incl γ_k (prod (KS, C)) (prod (K1, Cn))
                with "[$Ha $Hf]") as "%". iDestruct "HKS" as %HKS.
    iPoseProof ((own_valid γ_k (● prod (KS, C))) with "Ha") as "%".
    iPoseProof ((own_valid γ_k (◯ prod (K1, Cn))) with "Hf") as "%".
    assert ((K1 = KS ∧ Cn = C) ∨
            (∃ a0 b0, KS = K1 ∪ a0 ∧ C = Cn ∪ b0 ∧ K1 ## a0 ∧ Cn ## b0 ∧ Cn ⊆ K1 ∧ C ⊆ KS ∧ b0 ⊆ a0)) as Hs.
    { apply (auth_ks_included K1 KS Cn C); try done. rewrite <- auth_frag_valid. done. apply auth_auth_valid. done. }
    destruct Hs.
    - iEval (unfold Ψ) in "HΨ". destruct H5. destruct dop.
      + iDestruct "HΨ" as "%". destruct H7.
        iModIntro. iExists C. iEval (rewrite <-H7) in "Hf". iFrame. unfold Ψ.
        iPureIntro. split; try done. rewrite <-H6. done.
      + iDestruct "HΨ" as "%". destruct H7. destruct res.
        * iMod (own_update_2 γ_k (● prod (KS, C)) (◯ prod (K1, Cn))
          (● prod (KS, C ∪ {[k]}) ⋅ ◯ prod (K1, Cn ∪ {[k]})) with "[Ha] [Hf]") as "(Ha & Hf)"; try done.
          { apply auth_update. apply auth_ks_local_update_insert.
            repeat split; try done. apply auth_auth_valid.  done. apply auth_frag_valid. done.  }
          iModIntro. iExists (C ∪ {[k]}). iEval (rewrite H7). iFrame.
          unfold Ψ. iPureIntro. split; try done. rewrite <-H6. done.
        * assert (Cn' = Cn). { set_solver. } iModIntro. iExists C. iEval (rewrite <-H9) in "Hf".
          iFrame. unfold Ψ. iPureIntro. rewrite <- H6. split; try done. rewrite H9 in H7. done.
      + iDestruct "HΨ" as "%". destruct H7. destruct res.
        * iMod (own_update_2 γ_k (● prod (KS, C)) (◯ prod (K1, Cn))
          (● prod (KS, C ∖ {[k]}) ⋅ ◯ prod (K1, Cn ∖ {[k]})) with "[Ha] [Hf]") as "(Ha & Hf)"; try done.
          { apply auth_update. apply auth_ks_local_update_delete. repeat split; try done. apply auth_auth_valid. done. apply auth_frag_valid. done. }
          iModIntro. iExists (C ∖ {[k]}). iEval (rewrite H7). iFrame.
          unfold Ψ. iPureIntro. split; try done. rewrite <-H6. done.
        * assert (Cn' = Cn). { set_solver. } iModIntro. iExists C. iEval (rewrite <-H9) in "Hf".
          iFrame. unfold Ψ. iPureIntro. rewrite <- H6. split; try done. rewrite H9 in H7. done.
    - destruct H5 as [Ko [Co [H5 [H6 [H7 [H8 [H9 [H10 H11]]]]]]]]. destruct dop.
      + iDestruct "HΨ" as "%". destruct H12.
        iModIntro. iExists C. iEval (rewrite <-H12) in "Hf". iFrame. unfold Ψ.
        iPureIntro. split; try done. destruct res; set_solver.
      + iDestruct "HΨ" as "%". destruct H12. destruct res.
        * iMod (own_update_2 γ_k (● prod (KS, C)) (◯ prod (K1, Cn))
          (● prod (KS, C ∪ {[k]}) ⋅ ◯ prod (K1, Cn ∪ {[k]})) with "[Ha] [Hf]") as "(Ha & Hf)"; try done.
          { apply auth_update. apply auth_ks_local_update_insert. split; try done. }
          iModIntro. iExists (C ∪ {[k]}). iEval (rewrite H12). iFrame.
          unfold Ψ. iPureIntro. split; try done. set_solver.
        * assert (Cn' = Cn). { set_solver. } iModIntro. iExists C. iEval (rewrite <-H14) in "Hf".
          iFrame. unfold Ψ. iPureIntro. set_solver.
      + iDestruct "HΨ" as "%". destruct H12. destruct res.
        * iMod (own_update_2 γ_k (● prod (KS, C)) (◯ prod (K1, Cn))
          (● prod (KS, C ∖ {[k]}) ⋅ ◯ prod (K1, Cn ∖ {[k]})) with "[Ha] [Hf]") as "(Ha & Hf)"; try done.
          { apply auth_update. apply auth_ks_local_update_delete. repeat split; try done. }
          iModIntro. iExists (C ∖ {[k]}). iEval (rewrite H12). iFrame.
          unfold Ψ. iPureIntro. split; try done. set_solver.
        * assert (Cn' = Cn). { set_solver. } iModIntro. iExists C. iEval (rewrite <-H14) in "Hf".
          iFrame. unfold Ψ. iPureIntro. set_solver.
  Qed.

End keyset_updates.


Require Import MSets.MSetFacts.
Require Import MSets.MSetProperties.
Require Import MSets.MSetDecide.
Require Import FSets.FMapFacts.
Require Export Solvers.
Require Import RLDi.
Require Import Utf8.

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

Module SolverRLD (Sys : CSysJoinSemiLat)
                 (VSet : SetsTypeOn (Sys.V))
                 (VMap : MapsTypeOn (Sys.V)).

Module Var := Sys.V.
Module D <: JoinSemiLattice := Sys.D.

Module UtilD := UtilJoin (D).

Module Import VSetFacts := WFactsOn (Var) (VSet).
Module Import VSetProps := WPropertiesOn (Var) (VSet).
Module Import VSetDecide := WDecideOn (Var) (VSet).
Module Import VMapFacts := WFacts_fun (Var) (VMap).

Module VS := VSet.
Module Sigma := VMap.
Module Infl := VMap.

Definition F := Sys.F.

Module Import Defs := Solvers.Defs (Sys).

Module SI := SolverRLDInstr (Sys) (VSet) (VMap).

(*****************************************************************)
(*********** Non-instrumented algorithm specification ************)
(*****************************************************************)

Definition state :=
  (Sigma.t D.t * Infl.t (list Var.t) * VS.t)%type.

Ltac destruct_state s :=
  let sig := fresh "sigma" in
  let inf := fresh "infl" in
  let sta := fresh "stable" in
    destruct s as [ [sig inf] sta].

Ltac destruct_pose_state s :=
  let sig := fresh "sigma" in
  let inf := fresh "infl" in
  let sta := fresh "stable" in
    destruct s as [ [sig inf] sta];
    pose (s := (sig, inf, sta));
    fold s.

Definition setval (x : Var.t) d (s : state) : state :=
  let '(sigma, infl, stable) := s in
    (Sigma.add x d sigma, infl, stable).

Definition getval (s : state) x :=
  let '(sigma, _, _) := s in
    match Sigma.find x sigma with
      | Some d => d
      | None => D.bot
    end.

Lemma getval_eq (s1 s2 : state) :
  let '(sigma1, _, _) := s1 in
  let '(sigma2, _, _) := s2 in
    VMap.Equal sigma1 sigma2 ->
    getval s1 = getval s2.
Proof.
destruct_state s1. destruct_state s2. intro e.
extensionality x; simpl. now rewrite e.
Qed.

Definition get_infl (s : state) x : list (Var.t) :=
  let '(_, infl, _) := s in
    match Infl.find x infl with
      | Some l => l
      | None => []
    end.

Lemma get_infl_eq s1 s2 :
  let '(_, infl1, _) := s1 in
  let '(_, infl2, _) := s2 in
    VMap.Equal infl1 infl2 ->
    get_infl s1 = get_infl s2.
Proof.
destruct_state s1. destruct_state s2. intro e.
extensionality x; simpl. now rewrite e.
Qed.

Definition add_infl y x (s : state) : state :=
  let '(sigma, infl, stable) := s in
    let xs := get_infl s y in
    (sigma, Infl.add y (x :: xs) infl, stable).

Definition rem_infl x (s : state) : state :=
  let '(sigma, infl, stable) := s in
    (sigma, Infl.remove x infl, stable).

Definition is_stable x (s : state) :=
  let '(_, _, stable) := s in VS.In x stable.

Lemma is_stable_dec x s : {is_stable x s} + {~ is_stable x s}.
destruct_state s. simpl. now apply VSetProps.In_dec.
Qed.

Definition get_stable (s : state) :=
  let '(_, _, stable) := s in stable.

Definition add_stable x (s : state) : state :=
  let '(sigma, infl, stable) := s in
    (sigma, infl, VS.add x stable).

Definition rem_stable x (s : state) : state :=
  let '(sigma, infl, stable) := s in
    (sigma, infl, VS.remove x stable).

Definition prepare x s := add_stable x s.

Definition handle_work (w : list Var.t) (s : state) :=
    let f s x := rem_stable x s in
    List.fold_left f w s.

Definition extract_work (x : Var.t) (s : state) : (list Var.t * state)
  := let w := get_infl s x in
     let s := rem_infl x s in
     let s := handle_work w s in
       (w, s).

Lemma handle_work_spec s w s' :
  s' = handle_work w s ->
  let '(sigma, infl, stable) := s in
  let '(sigma', infl', stable') := s' in
    sigma' = sigma /\
    infl' = infl /\
    VS.Equal stable' (VS.diff stable (of_list w)).
Proof.
revert s s'.
induction w as [| x w IHw ].
- intros s s' H1. destruct_state s. destruct_state s'. simpl.
  inversion H1. now intuition; fsetdec.
- intros s s' H.
  remember (rem_stable x s) as s1.
  assert (H1 : s' = handle_work w s1) by (subst; auto).
  assert (H2 := IHw _ _ H1). clear IHw H1.
  destruct_state s. destruct_state s1. destruct_state s'.
  inversion Heqs1; subst; simpl.
  now intuition; fsetdec.
Qed.

Lemma extract_work_spec x s w s' :
  (w, s') = extract_work x s ->
  let '(sigma, infl, stable) := s in
  let '(sigma', infl', stable') := s' in
    w = get_infl s x /\
    sigma' = sigma /\
    infl' = Infl.remove x infl /\
    VS.Equal stable' (VS.diff stable (of_list w)).
Proof.
intro H. injection H as H1 Ew; clear H.
assert (H := handle_work_spec H1).
subst w. destruct_state s. destruct_state s'.
now simpl in *; intuition.
Qed.

Definition s_init : state
  := (Sigma.empty D.t,
      Infl.empty (list Var.t),
      VS.empty).

Section algorithm.

Variable Hpure : forall x, is_pure (F x).
Definition rhs x : Tree Var.t D.t D.t := proj1_sig (Hpure x).

Lemma rhs_spec x : F x = [[rhs x]].
Proof. now rewrite (proj2_sig (Hpure x)). Qed.

Inductive EvalGet :
  Var.t -> Var.t -> state -> D.t * state -> Prop :=
  | EvalGet0 :
      forall x y s s0,
        Solve y s s0 ->
        let s1 := add_infl y x s0 in
        let d := getval s0 y in
        EvalGet x y s (d, s1)

with EvalGet_x :
  Var.t -> (Var.t -> state -> D.t * state -> Prop) -> Prop :=
  | EvalGet_x0 :
      forall x (f : Var.t -> state -> D.t * state -> Prop),
        (forall y s0 ds1,
           f y s0 ds1 -> EvalGet x y s0 ds1) ->
        EvalGet_x x f

with Wrap_Eval_x :
  Var.t -> (Var.t -> state -> D.t * state -> Prop) ->
  @Tree Var.t D.t D.t ->
  state -> D.t * state -> Prop :=
  | Wrap_Eval_x0 :
    forall x f t s0 ds1,
      EvalGet_x x f ->
      [[t]]# f s0 ds1 ->
      Wrap_Eval_x x f t s0 ds1

with Eval_rhs :
  Var.t ->
  state -> D.t * state -> Prop :=
  | Eval_rhs0 :
    forall x f s0 ds1,
      EvalGet_x x f ->
      Wrap_Eval_x x f (rhs x) s0 ds1 ->
      Eval_rhs x s0 ds1

with Solve :
  Var.t -> state -> state -> Prop :=
  | Solve0 :
      forall x s, is_stable x s -> Solve x s s
  | Solve1 :
      forall x d s s2,
      ~ is_stable x s ->
      let s1 := prepare x s in
      Eval_rhs x s1 (d, s2) ->
      let cur := getval s2 x in
      let new := D.join cur d in
      D.Leq new cur ->
      Solve x s s2
  | Solve2 :
      forall x d s s2 s5 s6 work,
      ~ is_stable x s ->
      let s1 := prepare x s in
      Eval_rhs x s1 (d, s2) ->
      let cur := getval s2 x in
      let new := D.join cur d in
      ~ D.Leq new cur ->
      let s4 := setval x new s2 in
      (work, s5) = extract_work x s4 ->
      SolveAll work s5 s6 ->
      Solve x s s6

with SolveAll :
  list Var.t -> state -> state -> Prop :=
  | SolveAll0 :
      forall s, SolveAll [] s s
  | SolveAll2 :
      forall x xs s s1 s2,
        Solve x s s1 ->
        SolveAll xs s1 s2 ->
        SolveAll (x :: xs) s s2.

(* generate a mutual induction scheme *)
Scheme evalget_min   := Minimality for EvalGet Sort Prop
  with evalgetx_min  := Minimality for EvalGet_x Sort Prop
  with wrapevalx_min := Minimality for Wrap_Eval_x Sort Prop
  with evalrhs_min   := Minimality for Eval_rhs Sort Prop
  with solve_min     := Minimality for Solve Sort Prop
  with solveall_min  := Minimality for SolveAll Sort Prop.

Combined Scheme solve_mut_min from
  evalget_min,
  evalgetx_min,
  wrapevalx_min,
  evalrhs_min,
  solve_min,
  solveall_min.

Definition EvalGet_fun x y s ds1
  := forall ds1', EvalGet x y s ds1' -> ds1 = ds1'.

Definition EvalGet_x_fun x (f : Var.t -> state -> D.t * state -> Prop)
  := forall f',
       EvalGet_x x f' ->
       forall y s ds0 ds0',
         f y s ds0 -> f' y s ds0' -> ds0 = ds0'.

Definition Wrap_Eval_x_fun x (f : Var.t -> state -> D.t * state -> Prop) t s ds1
  := forall f' ds1',
       Wrap_Eval_x x f' t s ds1' ->
       (forall y s ds0 ds0',
          f y s ds0 -> f' y s ds0' -> ds0 = ds0') ->
       ds1 = ds1'.

Definition Eval_rhs_fun x s ds1
  := forall ds1', Eval_rhs x s ds1' -> ds1 = ds1'.

Definition Solve_fun x s s1
  := forall s1', Solve x s s1' -> s1 = s1'.

Definition SolveAll_fun (l : list Var.t) s s1
  := forall s1', SolveAll l s s1' -> s1 = s1'.

Lemma partial_functions_invar :
  (forall x y s1 ds2,
     EvalGet x y s1 ds2 -> EvalGet_fun x y s1 ds2) /\
  (forall x f,
    EvalGet_x x f -> EvalGet_x_fun x f) /\
  (forall x f t s1 ds2,
    Wrap_Eval_x x f t s1 ds2 ->
    Wrap_Eval_x_fun x f t s1 ds2) /\
  (forall x s1 ds2,
    Eval_rhs x s1 ds2 -> Eval_rhs_fun x s1 ds2) /\
  (forall x s1 s2,
    Solve x s1 s2 -> Solve_fun x s1 s2) /\
  (forall w s1 s2,
    SolveAll w s1 s2 -> SolveAll_fun w s1 s2).
Proof.
apply solve_mut_min.

(* EvalGet *)
- idtac. intros x y s s0 Hsol Isol s1 d.
  red. red in Isol.
  intros [d' s1'] Heval'.
  subst.
  inversion Heval' as [? ? ? ? Hsol']; subst; clear Heval'.
  assert (Htmp := Isol _ Hsol').
  unfold d, s1. now subst.

(* EvalGet_x *)
- idtac. intros x f Heval Ieval.
  red in Ieval. red.
  intros f' Heval'.
  intros y s ds0 ds0' Hf Hf'.
  inversion Heval'; subst. now firstorder.

(* Wrap_Eval_x *)
- idtac. intros x f.
  induction t as [c | a k IH].
  + intros s [d s0] Hevalx Ievalx Hf.
    red. intros f' [d' s0'] Hwrap Hfun.
    inversion Hwrap; subst; clear Hwrap.
    now eapply wrap_rel_State_fun; eauto.
  + intros s [d1 s1] Hevalx Ievalx HfQue.
    red.
    intros f' [d' s1'] Hf'Que Hff'.
    inversion Hf'Que; subst.
    now eapply wrap_rel_State_fun; eauto.

(* Eval_rhs *)
- idtac. intros x f s ds0 Hevalx Ievalx Hwrap Iwrap.
  red. intros ds0' Heval.
  red in Iwrap.
  inversion Heval; subst; clear Heval.
  now eapply Iwrap; eauto.

(* Solve 0 *)
- idtac. intros x s Hstaxs.
  red. intros s0' Hsol'.
  now inversion Hsol'.

(* Solve 1 *)
- idtac.
  intros x d1 s s1 Hnstaxs s0 Heval Ieval cur new Hleq.
  red. intros s1' Hsol'.
  red in Ieval.
  inversion Hsol' as [| ? ? ? ? ? s0' Heval' | ? ? ? ? ? ? ? ? s0' Heval' ].
  + now subst s1'.
  + unfold s0' in Heval'.
    assert (Htmp := Ieval _ Heval').
    now inversion Htmp.
  + subst s2 s6.
    assert (Htmp := Ieval _ Heval').
    inversion Htmp.
    unfold new0, cur1, cur0 in H0.
    unfold new, cur in Hleq.
    subst d1.
    now rewrite H3, <- H6 in H0.

(* Solve 2 *)
- idtac.
  intros x d1 s s1 s3 s4 w.
  intros Hnstaxs s0 Heval Ieval.
  intros cur new Hnleq s2 Hwork Hsolall Isolall.
  red. intros s4' Hsol'.
  inversion Hsol' as [| ? ? ? ? ? s0' Heval' | ? ? ? ? ? ? ? ? s0' Heval' ].
  + now subst s4'.
  + unfold s0' in Heval'.
    assert (Htmp := Ieval _ Heval').
    subst s4' s5.
    inversion Htmp; clear Htmp.
    unfold new, cur in Hnleq.
    unfold new0, cur0, cur1 in H0.
    subst d.
    now rewrite H1, <- H4 in H0.
  + clear H Hnstaxs.
    assert (Htmp := Ieval _ Heval'); clear Heval Ieval.
    subst s4' s5.
    inversion Htmp; clear Htmp.
    unfold new, cur in Hnleq.
    unfold new0, cur0, cur1 in H0.
    rewrite H3, <- H5 in H0.
    assert (Hw : (w,s3) = (work,s7)).
    { rewrite Hwork, H1.
      subst s9.
      unfold s2, new, cur.
      unfold new0, cur0.
      now rewrite H3, H4, <- H5. }
    inversion Hw; subst s7 work; clear Hw.
    now eapply Isolall; eauto.

(* SolveAll 0 *)
- idtac.
  intros s. red. intros s0' Hsolall'.
  now inversion Hsolall'; subst.

(* SolveAll 1 *)
- idtac.
  intros x xs s s0 s1 Hsol Isol Hsolall Isolall.
  red. intros s1' Hsolall'.
  inversion Hsolall' as [| ? ? ? s1'' ? Hsol'' Hsolall''];
    subst; auto.
  red in Isol. assert (e := Isol _ Hsol''); subst s1''.
  red in Isolall. now apply Isolall; auto.
Qed.

(* a nicer reformulation of partial_functions_invar: *)
Lemma partial_functions :
  (forall x y s1 ds2 ds2',
     EvalGet x y s1 ds2 ->
     EvalGet x y s1 ds2' -> ds2 = ds2') /\
  (forall x y f f' s ds ds',
    EvalGet_x x f ->
    EvalGet_x x f' ->
    f y s ds -> f' y s ds' -> ds = ds') /\
  (forall x f f' t s1 ds2 ds2',
    Wrap_Eval_x x f t s1 ds2 ->
    Wrap_Eval_x x f' t s1 ds2' ->
    (forall y s ds ds',
       f y s ds -> f' y s ds' -> ds = ds') ->
    ds2 = ds2') /\
  (forall x s1 ds2 ds2',
    Eval_rhs x s1 ds2 -> Eval_rhs x s1 ds2' -> ds2 = ds2') /\
  (forall x s1 s2 s2',
    Solve x s1 s2 -> Solve x s1 s2' -> s2 = s2') /\
  (forall w s1 s2 s2',
    SolveAll w s1 s2 -> SolveAll w s1 s2' -> s2 = s2').
Proof.
pose proof partial_functions_invar as H.
unfold EvalGet_fun, EvalGet_x_fun, Wrap_Eval_x_fun,
  Eval_rhs_fun, Solve_fun, SolveAll_fun in H.
destruct H as [Hevalget [Hevalgetx [Hwrap [Heval [Hsol Hsolall] ] ] ] ].
split; [| split; [| split; [| split; [| split] ] ] ].
- intros; now eapply Hevalget; eauto.
- intros; now eapply Hevalgetx; [refine H | refine H0 | |]; eauto.
- intros; now eapply Hwrap; eauto.
- intros; now eapply Heval; eauto.
- intros; now eapply Hsol; eauto.
- intros; now eapply Hsolall; eauto.
Qed.

Section instrumentation.

(*Definition state := S.state.*)
Definition state' := SI.state'.

Definition projI (si : state') : state :=
  let '(sigma, infl, stable, _, _) := si in
    (sigma, infl, stable).

Definition sim (s : state) (si : state') := projI si = s.

(* lifted simulation relation *)
Definition simT
  (f : Var.t -> State state D.t)
  (f' : Var.t -> State state' D.t)
  := forall x s s1 s' s1' d d',
       sim s s' ->
       f x s = (d, s1) ->
       f' x s' = (d', s1') ->
       d = d' /\ sim s1 s1'.

(* lifted simulation relation *)
(*Definition simTrel
  (f : Var.t -> state -> D.t * state -> Prop)
  (f' : Var.t -> state' -> D.t * state' -> Prop)
  := forall x s s1 s' s1' d d',
       sim s s' ->
       f x s (d, s1) ->
       f' x s'(d', s1') ->
       d = d' /\ sim s1 s1'.*)

Definition simTrel
  (f : Var.t -> state -> D.t * state -> Prop)
  (f' : Var.t -> state' -> D.t * state' -> Prop)
  := forall x s s1 s' d,
       sim s s' ->
       f x s (d, s1) ->
       exists ds1',
       f' x s' ds1' /\
       let (d',s1') := ds1' in
       d = d' /\ sim s1 s1'.

Lemma sim_init : sim s_init SI.s_init.
easy.
Qed.

Ltac destruct_state s :=
  let sig := fresh "sigma" in
  let inf := fresh "infl" in
  let sta := fresh "stable" in
    destruct s as [ [sig inf] sta].

Ltac destruct_state' s :=
  let sig := fresh "sigma'" in
  let inf := fresh "infl'" in
  let sta := fresh "stable'" in
  let cal := fresh "called'" in
  let que := fresh "queued'" in
    destruct s as [ [ [ [sig inf] sta] cal] que].

Lemma sim_projI s' : sim (projI s') s'.
now destruct_state' s'.
Qed.
Hint Resolve sim_projI.

Lemma sim_prepare x s s' (H : sim s s') :
  sim (prepare x s) (SI.prepare x s').
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_prepare.

Lemma sim_getval s s' (H : sim s s') :
  getval s = SI.getval s'.
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_getval.

Lemma sim_setval x d s s' (H : sim s s') :
  sim (setval x d s) (SI.setval x d s').
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_setval.

Lemma sim_add_infl x y s s' (H : sim s s') :
  sim (add_infl x y s) (SI.add_infl x y s').
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_add_infl.

Lemma sim_is_stable x s s' (H : sim s s') :
  is_stable x s <-> SI.is_stable x s'.
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_is_stable.

Lemma sim_add_stable x s s' (H : sim s s') :
  sim (add_stable x s) (SI.add_stable x s').
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_add_stable.

Lemma sim_rem_called x s s' (H : sim s s') :
  sim s (SI.rem_called x s').
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_rem_called.

Lemma sim_rem_queued x s s' (H : sim s s') :
  sim s (SI.rem_queued x s').
Proof.
destruct_state s.
destruct_state' s'.
now inversion H; subst.
Qed.
Hint Resolve sim_rem_queued.

Lemma sim_handle_work s s' w (H : sim s s') :
  sim (handle_work w s) (SI.handle_work w s').
Proof.
revert s s' H. induction w as [| x xs IH].
- now firstorder.
- intros s s' Hsims. simpl.
  destruct_state s.
  destruct_state' s'.
  apply IH. now inversion Hsims.
Qed.
Hint Resolve sim_handle_work.

Lemma sim_extract_work x s s' w w' s0 s0' (H : sim s s') :
  (w, s0) = extract_work x s ->
  (w', s0') = SI.extract_work x s' ->
  w = w' /\ sim s0 s0'.
Proof.
destruct_state s.
destruct_state' s'.
intros Hw Hw'.
assert (Ew : w = w')
  by (inversion Hw; inversion Hw'; now inversion H; subst).
split; auto.
- subst w'. inversion H; subst.
  inversion Hw. inversion Hw'. now apply sim_handle_work.
Qed.

(* simulation 'invariants' *)
Definition EvalGet_sim x y s ds1
  := forall s',
       sim s s' ->
       exists ds1',
         let '(d,s1) := ds1 in
         let '(d',s1') := ds1' in
       SI.EvalGet Hpure x y s' (d',s1') /\
       d = d' /\ sim s1 s1'.

Definition EvalGet_x_sim (x : Var.t)
                         (f : Var.t -> state -> D.t * state -> Prop)
  := exists f', SI.EvalGet_x Hpure x f' /\ simTrel f f'.

Definition Wrap_Eval_x_sim x f t s ds1
  := forall f' s' l',
       sim s s' ->
       simTrel f f' ->
       SI.EvalGet_x Hpure x f' ->
       exists ds1' l1',
         let '(d,s1) := ds1 in
         let '(d',s1') := ds1' in
       SI.Wrap_Eval_x Hpure x f' t (s',l') (d',(s1',l1')) /\
       d = d' /\ sim s1 s1'.

Definition Eval_rhs_sim x s ds1
  := forall s',
       sim s s' ->
       exists ds1' l',
         let '(d,s1) := ds1 in
         let '(d',s1') := ds1' in
       SI.Eval_rhs Hpure x s' (d',(s1',l')) /\
       d = d' /\ sim s1 s1'.

Definition Solve_sim x s s1
  := forall s',
       sim s s' ->
       exists s1',
         SI.Solve Hpure x s' s1' /\ sim s1 s1'.

Definition SolveAll_sim (l : list Var.t) s s1
  := forall s',
       sim s s' ->
       exists s1',
         SI.SolveAll Hpure l s' s1' /\ sim s1 s1'.

Require Import Classical.
Require Import Epsilon.
Require Import ChoiceFacts.

Theorem simulation :
  (forall x y s1 ds2,
     EvalGet x y s1 ds2 -> EvalGet_sim x y s1 ds2) /\
  (forall x f,
    EvalGet_x x f -> EvalGet_x_sim x f) /\
  (forall x f t s1 ds2,
    Wrap_Eval_x x f t s1 ds2 ->
    Wrap_Eval_x_sim x f t s1 ds2) /\
  (forall x s1 ds2,
    Eval_rhs x s1 ds2 -> Eval_rhs_sim x s1 ds2) /\
  (forall x s1 s2,
    Solve x s1 s2 -> Solve_sim x s1 s2) /\
  (forall w s1 s2,
    SolveAll w s1 s2 -> SolveAll_sim w s1 s2).
Proof.
apply solve_mut_min.

(* EvalGet *)
- idtac.
  intros x y s s0 Hsol Hsolsim s1 d.
  red. intros s' Hsims.
  red in Hsolsim.
  elim (Hsolsim _ Hsims); intros s0' [Hsol' Hsims0].
  pose (d' := SI.getval s0' y).
  assert (e : d = d')
    by (subst d; unfold d'; now erewrite sim_getval).
  pose (s1' := SI.add_infl y x s0').
  assert (Hsims1 : sim s1 s1')
    by (subst s1; apply sim_add_infl; auto).
  exists (d',s1').
  split; [| split]; try apply SI.EvalGet0; easy.

(* Eval_x *)
- idtac.
  intros x f H H0.
  red. red in H0.
  pose (f' := fun y s' ds1' =>
          let '(d',s1') := ds1' in
          match (constructive_definite_descr_excluded_middle
                   constructive_definite_description
                   classic)
                  (f y (projI s') (d',(projI s1'))) with
            | right _ => False
            | left e =>
                let ds1'' :=
                    proj1_sig
                      (constructive_indefinite_description
                         _
                         (H0 y (projI s') (d',(projI s1'))
                             e s' (sim_projI s'))
                      ) in
                ds1'' = ds1'
          end).
  exists f'.
  split.
  + apply SI.EvalGet_x0.
    intros y s' [d' s0'] Hf'.
    unfold f' in Hf'.
    simpl in Hf'.
    destruct
      (constructive_definite_descr_excluded_middle
         constructive_definite_description classic
         (f y (projI s') (d', projI s0'))); try easy.
    assert (Hf'0 :=
            proj2_sig
              (constructive_indefinite_description
                 _
                 (H0 y (projI s') (d', projI s0') f0 s' (sim_projI s')))).
    now rewrite Hf' in Hf'0.
  + red. intros y s s0 s' d Hsims Hf.
    destruct (H0 _ _ _ Hf _ Hsims)
             as [ [d' s0'] [Heval' [? Hsims0] ] ]; subst d'.
    exists (d,s0').
    split; [| now auto].
    unfold f'.
    change (
        match
          constructive_definite_descr_excluded_middle
            constructive_definite_description classic
            (f y (projI s') (d, projI s0'))
        with
          | left e =>
              proj1_sig
                (constructive_indefinite_description
                   _
                   (H0 y (projI s') (d, projI s0')
                       e s' (sim_projI s'))) =
            (d, s0')
          | right _ => False
        end
      ).
    assert (Hfproj : f y (projI s') (d, projI s0')).
    { rewrite Hsims. red in Hsims0; now rewrite Hsims0. }
    destruct
      (constructive_definite_descr_excluded_middle
         constructive_definite_description classic
         (f y (projI s') (d, projI s0'))) as [p | n]; auto.
    assert (eHf : p = Hfproj) by (apply proof_irrelevance).
    subst p.
    set (p' :=
         proj1_sig
           (constructive_indefinite_description
              _
              (H0 y (projI s') (d, projI s0')
                  Hfproj s' (sim_projI s')))).
    assert (Hp' :=
            proj2_sig
              (constructive_indefinite_description
                 _
                 (H0 y (projI s') (d, projI s0') Hfproj s' (sim_projI s')))).
    simpl in Hp'. fold p' in Hp'.
    destruct p' as [pd' ps'].
    destruct Hp' as [Hp' _].
    now rewrite <- (proj1 (SI.partial_functions Hpure)
                     _ _ _ _ _ Heval' Hp').

(* Wrap_Eval_x *)
- idtac.
  intros x f.
  induction t as [a | q k IH].
  + idtac.
    intros s [d s0] Hevalx Hevalxsim Ht.
    destruct (wrap_rel_State_Ans_inv Ht); subst; clear Ht.
    red. intros f' s' l' Hsims Hsimf Hevalx'.
    exists (a,s'), l'.
    split; auto.
    apply SI.Wrap_Eval_x0; auto.
    now apply wrapAns.
  + intros s [d1 s1] Hevalx Hevalxsim Ht.
    destruct (wrap_rel_State_Que_inv Ht)
      as [d0 [s0 [Hf Hwrapf] ] ]; clear Ht.
    assert (Hwrapeval : Wrap_Eval_x_sim x f (k d0) s0 (d1, s1))
      by (apply IH; auto). clear IH.
    red. intros f' s' l' Hsims Hsimf Hevalx'.
    red in Hwrapeval.
    red in Hevalxsim.
    assert (Htmp := Hsimf _ _ _ _ _ Hsims Hf).
    destruct Htmp as [ [d' s0'] [Hf' [? Hsims0 ] ] ].
    subst d'.
    assert (Htmp := Hwrapeval f' s0' (l' ++ [(q,d0)]) Hsims0 Hsimf Hevalx').
    destruct Htmp as [ [d1' s1'] [l1' [Hwrapeval' [? Hsims1] ] ] ];
      clear Hwrapeval.
    subst d1'.
    exists (d1,s1'), l1'. split; auto.
    apply SI.Wrap_Eval_x0; auto.
    apply wrapQue with (d0:=d0) (s0:= (s0', l' ++ [(q,d0)])).
    * now apply SI.instrR0.
    * now inversion Hwrapeval'; subst.

(* Eval_rhs *)
- idtac.
  intros x f s [d s0] Hevalx Ievalx Hwrapx Iwrapx.
  red. intros s' Hsims.
  red in Ievalx. destruct Ievalx as [f' [Hevalx' Hsimff'] ].
  red in Iwrapx.
  destruct (Iwrapx f' _ [] Hsims) as [ [d' s0'] H]; auto.
  destruct H as [l1' [Hwrapeval' [e Hsims0] ] ].
  exists (d',s0'), l1'.
  split; [| split]; try apply (SI.Eval_rhs0 (f:=f')); easy.

(* Solve0 *)
- idtac.
  intros x s Hsta.
  red. intros s' Hsims.
  exists s'. split; auto.
  apply SI.Solve0. now eapply sim_is_stable; eauto.

(* Solve1 *)
- idtac.
  intros x d s s1 Hxnsta s0 Hevalrhs Hevalrhssim cur new Hleq.
  red. intros s' Hsims.
  assert (Hxnsta' : ~ SI.is_stable x s')
    by (contradict Hxnsta; now eapply sim_is_stable; eauto).
  red in Hevalrhssim.
  pose (s0' := SI.prepare x s').
  assert (Hsims0 : sim s0 s0') by (apply sim_prepare; auto).
  destruct (Hevalrhssim _ Hsims0) as [ [d' s1'] [l1' [Hevalrhs' [e Hsims1] ] ] ].
  clear Hevalrhssim. subst d'.
  pose (s1'' := SI.rem_called x s1').
  pose (cur' := SI.getval s1'' x).
  pose (new' := D.join cur' d).
  assert (Hsims1' : sim s1 s1'') by (apply sim_rem_called; auto).
  assert (Hle' : SI.D.Leq new' cur')
    by (unfold new',cur'; now erewrite <- sim_getval; eauto).
  exists s1''. split; auto.
  eapply (SI.Solve1); eauto.

(* Solve2 *)
- idtac.
  intros x d s s1 s4 s5 w.
  intros Hxnsta s0 Hevalrhs Hevalrhssim cur new Hleq s3 Hw Hsolall Hsolallsim.
  red. intros s' Hsims.
  assert (Hxnsta' : ~ SI.is_stable x s')
    by (contradict Hxnsta; now eapply sim_is_stable; eauto).
  red in Hevalrhssim.
  pose (s0' := SI.prepare x s').
  assert (Hsims0 : sim s0 s0') by (apply sim_prepare; auto).
  destruct (Hevalrhssim _ Hsims0) as [ [d' s1'] [l1' [Hevalrhs' [e Hsims1] ] ] ].
  clear Hevalrhssim. subst d'.
  pose (s2' := SI.rem_called x s1').
  pose (cur' := SI.getval s2' x).
  pose (new' := SI.D.join cur' d).
  assert (Hsims1' : sim s1 s2') by (apply sim_rem_called; auto).
  assert (Hnle' : ~ SI.D.Leq new' cur')
    by (unfold new',cur'; now erewrite <- sim_getval; eauto).
  pose (s3' := SI.setval x new' s2').
  assert (Hsims3 : sim s3 s3').
  { unfold s3, s3', new, new', cur, cur'.
    rewrite <- (sim_getval Hsims1'). now apply sim_setval. }
  destruct (SI.extract_work x s3') as (w', s4') eqn:Hw'.
  assert (Htmp1 : w = w' /\ sim s4 s4')
    by (eapply sim_extract_work; eauto).
  destruct Htmp1 as [? Hsims4]; subst w'.
  destruct (Hsolallsim _ Hsims4) as [s5' [Hsolall' Hsims5] ].
  exists s5'. split; auto.
  now eapply (SI.Solve2); eauto.

(* SolveAll0 *)
- idtac.
  intros s.
  red. intros s' Hsims.
  exists s'. split; auto.
  now eapply (SI.SolveAll0); eauto.

(* SolveAll1 *)
- idtac.
  intros x xs s s0 s1 Hsols Hsolsim Hsolall Hsolallsim.
  red. intros s' Hsims.
  destruct (Hsolsim _ Hsims) as [s0' [Hsols'  Hsims0] ].
  destruct (Hsolallsim _ Hsims0) as [s1' [Hsolall'  Hsims1] ].
  exists s1'. split; auto.
  now eapply (SI.SolveAll2); eauto.
Qed.

End instrumentation.

Theorem correctness s w :
  SolveAll w s_init s ->
  (forall z, In z w -> is_stable z s) /\
  (forall z v d,
     is_stable z s ->
     In (v,d) (deps (rhs z) (getval s)) ->
     is_stable v s) /\
  (forall z,
     is_stable z s -> D.Leq ([[rhs z]]* (getval s)) (getval s z)).
Proof.
intros Hsolall.
apply simulation in Hsolall.
assert (Htmp := Hsolall _ sim_init).
destruct Htmp as [s' [Hsolall' Hsims] ].
apply SI.correctness in Hsolall'.
destruct Hsolall' as [H0 [H1 H2] ].
split; [| split].
- clear - Hsims H0.
  intros. now eapply sim_is_stable; eauto.
- clear - Hsims H1.
  rewrite <- (sim_getval Hsims) in H1.
  intros z v d Hsta Hin. apply <- (sim_is_stable v Hsims).
  eapply H1; [| refine Hin].
  now apply (sim_is_stable z Hsims).
- clear - H2 Hsims.
  intros z Hsta.
  rewrite <- (sim_getval Hsims) in H2.
  now apply -> (sim_is_stable z Hsims) in Hsta; auto.
Qed.

Theorem exactness :
  has_uniq_lookup rhs ->
  is_monotone rhs ->
  forall mu w s,
    is_solution rhs mu ->
    SolveAll w s_init s ->
    leqF (getval s) mu.
Proof.
intros Huniq Hmon mu w s Hsolmu Hsolall.
apply simulation in Hsolall.
assert (Htmp := Hsolall _ sim_init).
destruct Htmp as [s' [Hsolall' Hsims] ].
apply SI.exactness with (mu:=mu) in Hsolall'; try rewrite <- rhs_same; auto.
now rewrite (sim_getval Hsims).
Qed.

Section termination.

Require Import Rels.
Require Import Arith.
Require Import Omega.

(* We prove termination of RLD on the two assumptions: *)
Variable Hasc : ascending_chain D.Leq.

Variable varSet : {s : VS.t | forall x, VS.In x s}.
Let V := proj1_sig varSet.
Let cardV := VS.cardinal V.

Definition varVec :
  {n : nat &
    {v : vector Var.t n &
       forall x, {i : {k : nat | k < n} | nth v i = x}}}.
Proof.
pose (l := VS.elements V).
destruct (vector_of l) as [n v] eqn:Hl.
exists n, v.
intros x.
assert (Hx : has v x).
{ assert (Htmp:= InA_has).
  specialize Htmp with (l:=l) (a:=x).
  rewrite Hl in Htmp.
  apply Htmp; clear Htmp.
  apply elements_1.
  now apply (proj2_sig varSet). }
exists (find Var.eq_dec Hx).
now apply nth_find.
Defined.

Definition phi (f : Var.t -> D.t) : vector D.t _ :=
  let v := projT1 (projT2 varVec) in map v f.

Definition psi (dv : vector D.t (projT1 varVec)) : Var.t -> D.t :=
  fun x =>
    let v := projT1 (projT2 varVec) in
    let H := projT2 (projT2 varVec) in
    let i := proj1_sig (H x) in
      nth dv i.

Lemma psi_phi f : psi (phi f) = f.
extensionality x.
unfold phi, psi.
rewrite nth_map.
f_equal.
now apply (proj2_sig (projT2 (projT2 varVec) x)).
Qed.

Lemma phi_inj f g : phi f = phi g -> f = g.
Proof.
intros H.
rewrite <- (psi_phi f).
rewrite <- (psi_phi g).
now f_equal.
Qed.

(* TODO : rename lemmas *)
Let R_phi (R : relation D.t) : relation (Var.t -> D.t)
  := fun f g => lp_vector R (phi f) (phi g).

Lemma leqF_sub_inverse_lp_vector f g :
  leqF f g -> R_phi D.Leq f g.
Proof.
intros H.
unfold R_phi.
apply lp_vector_nth.
intros i.
unfold phi.
now rewrite !nth_map.
Qed.

Lemma lem4 f g :
  strict (inv (leqF (X:=Var.t))) f g ->
  strict (inv (lp_vector D.Leq (n:=projT1 varVec)))
         (phi f) (phi g).
Proof.
intros [H ne].
unfold inv, strict.
unfold inv, strict in H.
split; [now apply leqF_sub_inverse_lp_vector |
        intros e; now apply phi_inj in e].
Qed.

Lemma lem4_bis :
  inclusion
    _
    (strict (inv (leqF (X:=Var.t))))
    (fun f g =>
       (strict (inv (lp_vector D.Leq (n:=projT1 varVec))))
         (phi f)
         (phi g)).
Proof.
unfold inclusion. intros f g.
now apply lem4.
Qed.

Lemma prec_1_wf :
  well_founded (strict (inv (leqF (X:=Var.t)))).
Proof.
pose (H := fun n => asc_lp_vector (D.eq_dec) (n:=n) Hasc).
unfold ascending_chain in H.
specialize H with (projT1 varVec).
apply wf_inverse_image with (f:=phi) in H.
now apply (wf_incl _ _ _ lem4_bis).
Qed.

Lemma subset_V s : VS.Subset s V.
Proof.
intros x _.
now apply (proj2_sig varSet).
Qed.
Hint Resolve subset_V.

Lemma le_cardVar s : VS.cardinal s <= cardV.
Proof.
now apply VSetProps.subset_cardinal; auto.
Qed.
Hint Resolve le_cardVar.

Lemma cardVar_equal_V s :
  VS.cardinal s = cardV ->
  VS.Equal s V.
Proof.
intros H.
apply subset_antisym; [now apply subset_V |].
intros x Hx.
destruct (VSetProps.In_dec x s) as [e | n]; auto.
assert (Hcard : VSet.cardinal s < VSet.cardinal V)
  by (apply VSetProps.subset_cardinal_lt with x; auto).
rewrite H in Hcard.
now apply Lt.lt_irrefl in Hcard.
Qed.

Definition strictS (R : relation VS.t) : relation VS.t :=
  fun s t => R s t /\ ~ VS.Equal s t.

Lemma card_Acc n :
  forall s,
    n + VS.cardinal s = cardV ->
    Acc (strictS (inv (VS.Subset))) s.
Proof.
apply (lt_wf_ind n); clear n.
intros n IH.
intros s H.
constructor.
intros t Ht.
unfold strictS, inv in Ht.
pose (d := VS.diff t s).
assert (Hd : ~ VS.Empty d).
{ clear - Ht.
  destruct Ht as [Hst Hne].
  contradict Hne. now fsetdec. }
assert (Hdcard : VS.cardinal d <> 0).
{ contradict Hd. now apply VSetProps.cardinal_inv_1. }
assert (Hdcardpos : VS.cardinal d > 0).
{ unfold gt. now apply neq_0_lt; auto. }
assert (Et : VS.Equal t (VS.union s d)) by fsetdec.
assert (Hs' : VS.cardinal t = VS.cardinal s + VS.cardinal d)
  by (rewrite Et; apply VSetProps.union_cardinal; now fsetdec).
pose (m := n - VS.cardinal d).
assert (Hdn : VS.cardinal d <= n).
{ apply plus_le_reg_l with (VS.cardinal s).
  rewrite (plus_comm _ n), H, <- Hs'.
  now auto. }
assert (Hm : m < n) by (apply lt_minus; auto).
assert (Hm1 : m + VS.cardinal t = cardV)
  by (unfold m; rewrite Hs', <- H; omega).
now apply IH with m.
Qed.

Lemma prec_2_wf : well_founded (strictS (inv VS.Subset)).
Proof.
unfold well_founded.
intros s.
pose (n := cardV - VS.cardinal s).
assert (Hcard : VS.cardinal s <= cardV) by auto.
assert (H : n + VS.cardinal s = cardV) by (unfold n; omega).
now apply card_Acc with n.
Qed.

Definition sigma_fun (sigma : Sigma.t D.t) : Var.t -> D.t :=
  fun x =>
    match Sigma.find x sigma with
      | Some d => d
      | None => D.bot
    end.

Lemma getval_sigma sigma infl stable :
  getval (sigma, infl, stable) = sigma_fun sigma.
Proof.
easy.
Qed.

Definition prec_sigma : relation (Sigma.t D.t) :=
  fun sigma1 sigma2 =>
    strict (inv (leqF (X:=Var.t))) (sigma_fun sigma1) (sigma_fun sigma2).

Lemma prec_sigma_irrefl s : ~ prec_sigma s s.
Proof.
now firstorder.
Qed.
Hint Resolve prec_sigma_irrefl.

Lemma prec_sigma_trans : transitive _ prec_sigma.
Proof.
intros s1 s2 s3.
unfold prec_sigma, strict, inv.
intros [H10 H11].
intros [H20 H21].
split.
- now eapply leqF_trans; eauto.
- contradict H11. rewrite <- H11 in H20.
  now apply leqF_antisym.
Qed.

Lemma prec_sigma_wf : well_founded prec_sigma.
Proof.
unfold prec_sigma.
apply wf_inverse_image with (f:=sigma_fun).
now apply prec_1_wf.
Qed.

Definition prec_stable : relation VS.t :=
  fun s1 s2 => strictS (inv VS.Subset) s1 s2.

Lemma prec_stable_irrefl s : ~ prec_stable s s.
Proof.
now firstorder.
Qed.
Hint Resolve prec_stable_irrefl.

Lemma prec_stable_trans : transitive _ prec_stable.
Proof.
intros s1 s2 s3.
unfold prec_stable, strict, inv.
intros [H10 H11].
intros [H20 H21].
split.
- now fsetdec.
- contradict H11. now fsetdec.
Qed.

Lemma prec_stable_wf : well_founded prec_stable.
Proof.
refine prec_2_wf.
Qed.

Definition prec_ss := lexprod prec_sigma prec_stable.

Lemma prec_ss_wf : well_founded prec_ss.
Proof.
apply lexprod_wf;
  [now apply prec_sigma_wf | now apply prec_stable_wf].
Qed.

Definition forget_infl (s : state) :=
  let '(sigma, _, stable) := s in (sigma, stable).

Definition prec_state : relation state :=
  fun s1 s2 => prec_ss (forget_infl s1) (forget_infl s2).

Lemma prec_state_wf : well_founded prec_state.
Proof.
unfold prec_state.
apply wf_inverse_image with (f:=forget_infl).
now apply prec_ss_wf.
Qed.

Local Infix "<" := prec_state (at level 70).

Lemma prec_state_irrefl s : ~ s < s.
Proof.
unfold prec_state, prec_ss.
destruct_state s. simpl.
intros H. inversion H; subst; now firstorder.
Qed.
Hint Resolve prec_state_irrefl.

Lemma prec_state_trans : transitive _ prec_state.
Proof.
intros s1 s2 s3.
unfold prec_state, prec_ss.
destruct_state s1.
destruct_state s2.
destruct_state s3.
simpl.
intros H1 H2.
inversion H1 as [? ? ? ? H10 | ? ? ? H10]; subst; clear H1.
- inversion H2 as [? ? ? ? H20 | ? ? ? H20]; subst; clear H2.
  + left. now eapply prec_sigma_trans; eauto.
  + now left.
- inversion H2 as [? ? ? ? H20 | ? ? ? H20]; subst; clear H2.
  + now left.
  + right. now eapply prec_stable_trans; eauto.
Qed.

Definition eq_state : relation state :=
  fun s1 s2 =>
    let '(sigma1, _, stable1) := s1 in
    let '(sigma2, _, stable2) := s2 in
      sigma1 = sigma2 /\ stable1 = stable2.

Lemma eq_state_refl : reflexive _ eq_state.
Proof.
intros s; now destruct_state s.
Qed.
Hint Resolve eq_state_refl.

Lemma eq_state_sym : symmetric _ eq_state.
Proof.
intros s1 s2.
destruct_state s1.
destruct_state s2.
intros [? ?].
now subst.
Qed.
Hint Resolve eq_state_sym.

Lemma eq_state_trans : transitive _ eq_state.
Proof.
intros s1 s2 s3.
destruct_pose_state s1.
destruct_pose_state s2.
destruct_pose_state s3.
intros H1 H2.
destruct H1 as [H10 H11]; destruct H2 as [H20 H21].
red. split; congruence.
Qed.

Definition precEq_state : relation state
  := fun s1 s2 => prec_state s1 s2 \/ eq_state s1 s2.

Local Infix "<=" := precEq_state (at level 70).

Lemma precEq_state_refl : reflexive _ precEq_state.
Proof.
now right; auto.
Qed.
Hint Resolve precEq_state_refl.

Lemma prec_eq_state s1 s2 s3 :
  s1 < s2 -> eq_state s2 s3 -> s1 < s3.
Proof.
destruct_state s1.
destruct_state s2.
destruct_state s3.
intros H1 H2. destruct H2.
inversion H1; subst; clear H1.
- now left.
- now right.
Qed.

Lemma eq_prec_state s1 s2 s3 :
  eq_state s1 s2 -> s2 < s3 -> s1 < s3.
Proof.
destruct_state s1.
destruct_state s2.
destruct_state s3.
intros H1 H2. destruct H1.
inversion H2; subst; clear H2.
- now left.
- now right.
Qed.

Lemma prec_precEq_state s1 s2 s3 :
  s1 < s2 -> s2 <= s3 -> s1 < s3.
Proof.
intros H1 H2. destruct H2 as [H2 | H2].
- now eapply prec_state_trans; eauto.
- now eapply prec_eq_state; eauto.
Qed.

Lemma precEq_prec_state s1 s2 s3 :
  s1 <= s2 -> s2 < s3 -> s1 < s3.
Proof.
intros H1 H2. destruct H1 as [H1 | H1].
- now eapply prec_state_trans; eauto.
- now eapply eq_prec_state; eauto.
Qed.

Lemma precEq_state_trans : transitive _ precEq_state.
Proof.
intros s1 s2 s3.
intros H1 H2.
destruct H1 as [H1 | H1].
- left. now eapply prec_precEq_state; eauto.
- destruct H2 as [H2 | H2].
  + left. now eapply eq_prec_state; eauto.
  + right. now eapply eq_state_trans; eauto.
Qed.

Lemma eq_precEq_state s1 s2 s3 :
  eq_state s1 s2 -> s2 <= s3 -> s1 <= s3.
Proof.
intros H1 H2. destruct H2 as [H2 | H2].
- left. now eapply eq_prec_state; eauto.
- right. now eapply eq_state_trans; eauto.
Qed.

Lemma precEq_eq_state s1 s2 s3 :
  s1 <= s2 -> eq_state s2 s3 -> s1 <= s3.
Proof.
intros H1 H2. destruct H1 as [H1 | H1].
- left. now eapply prec_eq_state; eauto.
- right. now eapply eq_state_trans; eauto.
Qed.

Lemma eq_state_add_infl x y s :
  eq_state (add_infl x y s) s.
Proof.
now destruct_state s.
Qed.
Local Hint Resolve eq_state_add_infl.

Lemma prec_prepare x s :
  ~ is_stable x s -> prepare x s < s.
Proof.
destruct_state s.
intros H. simpl in *.
unfold prec_state, prec_ss.
right.
unfold prec_stable, strictS, inv; simpl.
split; now fsetdec.
Qed.

Lemma precEq_invariant :
  (forall x y s1 ds2,
     EvalGet x y s1 ds2 ->
     let (d,s2) := ds2 in s2 <= s1) /\
  (forall x f,
     EvalGet_x x f ->
     forall y s1 ds2,
       f y s1 ds2 ->
       let (d,s2) := ds2 in s2 <= s1) /\
  (forall x f t s1 ds2,
     Wrap_Eval_x x f t s1 ds2 ->
     let (d,s2) := ds2 in s2 <= s1) /\
  (forall x s1 ds2,
     Eval_rhs x s1 ds2 ->
     let (d,s2) := ds2 in s2 <= s1) /\
  (forall x s1 s2,
     Solve x s1 s2 -> s2 <= s1) /\
  (forall w s1 s2,
     SolveAll w s1 s2 -> s2 <= s1).
Proof.
apply solve_mut_min.

(* EvalGet *)
- idtac. intros x y s s0 _ Isol s1 d.
  subst s1.
  now apply eq_precEq_state with (s2:=s0); auto.

(* EvalGet_x *)
- idtac. easy.

(* Wrap_Eval_x *)
- idtac. intros x f.
  induction t as [c | a k IH].
  + intros s [d s0] _ Ievalx Ht.
    now destruct (wrap_rel_State_Ans_inv Ht); subst.
  + intros s [d1 s1] Hevalx Ievalx Ht.
    destruct (wrap_rel_State_Que_inv Ht)
      as [d0 [s0 [Hf Hwrapf] ] ]; clear Ht.
    assert (H := Ievalx _ _ _ Hf).
    simpl in H.
    assert (H1 : s1 <= s0)
      by (eapply (@IH _ _ (d1,s1)); eauto).
    now eapply precEq_state_trans; eauto.

(* Eval_rhs *)
- idtac. now firstorder.

(* Solve 0 *)
- idtac. now auto.

(* Solve 1 *)
- idtac.
  intros x d s s1 Hnstaxs s0 _ Ievalrhs cur Hleq.
  assert (H : s0 < s) by (apply prec_prepare; auto).
  left. now eapply precEq_prec_state; eauto.

(* Solve 2 *)
- idtac.
  intros x d s s1 s3 s4 w.
  intros Hnstaxs s0 _ Ievalrhs cur new Hnleq s2 Hw _ Isolveall.
  assert (H : s0 < s) by (apply prec_prepare; auto).
  clear Hnstaxs.
  apply (precEq_state_trans Isolveall); clear Isolveall.
  left.
  apply (precEq_prec_state (s2:=s0)); auto.
  apply (@precEq_state_trans s3 s1 s0); auto.
  clear - Hnleq Hw.
  assert (Hwspec := extract_work_spec Hw); clear Hw.
  assert (Hvals1 : forall z, x <> z -> getval s3 z = getval s1 z).
  { clear - Hwspec. intros z ne.
    destruct_state s1; destruct_state s3.
    destruct Hwspec as [_ [H _ ] ].
    simpl in *; subst. now rewrite add_neq_o. }
  assert (Hvals1x : getval s3 x = D.join cur d).
  { clear - Hwspec.
    destruct_state s1; destruct_state s3.
    destruct Hwspec as [_ [H _ ] ].
    simpl in *; subst. now rewrite add_eq_o. }
  left. unfold prec_state, prec_ss.
  destruct_state s1.
  destruct_state s3.
  left. unfold prec_sigma, strict, inv.
  rewrite !getval_sigma in Hvals1.
  rewrite getval_sigma in Hvals1x.
  split.
  + intros u. destruct (Var.eq_dec x u) as [e | n].
    * subst u. now rewrite Hvals1x.
    * now rewrite Hvals1; auto.
  + contradict Hnleq. unfold cur.
    now rewrite getval_sigma, <- Hnleq, Hvals1x.

(* SolveAll 0 *)
- idtac. now auto.

(* SolveAll 1 *)
- idtac. intros x xs s s0 s1 _ Isolve _ Isolveall.
  now eapply precEq_state_trans; eauto.
Qed.

Lemma prec_call_SolveAll x s d s1 s3 w :
  ~ is_stable x s ->
  let s0 := prepare x s in
  Eval_rhs x s0 (d, s1) ->
  let cur := getval s1 x in
  let new := D.join cur d in
  ~ D.Leq new cur ->
  let s2 := setval x new s1 in
  (w, s3) = extract_work x s2 ->
  s3 < s.
Proof.
intros Hnstaxs s0 Evalrhs cur new Hnleq s2 Hw.
assert (H : s0 < s) by (apply prec_prepare; auto).
clear Hnstaxs.
apply precEq_invariant in Evalrhs.
apply (@prec_state_trans s3 s0 s); auto. clear H.
apply (prec_precEq_state (s2:=s1)); auto. clear Evalrhs.
assert (Hwspec := extract_work_spec Hw); clear Hw.
assert (Hvals1 : forall z, x <> z -> getval s3 z = getval s1 z).
{ clear - Hwspec. intros z ne.
  destruct_state s1; destruct_state s3.
  destruct Hwspec as [_ [H _ ] ].
  simpl in *; subst. now rewrite add_neq_o. }
assert (Hvals1x : getval s3 x = D.join cur d).
{ clear - Hwspec.
  destruct_state s1; destruct_state s3.
  destruct Hwspec as [_ [H _ ] ].
  simpl in *; subst. now rewrite add_eq_o. }
unfold prec_state, prec_ss.
destruct_state s1.
destruct_state s3.
left. unfold prec_sigma, strict, inv.
rewrite !getval_sigma in Hvals1.
rewrite getval_sigma in Hvals1x.
split.
+ intros u. destruct (Var.eq_dec x u) as [e | n].
  * subst u. now rewrite Hvals1x.
  * now rewrite Hvals1; auto.
+ contradict Hnleq. unfold cur.
  now rewrite getval_sigma, <- Hnleq, Hvals1x.
Qed.

Theorem termination :
  forall x s1, exists s2, Solve x s1 s2.
Proof.
intros x s; revert s x.
apply (@well_founded_ind _ _ prec_state_wf
        (fun s => forall x, exists s2, Solve x s s2)); auto.
intros s IH x.
destruct (is_stable_dec x s) as [Hstaxs | Hnstaxs];
  [exists s; now apply Solve0 |].
pose (s0 := prepare x s).
assert (Hprecs0 : s0 < s) by (apply prec_prepare; auto).
assert (Heval: forall y s1,
                 s1 < s -> exists ds2, EvalGet x y s1 ds2).
{ intros y s1 Hprecs1.
  destruct (IH _ Hprecs1 y) as [s2 Hs2].
  pose (s3 := add_infl y x s2).
  pose (d := getval s2 y).
  exists (d, s3). now apply EvalGet0 with (s0:=s2). }
pose (f := (fun y s' ds1' => EvalGet x y s' ds1')
           : Var.t -> state -> D.t * state -> Prop).
assert (Hevalxf : EvalGet_x x f).
{ apply EvalGet_x0.
  intros y q0 [d q2] Hf. now firstorder. }
assert (H : forall t q,
              q < s -> exists ds1, Wrap_Eval_x x f t q ds1).
{ induction t as [c | a k IHt].
  - intros q _. exists (c,q).
    apply Wrap_Eval_x0; auto.
    now apply wrapAns.
  - intros q Hprecq.
    destruct (Heval a _ Hprecq) as [ [d0' s0'] Heval0'].
    assert (Hf : f a q (d0',s0')) by (unfold f; auto).
    assert (Hprecs0' : s0' < s).
    { apply precEq_prec_state with (s2:=q); auto.
      unfold f in Hf. now apply precEq_invariant in Hf. }
    destruct (IHt d0' _ Hprecs0') as [ [d1 s1] Hwrap']; clear IHt.
    exists (d1,s1). apply Wrap_Eval_x0; auto.
    eapply wrapQue; eauto. now inversion Hwrap'; subst. }
 destruct (H (rhs x) _ Hprecs0) as [ [d s1] Hwrapx]; clear H.
assert (Hevalrhs : Eval_rhs x s0 (d,s1))
  by (apply Eval_rhs0 with (f:=f); auto).
pose (cur := getval s1 x).
pose (new := D.join cur d).
destruct (D.eq_dec new cur) as [e | n].
- assert (Hleq : D.Leq new cur) by now rewrite <- e.
  exists s1. now apply Solve1 with (d:=d); auto.
- assert (Hnleq : ~ D.Leq new cur).
  { contradict n. unfold new. now apply D.LeqAntisym. }
  pose (s2 := setval x new s1).
  destruct (extract_work x s2) as [w s3] eqn: Hwork.
  symmetry in Hwork.
  assert (Hprecs3 : s3 < s)
    by (eapply prec_call_SolveAll; eauto).
  assert (H : forall l q, q < s -> exists s4, SolveAll l q s4).
  { induction l as [| y ys IHl].
    - intros q _. exists q. now apply SolveAll0.
    - intros q Hprecq.
      destruct (IH _ Hprecq y) as [s3' Hsol'].
      assert (Hprecs3' : s3' < s).
      { apply precEq_prec_state with (s2:=q); auto.
        now apply precEq_invariant in Hsol'. }
      destruct (IHl _ Hprecs3') as [s4 Hsolall']; clear IHl.
      exists s4. now eapply SolveAll2; eauto. }
  destruct (H w _ Hprecs3) as [s4 Hsolall].
  exists s4. now eapply Solve2; eauto.
Qed.

End termination.

End algorithm.

End SolverRLD.

(* TODO this should go elsewhere actually *)
Module SolverRLDcomplete (Sys : CSys)
                         (VSet : SetsTypeOn (Sys.V))
                         (VMap : MapsTypeOn (Sys.V)).

Include SolverRLD (Sys)(VSet)(VMap).

Section exactness.

Variable Hpure : forall x, is_pure (F x).
(*Definition rhs x : Tree Var.t D.t D.t := proj1_sig (Hpure x).*)

Definition is_local_solution
             (X X' : VS.t) (sigma : Var.t -> Sys.D.t)
  := (forall z, VS.In z X -> VS.In z X') /\
     (forall z v d,
        VS.In z X' ->
        In (v,d) (deps (rhs Hpure z) sigma) ->
        VS.In v X') /\
     (forall z,
        VS.In z X' ->
        D.Leq ([[rhs Hpure z]]* sigma) (sigma z)).

Definition sol_ext X X' sigma (H : is_local_solution X X' sigma)
  : Var.t -> Sys.D.t
  := fun z =>
       match VSetProps.In_dec z X' with
           | left _ => sigma z
           | right _ => Sys.D.top
       end.

Import Defs.

Lemma sol_ext_is_solution
        X X' sigma (H : @is_local_solution X X' sigma) :
  is_solution (rhs Hpure) (@sol_ext X X' sigma H).
Proof.
destruct H as [H [H0 H1] ].
intros x.
unfold sol_ext at 2.
case (VSetProps.In_dec x X') as [e | n]; auto.
- rewrite <- (@deps_val_compat _ _ _ _ _ sigma _ eq_refl).
  + now apply H1.
  + intros [v d] i.
    unfold sol_ext; simpl.
    now case (VSetProps.In_dec v X'); firstorder.
Qed.

End exactness.
End SolverRLDcomplete.


(*
  This file showcases the use of packages.
 *)

From Coq Require Import Utf8.
Set Warnings "-ambiguous-paths,-notation-overridden,-notation-incompatible-format".
From mathcomp Require Import ssrnat ssreflect ssrfun ssrbool ssrnum eqtype choice seq.
Set Warnings "ambiguous-paths,notation-overridden,notation-incompatible-format".
From extructures Require Import ord fset fmap.
From Crypt Require Import RulesStateProb Package Prelude.
Import PackageNotation.

From Equations Require Import Equations.
Require Equations.Prop.DepElim.

Set Bullet Behavior "Strict Subproofs".
Set Default Goal Selector "!".
Set Primitive Projections.

#[local] Open Scope package_scope.

Definition I0 : Interface :=
  [interface val #[3] : 'nat → 'nat].

Definition I1 : Interface :=
  [interface
    val #[0] : 'bool → 'bool ;
    val #[1] : 'nat → 'unit ;
    val #[2] : 'unit → 'bool
  ].

Definition I2 : Interface :=
  [interface
    val #[4] : 'bool × 'bool → 'bool
  ].

Definition pempty : package fset0 [interface] [interface] :=
  [package].

Definition p0 : package fset0 [interface] I0 :=
  [package
    def #[3] (x : 'nat) : 'nat {
      ret x
    }
  ].

Definition p1 : package fset0 [interface] I1 :=
  [package
    def #[0] (z : 'bool) : 'bool {
      ret z
    } ;
    def #[1] (y : 'nat) : 'unit {
      ret Datatypes.tt
    } ;
    def #[2] (u : 'unit) : 'bool {
      ret false
    }
  ].

Definition foo (x : bool) : code fset0 [interface] bool_choiceType :=
  {code let u := x in ret u}.

Definition bar (b : bool) : code fset0 [interface] nat_choiceType :=
  {code if b then ret 0 else ret 1}.

Definition p2 : package fset0 [interface] I2 :=
  [package
    def #[4] (x : 'bool × 'bool) : 'bool {
      let '(u,v) := x in ret v
    }
  ].

Definition test₁ :
  package
    [fset (chNat; 0)]
    [interface val #[0] : 'nat → 'nat]
    [interface
      val #[1] : 'nat → 'nat ;
      val #[2] : 'unit → 'unit
    ]
  :=
  [package
    def #[1] (x : 'nat) : 'nat {
      getr ('nat; 0) (λ n : nat,
        opr (0, ('nat, 'nat)) n (λ m,
          putr ('nat; 0) m (ret m)
        )
      )
    } ;
    def #[2] (_ : 'unit) : 'unit {
      putr ('nat; 0) 0 (ret Datatypes.tt)
    }
  ].

Definition sig := {sig #[0] : 'nat → 'nat }.

#[program] Definition test₂ :
  package
    [fset ('nat; 0)]
    [interface val #[0] : 'nat → 'nat ]
    [interface
      val #[1] : 'nat → 'nat ;
      val #[2] : 'unit → 'option ('fin 2) ;
      val #[3] : {map 'nat → 'nat} → 'option 'nat
    ]
  :=
  [package
    def #[1] (x : 'nat) : 'nat {
      n ← get ('nat ; 0) ;;
      m ← op sig ⋅ n ;;
      n ← get ('nat ; 0) ;;
      m ← op sig ⋅ n ;;
      put ('nat ; 0) := m ;;
      ret m
    } ;
    def #[2] (_ : 'unit) : 'option ('fin 2) {
      put ('nat ; 0) := 0 ;;
      ret (Some (gfin 1))
    } ;
    def #[3] (m : {map 'nat → 'nat}) : 'option 'nat {
      ret (getm m 0)
    }
  ].

(* Testing the #import notation *)
Definition test₃ :
  package
    fset0
    [interface
      val #[0] : 'nat → 'bool ;
      val #[1] : 'bool → 'unit
    ]
    [interface
      val #[2] : 'nat → 'nat ;
      val #[3] : 'bool × 'bool → 'bool
    ]
  :=
  [package
    def #[2] (n : 'nat) : 'nat {
      #import {sig #[0] : 'nat → 'bool } as f ;;
      #import {sig #[1] : 'bool → 'unit } as g ;;
      b ← f n ;;
      if b then
        g false ;;
        ret 0
      else ret n
    } ;
    def #[3] ('(b₀,b₁) : 'bool × 'bool) : 'bool {
      ret b₀
    }
  ].

(** Information is redundant between the export interface and the package
    definition, so it can safely be skipped.
*)
Definition test₄ : package fset0 [interface] _ :=
  [package
    def #[ 0 ] (n : 'nat) : 'nat {
      ret (n + n)%N
    } ;
    def #[ 1 ] (b : 'bool) : 'nat {
      if b then ret 0 else ret 13
    }
  ].

Definition ℓ : Location := ('nat ; 0).

#[tactic=notac] Equations? foo : code fset0 [interface] 'nat :=
  foo := {code
    n ← get ℓ ;;
    ret n
  }.
Proof.
  ssprove_valid.
Abort.


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

Local Open Scope Z_scope.

Section SpecLow.

  Definition invalidate_block_spec0 (addr: Z64) (adt: RData) : option RData :=
    match addr with
    | VZ64 _addr =>
      when adt == barrier_spec  adt;
      rely is_int64 _addr;
      when adt == stage2_tlbi_ipa_spec (VZ64 _addr) (VZ64 4096) adt;
      Some adt
     end
    .

End SpecLow.