(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION                                                        *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import useless.
Require Import inaccessible.
Require Import unitrules.
Require Import emptyrules.

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

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INITIAL THEOREMS                                     *)
(* --------------------------------------------------------------------- *)

Section Simplification.

Variables terminal non_terminal: Type.
Notation sf := (list (non_terminal + terminal)).
Notation sentence := (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).
Notation term_lift':= ((terminal_lift non_terminal') terminal).

Theorem no_useless_symbols:
forall g: cfg terminal non_terminal,
non_empty g ->
exists g': cfg terminal non_terminal,
g_equiv g' g /\
has_no_useless_symbols g'.
Proof.
intros g.
exists (g_use g).
apply g_use_correct.
exact H.
Qed.

Theorem no_inaccessible_symbols:
forall g: cfg terminal non_terminal,
exists g': cfg terminal non_terminal,
g_equiv g' g /\
has_no_inaccessible_symbols g'.
Proof.
intros g.
exists (g_acc g).
apply g_acc_correct.
Qed.

Theorem no_unit_rules:
forall g: cfg terminal non_terminal,
exists g': cfg terminal non_terminal,
g_equiv g' g /\
has_no_unit_rules g'.
Proof.
intros g.
exists (g_unit g).
apply g_unit_correct.
Qed.

Theorem no_empty_rules:
forall g: cfg non_terminal terminal,
exists g': cfg (non_terminal' non_terminal) terminal,
g_equiv g' g /\
(generates_empty g -> has_one_empty_rule g') /\
(~ generates_empty g -> has_no_empty_rules g') /\
start_symbol_not_in_rhs g'.
Proof.
intros g.
exists (g_emp' g).
apply g_emp'_correct.
Qed.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - INACCESSIBLE AND USELESS SYMBOLS                     *)
(* --------------------------------------------------------------------- *)

Lemma g_acc_preserves_use:
forall g: cfg _ _,
forall s: non_terminal + terminal,
useful g s ->
accessible g s ->
useful (g_acc g) s.
Proof.
intros g s H1 H2.
destruct s.
- unfold useful in H1.
  unfold useful.
  destruct H1 as [s H3].
  exists s.
  apply derives_sflist in H3.
  destruct H3 as [l [H4 [H5 H6]]].
  assert (H7: length l >= 2 \/ length l < 2) by omega.
  destruct H7 as [H7 | H7].
  + assert (H7':=H7).
    apply sflist_rules with (g:=g) in H7.
    destruct H7 as [H7 _].
    specialize (H7 H4).
    apply derives_sflist.
    exists l.
    split.
    * {
      apply sflist_rules.
      - exact H7'.
      - intros i H8.
        specialize (H7 i H8).
        destruct H7 as [left [right [s0 [s' [H10 [H11 H12]]]]]].
        exists left, right, s0, s'.
        split.
        + exact H10.
        + split.
          * exact H11.
          * simpl.
            {
            apply Lift_acc.
            - exact H12.
            - unfold accessible in H2.
              destruct H2 as [s2 [s3 H13]].
              assert (H20: derives g [inl n] (s0 ++ inl left :: s')).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H4.
                apply sflist_app_r in H4.
                exists (firstn (S i) l).
                split.
                - exact H4.
                - split.
                  + rewrite hd_first.
                    * exact H5.
                    * omega.
                  + rewrite <- H10.
                    apply last_first_nth.
                    omega.
                }
              assert (H21: derives g [inl (start_symbol g)] (s2++s0++inl left::s'++s3)).
                {
                replace (s2 ++ inl n :: s3) with (s2 ++ [inl n] ++ s3) in H13.
                - apply derives_subs with (g:=g) (s1:=[inl (start_symbol g)]) (s2:=s2) (s3:=[inl n]) (s3':=(s0 ++ inl left :: s')) (s4:=s3) in H13.
                  + rewrite <- app_assoc in H13.
                    exact H13.
                  + exact H20.
                - simpl.
                  reflexivity.
                }
              exists (s2++s0), (s'++s3).
              rewrite <- app_assoc.
              exact H21.
            }
      }
    * {
      split.
      - exact H5.
      - exact H6.
      }
  + destruct l as [| s0 l].
    * simpl in H5.
      inversion H5.
    * {
      replace (s0::l) with ([s0]++l) in H7.
      - rewrite app_length in H7.
        simpl in H7.
        assert (H8: length l = 0) by omega.
        apply length_zero in H8.
        subst.
        simpl in H5.
        rewrite H5 in H6.
        simpl in H6.
        destruct s.
        + simpl in H6.
          inversion H6.
        + replace (t::s) with ([t]++s) in H6.
          * rewrite map_app in H6.
            inversion H6.
          * simpl.
            reflexivity.
      - simpl.
        reflexivity.
      }
- simpl.
  auto.
Qed.

Lemma acc_appears:
forall g: cfg _ terminal,
forall n: non_terminal,
useful g (inl (start_symbol g)) ->
accessible g (inl n) ->
appears g (inl n).
Proof.
intros g n H10 H.
unfold accessible in H.
destruct H as [s1 [s2 H2]].
apply exists_rule' in H2.
destruct H2 as [H2 | H2].
- destruct H2 as [H2 [_ _]].
  inversion H2.
  apply (useful_exists).
  exact H10.
- destruct H2 as [left [right [H3 H4]]].
  exists left, right.
  split.
  + exact H3.
  + right.
    exact H4.
Qed.

Lemma in_g_use_acc_is_use:
forall g: cfg non_terminal terminal,
forall n: non_terminal,
useful g (inl (start_symbol g)) ->
accessible (g_use g) (inl n) ->
useful (g_use g) (inl n).
Proof.
intros g n H99 H.
unfold accessible in H.
unfold useful.
destruct H as [s1 [s2 H2]].
apply exists_rule' in H2.
destruct H2 as [H2 | H2].
- apply useful_g_use.
  simpl in H2.
  destruct H2 as [H2 [_ _]].
  rewrite H2.
  apply acc_appears.
  + simpl.
    apply useful_g_g_use.
    exact H99.
  + unfold accessible.
    exists [], [].
    constructor.
- destruct H2 as [left [right [H3 H4]]].
  simpl in H3.
  inversion H3.
  subst.
  specialize (H1 (inl n) H4).
  unfold useful in H1.
  destruct H1 as [s0 H7].
  exists s0.
  apply derives_sflist in H7.
  destruct H7 as [l [H10 [H11 H12]]].
  apply derives_sflist.
  exists l.
  split.
  + assert (H6: length l >= 2 \/ length l < 2) by omega.
    destruct H6 as [H6 | H6].
    * assert (H6':=H6).
      apply sflist_rules with (g:=g) in H6.
      destruct H6 as [H6 _].
      specialize (H6 H10).
      {
      apply sflist_rules.
      - exact H6'.
      - intros i H7.
        specialize (H6 i H7).
        destruct H6 as [left0 [right0 [s3 [s' [H20 [H21 H22]]]]]].
        exists left0, right0, s3, s'.
        split.
        + exact H20.
        + split.
          * exact H21.
          * simpl.
            {
            apply Lift_use.
            - exact H22.
            - assert (H30: derives g (s3 ++ inl left0 :: s') (map term_lift s0)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn i l) in H10.
                apply sflist_app_l in H10.
                exists (skipn i l).
                split.
                + exact H10.
                + split.
                  * rewrite hd_skip.
                    exact H20.
                  * {
                    rewrite last_skip.
                    - exact H12.
                    - omega.
                    }
                }
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H31 [H32 H33]]]].
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [_ [s2'0 [_ [_ H34]]]].
              rewrite <- H34 in H33.
              replace (inl left0 :: s') with ([inl left0] ++ s') in H33.
              + apply derives_split in H33.
                destruct H33 as [s1'0 [s2'1 [H35 [H36 _]]]].
                symmetry in H35.
                apply map_expand in H35.
                destruct H35 as [s1'1 [_ [_ [H37 _]]]].
                rewrite <- H37 in H36.
                unfold useful.
                exists s1'1.
                exact H36.
              + simpl.
                reflexivity.
            - assert (H30: derives g (s3 ++ right0 ++ s') (map term_lift s0)).
                {
                apply derives_sflist.
                rewrite <- (firstn_skipn (S i) l) in H10.
                apply sflist_app_l in H10.
                exists (skipn (S i) l).
                split.
                + exact H10.
                + split.
                  * rewrite hd_skip.
                    exact H21.
                  * {
                    rewrite last_skip.
                    - exact H12.
                    - omega.
                    }
                }
              apply derives_split in H30.
              destruct H30 as [s1' [s2' [H31 [H32 H33]]]].
              symmetry in H31.
              apply map_expand in H31.
              destruct H31 as [_ [s2'0 [_ [_ H34]]]].
              rewrite <- H34 in H33.
              apply derives_split in H33.
              destruct H33 as [s1'0 [s2'1 [H35 [H36 _]]]].
              symmetry in H35.
              apply map_expand in H35.
              destruct H35 as [s1'1 [_ [_ [H37 _]]]].
              rewrite <- H37 in H36.
              intros s4 H40.
              destruct s4.
              + unfold useful.
                apply in_split in H40.
                destruct H40 as [l1 [l2 H41]].
                rewrite H41 in H36.
                apply derives_nt_sentence in H36.
                destruct H36 as [s'0 H42].
                exists s'0.
                exact H42.
              + simpl.
                auto.
            }
      }
    * apply lt2_sflist.
      exact H6.
  + split.
    * exact H11.
    * exact H12.
Qed.

End Simplification.

Section Simplification_2.

Variables non_terminal terminal: Type.

Lemma no_useless_no_inaccessible_symbols_v1:
forall g: cfg non_terminal terminal,
non_empty g ->
g_equiv (g_acc (g_use g)) g /\
has_no_inaccessible_symbols (g_acc (g_use g)) /\
has_no_useless_symbols (g_acc (g_use g)).
Proof.
intros g H'.
split.
- assert (H1: g_equiv (g_use g) g).
    {
    apply g_equiv_use.
    exact H'.
    }
  assert (H2: g_equiv (g_acc (g_use g)) (g_use g)).
    {
    apply g_equiv_acc.
    }
  apply g_equiv_trans with (g2:= g_use g).
  split.
  + exact H2.
  + exact H1.
- split.
  + intros s H.
    destruct s.
    * inversion H.
      destruct H0 as [right [H1 H2]].
      {
      destruct H2 as [H2 | H2].
      - subst.
        simpl in H1.
        inversion H1.
        subst.
        apply accessible_g_g_acc.
        exact H2.
      - simpl in H1.
        inversion H1.
        subst.
        apply accessible_g_g_acc.
        apply acc_step with (s:=inl n) (right:=right) in H3.
        + exact H3.
        + exact H0.
        + exact H2.
      }
    * inversion H.
      destruct H0 as [right [H1 H2]].
      inversion H1.
      subst.
      apply accessible_g_g_acc.
      simpl in H1.
      inversion H1.
      subst.
      {
      apply acc_step with (s:=inr t) (right:=right) in H3.
      - exact H3.
      - exact H0.
      - exact H2.
      }
  + intros s H.
    inversion H.
    destruct H0 as [right [H1 H2]].
    destruct H2 as [H2 | H2].
    * simpl in H1.
      inversion H1.
      subst.
      assert (H4:= H3).
      {
      apply in_g_use_acc_is_use in H3.
      - apply g_acc_preserves_use.
        + exact H3.
        + exact H4.
      - exact H'.
      }
    * inversion H1.
      subst.
      {
      apply acc_step with (s:=inl s) (right:=right) in H3.
      - assert (H4:=H3).
        apply in_g_use_acc_is_use in H3.
        + apply g_acc_preserves_use.
          * exact H3.
          * exact H4.
        + exact H'.
      - exact H0.
      - exact H2.
      }
Qed.

Lemma no_useless_no_inaccessible_symbols_v2:
forall g: cfg non_terminal terminal,
non_empty g ->
exists g': cfg non_terminal terminal,
g_equiv g' g /\
has_no_inaccessible_symbols g' /\
has_no_useless_symbols g'.
Proof.
intros g H'.
exists (g_acc (g_use g)).
apply no_useless_no_inaccessible_symbols_v1.
exact H'.
Qed.

End Simplification_2.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - EMPTY AND UNIT RULES                                 *)
(* --------------------------------------------------------------------- *)

Section Simplification_3.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).
Notation term_lift:= ((terminal_lift non_terminal) terminal).

Lemma New_ss_not_in_unit_v1:
forall g: cfg non_terminal terminal,
forall n: non_terminal' non_terminal,
~ unit (g_emp' g) n (start_symbol (g_emp' g)).
Proof.
intros g n H.
remember (start_symbol (g_emp' g)) as w.
induction H.
- rewrite Heqw in H.
  apply New_ss_not_in_right_g_emp'_v2 in H.
  simpl in H.
  unfold New_ss_not_in_sf in H.
  simpl in H.
  apply H.
  left.
  reflexivity.
- apply IHunit2.
  exact Heqw.
Qed.

Lemma New_ss_not_in_unit_v2:
forall g: cfg non_terminal terminal,
forall n1 n2: non_terminal' non_terminal,
unit (g_emp' g) n1 n2 -> n2 <> (start_symbol (g_emp' g)).
Proof.
intros g n1 n2 H1.
assert (H2: n2 = start_symbol (g_emp' g) \/ n2 <> start_symbol (g_emp' g)).
  {
  destruct n2.
  - right.
    simpl.
    discriminate.
  - left.
    simpl.
    reflexivity.
  }
destruct H2 as [H2 | H2].
- rewrite H2 in H1.
  apply New_ss_not_in_unit_v1 in H1.
  contradiction.
- exact H2.
Qed.

Lemma g_unit_preserves_one_empty_rule:
forall g: cfg (non_terminal' non_terminal) terminal,
(forall n1 n2: non_terminal' non_terminal, unit g n1 n2 -> n2 <> (start_symbol g)) ->
has_one_empty_rule g ->
has_one_empty_rule (g_unit g).
Proof.
intros g H0 H1.
unfold has_one_empty_rule.
intros left right H2.
inversion H2.
- subst.
  specialize (H1 left right H3).
  destruct H1 as [H1 | H1].
  + left.
    simpl.
    exact H1.
  + right.
    exact H1.
- clear H2.
  subst.
  simpl.
  specialize (H1 b right H3).
  destruct H1 as [H1 | H1].
  + specialize (H0 left b H).
    destruct H1 as [H1 _].
    contradiction.
  + right.
    exact H1.
Qed.

Lemma g_unit_preserves_no_empty_rules:
forall g: cfg non_terminal terminal,
has_no_empty_rules g ->
has_no_empty_rules (g_unit g).
Proof.
unfold has_no_empty_rules.
intros g H1.
intros left right H2.
inversion H2.
- subst.
  apply H1 with (left:= left).
  exact H0.
- subst.
  apply H1 with (left:= b).
  exact H0.
Qed.

End Simplification_3.

Section Simplification_4.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Lemma no_empty_no_unit_rules_v1:
forall g: cfg non_terminal terminal,
g_equiv (g_unit (g_emp' g)) g /\
(generates_empty g -> has_one_empty_rule (g_unit (g_emp' g))) /\
(~ generates_empty g -> has_no_empty_rules (g_unit (g_emp' g))) /\
has_no_unit_rules (g_unit (g_emp' g)).
Proof.
intros g.
split.
- assert (H1: g_equiv (g_unit (g_emp' g)) (g_emp' g)).
    {
    apply g_unit_correct.
    }
  assert (H2: g_equiv (g_emp' g) g).
    {
    apply g_emp'_correct.
    }
  apply g_equiv_trans with (g2:= (g_emp' g)).
  split.
  + exact H1.
  + exact H2.
- split.
  + intros H1.
    assert (H2: has_one_empty_rule (g_emp' g)).
      {
      apply g_emp'_has_one_empty_rule.
      exact H1.
      }
    apply g_unit_preserves_one_empty_rule.
    * apply New_ss_not_in_unit_v2.
    * exact H2.
  + split.
    * intros H1.
      assert (H2: has_no_empty_rules (g_emp' g)).
        {
        apply g_emp'_has_no_empty_rules.
        exact H1.
        }
      apply g_unit_preserves_no_empty_rules.
      exact H2.
    * apply g_unit_has_no_unit_rules.
Qed.

Lemma no_empty_no_unit_rules_v2:
forall g: cfg non_terminal terminal,
g_equiv_without_empty (g_unit (g_emp g)) g /\
has_no_empty_rules (g_unit (g_emp g)) /\
has_no_unit_rules (g_unit (g_emp g)).
Proof.
intros g.
split.
- assert (H1: g_equiv (g_unit (g_emp g)) (g_emp g)).
    {
    apply g_unit_correct.
    }
  assert (H2: g_equiv_without_empty (g_emp g) g).
    {
    apply g_emp_correct.
    }
  apply g_equiv_without_empty_trans with (g2:= (g_emp g)).
  split.
  + apply remove_empty in H1.
    exact H1.
  + exact H2.
- split.
  + assert (H2: has_no_empty_rules (g_emp g)).
      {
      apply g_emp_has_no_empty_rules.
      }
    apply g_unit_preserves_no_empty_rules.
    exact H2.
  + apply g_unit_has_no_unit_rules.
Qed.

Lemma no_empty_no_unit_rules_v3:
forall g: cfg non_terminal terminal,
exists g': cfg  (non_terminal' non_terminal) terminal,
g_equiv g' g /\
(generates_empty g -> has_one_empty_rule g') /\
(~ generates_empty g -> has_no_empty_rules g') /\
has_no_unit_rules g'.
Proof.
intros g.
exists (g_unit (g_emp' g)).
apply no_empty_no_unit_rules_v1.
Qed.

End Simplification_4.

(* --------------------------------------------------------------------- *)
(* SIMPLIFICATION - FINAL THEOREM                                        *)
(* --------------------------------------------------------------------- *)

Section Simplification_5.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Lemma g_acc_g_use_preserves_rules:
forall g: cfg non_terminal terminal,
forall left: _,
forall right: _,
rules (g_acc (g_use g)) left right -> rules g left right.
Proof.
intros g left right H.
inversion H.
clear H.
subst.
inversion H0.
clear H0.
subst.
exact H.
Qed.

Lemma g_acc_g_use_preserves_empty_rule:
forall g: cfg (non_terminal' non_terminal) terminal,
rules g (start_symbol g) [] ->
rules (g_acc (g_use g)) (start_symbol (g_acc (g_use g))) [].
Proof.
intros g H.
simpl.
apply Lift_acc.
- apply Lift_use.
  + exact H.
  + unfold useful.
    exists [].
    apply derives_start.
    simpl.
    exact H.
  + intros s H1.
    simpl in H1.
    contradiction.
- exists [], [].
  simpl.
  apply derives_refl.
Qed.

Lemma g_emp_preserves_non_empty:
forall g: cfg non_terminal terminal,
(exists s: sentence, produces g s /\ s <> []) ->
non_empty (g_emp g).
Proof.
intros g H0.
unfold non_empty.
unfold produces in H0.
unfold generates in H0.
unfold useful.
destruct H0 as [s [H0 H1]].
assert (H3: g_equiv_without_empty (g_emp g) g).
  {
  apply g_emp_correct.
  }
unfold g_equiv_without_empty in H3.
specialize (H3 s H1).
destruct H3 as [_ H3].
specialize (H3 H0).
exists s.
exact H3.
Qed.

Lemma g_emp'_preserves_non_empty:
forall g: cfg non_terminal terminal,
non_empty g ->
non_empty (g_emp' g).
Proof.
unfold non_empty.
intros g H0.
unfold useful in H0.
destruct H0 as [s H0].
assert (H1: g_equiv (g_emp' g) g).
  {
  apply g_emp'_correct.
  }
unfold g_equiv in H1.
specialize (H1 s).
destruct H1 as [_ H1].
specialize (H1 H0).
unfold useful.
exists s.
exact H1.
Qed.

Lemma g_unit_preserves_non_empty:
forall g: cfg non_terminal terminal,
non_empty g ->
non_empty (g_unit g).
Proof.
unfold non_empty.
intros g H0.
simpl.
unfold useful in H0.
destruct H0 as [s H0].
exists s.
assert (H2: g_equiv (g_unit g) g).
  {
  apply g_unit_correct.
  }
unfold g_equiv in H2.
specialize (H2 s).
destruct H2 as [_ H2].
unfold produces in H2.
unfold generates in H2.
apply H2.
exact H0.
Qed.

Lemma g_unit_preserves_start:
forall g: cfg (non_terminal' non_terminal) terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_unit g).
Proof.
intros g H1 left right H2 H3.
unfold start_symbol_not_in_rhs in H1.
inversion H2.
- subst.
  specialize (H1 left right H0).
  apply H1.
  simpl in H3.
  exact H3.
- specialize (H1 b right H0).
  apply H1.
  simpl in H3.
  exact H3.
Qed.

Lemma g_use_preserves_start:
forall g: cfg (non_terminal' non_terminal) terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_use g).
Proof.
intros g H1 left right H2 H3.
unfold start_symbol_not_in_rhs in H1.
inversion H2.
subst.
specialize (H1 left right H).
apply H1.
simpl in H3.
exact H3.
Qed.

Lemma g_acc_preserves_start:
forall g: cfg (non_terminal' non_terminal) terminal,
start_symbol_not_in_rhs g ->
start_symbol_not_in_rhs (g_acc g).
Proof.
intros g H1 left right H2 H3.
unfold start_symbol_not_in_rhs in H1.
inversion H2.
subst.
specialize (H1 left right H).
apply H1.
simpl in H3.
exact H3.
Qed.

End Simplification_5.

Section Simplification_6.

Variables non_terminal terminal: Type.

Notation sentence:= (list terminal).

Theorem g_simpl_exists_v1:
forall g: cfg non_terminal terminal,
 non_empty g ->
 exists g': cfg (non_terminal' non_terminal) terminal,
 g_equiv g' g /\
 has_no_inaccessible_symbols g' /\
 has_no_useless_symbols g' /\
(produces_empty g -> has_one_empty_rule g') /\
(~ produces_empty g -> has_no_empty_rules g') /\
 has_no_unit_rules g' /\
 start_symbol_not_in_rhs g'.
Proof.
intros g H.
exists (g_acc (g_use (g_unit (g_emp' g)))).
split.
- assert (H3: g_equiv (g_acc (g_use (g_unit (g_emp' g)))) (g_unit (g_emp' g))).
    {
    apply no_useless_no_inaccessible_symbols_v1.
    apply g_emp'_preserves_non_empty in H.
    apply g_unit_preserves_non_empty in H.
    exact H.
    }
  apply g_equiv_trans with (g2:= (g_unit (g_emp' g))).
  split.
  + exact H3.
  + apply no_empty_no_unit_rules_v1.
- split.
  + apply g_acc_has_no_inaccessible_symbols.
  + split.
    * apply no_useless_no_inaccessible_symbols_v1.
      {
      apply g_emp'_preserves_non_empty in H.
      apply g_unit_preserves_non_empty in H.
      exact H.
      }
    * {
      split.
      - intros H1'.
        assert (H2': has_one_empty_rule (g_unit (g_emp' g))).
          {
          apply no_empty_no_unit_rules_v1.
          exact H1'.
          }
        unfold has_one_empty_rule.
        remember (g_unit (g_emp' g)) as g'.
        intros left right HH.
        simpl in HH.
        inversion HH.
        clear HH.
        subst.
        simpl.
        simpl in H0.
        inversion H0.
        clear H0.
        subst.
        specialize (H2' left right H2).
        destruct H2' as [H2' | H2'].
        + simpl in H2'.
          left.
          exact H2'.
        + right.
          exact H2'.
      - split.
        + intros H1'.
          unfold has_no_empty_rules.
          intros left right H2'.
          apply g_acc_g_use_preserves_rules in H2'.
          apply g_emp'_has_no_empty_rules in H1'.
          apply g_unit_preserves_no_empty_rules in H1'.
          unfold has_no_empty_rules in H1'.
          specialize (H1' left right H2').
          exact H1'.
        + split.
          * unfold has_no_unit_rules.
            intros left n right H1'.
            apply g_acc_g_use_preserves_rules in H1'.
            {
            inversion H1'.
            clear H1'.
            - subst.
              specialize (H0 n).
              exact H0.
            - subst.
              specialize (H2 n).
              exact H2.
            }
          * assert (H1: start_symbol_not_in_rhs (g_emp' g)).
              {
              apply start_symbol_not_in_rhs_g_emp'.
              }
            apply g_unit_preserves_start in H1.
            apply g_use_preserves_start in H1.
            apply g_acc_preserves_start in H1.
            exact H1.
      }
Qed.

Theorem g_simpl_exists_v2:
forall g: cfg non_terminal terminal,
(exists s: sentence, produces g s /\ s <> [] ) ->
 exists g': cfg (non_terminal' non_terminal) terminal,
 g_equiv_without_empty g' g /\
 has_no_inaccessible_symbols g' /\
 has_no_useless_symbols g' /\
 has_no_empty_rules g' /\
 has_no_unit_rules g' /\
 start_symbol_not_in_rhs g'.
Proof.
intros g H.
exists (g_acc (g_use (g_unit (g_emp g)))).
split.
- assert (H3: g_equiv (g_acc (g_use (g_unit (g_emp g)))) (g_unit (g_emp g))).
    {
    apply no_useless_no_inaccessible_symbols_v1.
    apply g_emp_preserves_non_empty in H.
    apply g_unit_preserves_non_empty in H.
    exact H.
    }
  apply g_equiv_without_empty_trans with (g2:= (g_unit (g_emp g))).
  split.
  + apply remove_empty in H3.
    exact H3.
  + apply no_empty_no_unit_rules_v2.
- split.
  + apply g_acc_has_no_inaccessible_symbols.
  + split.
    * apply no_useless_no_inaccessible_symbols_v1.
      {
      apply g_emp_preserves_non_empty in H.
      apply g_unit_preserves_non_empty in H.
      exact H.
      }
    * {
      split.
      - unfold has_no_empty_rules.
        intros left right H2'.
        apply g_acc_g_use_preserves_rules in H2'.
        apply g_unit_preserves_no_empty_rules in H2'.
        exact H2'.
        apply g_emp_has_no_empty_rules.
      - split.
        + unfold has_no_unit_rules.
          intros left n right H1'.
          apply g_acc_g_use_preserves_rules in H1'.
          inversion H1'.
          clear H1'.
          * subst.
            specialize (H0 n).
            exact H0.
          * subst.
            specialize (H2 n).
            exact H2.
        + assert (H1: start_symbol_not_in_rhs (g_emp g)).
            {
            apply start_symbol_not_in_rhs_g_emp.
            }
          apply g_unit_preserves_start in H1.
          apply g_use_preserves_start in H1.
          apply g_acc_preserves_start in H1.
          exact H1.
      }
Qed.

End Simplification_6.


Set Implicit Arguments.
Require Import LibLogic LibHeap.
Require Export JsSemantics.
Implicit Type h : heap.
Implicit Type l : loc.
Implicit Type f : field.

(**************************************************************)
(**************************************************************)
(** * Auxiliary lemmas *)

(**************************************************************)
(** * Checking the type of fields *)

(** Express whether a field is a user field *)

Definition is_field_normal f :=
    exists y, f = field_normal y.

(**************************************************************)
(** * Comparison of references *)

Lemma ref_neq : forall l l' f f',
  (Ref l f <> Ref l' f') = (l <> l' \/ f <> f').
Proof.
  intros. extens. iff H.
  rewrite <- not_and. intros [? ?]. subst. apply~ H.
  intros M. inverts M. destruct H; congruence.
Qed.

Lemma ref_neq_inv : forall l l' f f',
  (Ref l f <> Ref l' f') -> (l <> l' \/ f <> f').
Proof. intros. rewrite~ <- ref_neq. Qed.

Lemma ref_neq_prove : forall l l' f f',
  (l <> l' \/ f <> f') -> (Ref l f <> Ref l' f').
Proof. intros. rewrite~ ref_neq. Qed.

(**************************************************)
(** * Induction principle for [red] *)

Section Red_induct.

Scheme red_ind' := Induction for red Sort Prop
  with red_list_value_ind' := Induction for red_list_value Sort Prop.

Combined Scheme red_list_ind from red_ind', red_list_value_ind'.

End Red_induct.

(**************************************************************)
(** ** Corrolaries for [obj_of_value] *)

Definition value_not_loc v :=
  forall l, v <> value_loc l.

Lemma value_loc_or_not : forall v,
  (exists l, v = value_loc l) \/ (value_not_loc v).
Proof.
  intros. applys classic_right. introv M.
  rew_logic in M. auto.
Qed.

Lemma obj_of_value_not_loc : forall v l',
  value_not_loc v ->
  obj_of_value v l' = l'.
Proof. introv H. destruct* v. false* H. Qed.

(**************************************************************)
(** ** Corrolaries for [obj_or_glob_of_value_not_loc] *)

Definition not_scope_or_body f :=
  f <> field_scope /\ f <> field_body.

Hint Unfold not_scope_or_body.

Lemma obj_or_glob_of_value_not_loc : forall v,
  value_not_loc v ->
  obj_or_glob_of_value v = loc_obj_proto.
Proof. introv H. destruct* v. simpl. false* H. Qed.

(**************************************************************)
(**************************************************************)
(** * Properties of heaps *)

(**************************************************************)
(** * Properties of heaps (adapted from module [Heap]) *)

Section Properties.
Hint Resolve ref_neq_inv ref_neq_prove.

(** DO NOT REORDER THE LEMMAS *)

Lemma binds_equiv_read : forall h l f,
  indom h l f -> (forall v, (binds h l f v) = (read h l f = v)).
Proof. intros. apply* @Heap.binds_equiv_read. Qed.

Lemma indom_equiv_binds : forall h l f,
  indom h l f = (exists v, binds h l f v).
Proof. intros. apply Heap.indom_equiv_binds. Qed.

Lemma binds_write_eq : forall h l f v,
  binds (write h l f v) l f v.
Proof. intros. apply Heap.binds_write_eq. Qed.

Lemma binds_write_neq : forall h l f v l' f' v',
  binds h l f v -> (l <> l' \/ f <> f') ->
  binds (write h l' f' v') l f v.
Proof.
  introv B N. applys @Heap.binds_write_neq B.
  destruct N; congruence.
Qed.

Lemma binds_write_inv : forall h l f v l' f' v',
  binds (write h l' f' v') l f v ->
     (l = l' /\ f = f' /\ v = v')
  \/ ((l <> l' \/ f <> f') /\ binds h l f v).
Proof.
  introv B. forwards [[E ?]|[E ?]]: @Heap.binds_write_inv B.
  inverts E. left*.
  right*.
Qed.

Lemma binds_rem : forall h l f l' f' v,
  binds h l f v -> (l <> l' \/ f <> f') -> binds (rem h l' f') l f v.
Proof. introv B N. apply* @Heap.binds_rem. Qed.

Lemma binds_rem_inv : forall h l f v l' f',
  binds (rem h l' f') l f v -> (l <> l' \/ f <> f') /\ binds h l f v.
Proof. introv B. forwards* [? ?]: @Heap.binds_rem_inv B. Qed.

Lemma not_indom_rem : forall h l f,
  ~ indom (rem h l f) l f.
Proof. intros. apply Heap.not_indom_rem. Qed.

Lemma indom_binds : forall h l f,
  indom h l f -> exists v, binds h l f v.
Proof. intros. apply* @LibHeap.indom_binds. Qed.

Lemma binds_indom : forall h l f v,
  binds h l f v -> indom h l f.
Proof. intros. apply* @LibHeap.binds_indom. Qed.

Lemma binds_func : forall h l f v v',
  binds h l f v -> binds h l f v' -> v = v'.
Proof. intros. applys* @LibHeap.binds_func; typeclass. Qed.

Lemma binds_read : forall h l f v,
  binds h l f v -> read h l f = v.
Proof. intros. apply* @LibHeap.binds_read. Qed.

Lemma read_binds : forall h l f v,
  read h l f = v -> indom h l f -> binds h l f v.
Proof. intros. apply* @LibHeap.read_binds. Qed.

Lemma read_write_eq : forall h l f v,
  read (write h l f v) l f = v.
Proof. intros. apply* @LibHeap.read_write_eq. Qed.

Lemma read_write_neq : forall h l f l' f' v',
  indom h l f -> (l <> l' \/ f <> f') -> read (write h l' f' v') l f = read h l f.
Proof. intros. apply* @LibHeap.read_write_neq. Qed.

Lemma indom_write_eq : forall h l f v,
  indom (write h l f v) l f.
Proof. intros. apply* @LibHeap.indom_write_eq. Qed.

Lemma indom_write : forall h l f l' f' v',
  indom h l f -> indom (write h l' f' v') l f.
Proof. intros. apply* @LibHeap.indom_write. Qed.

Lemma indom_write_inv : forall h l f l' f' v',
  indom (write h l' f' v') l f -> (l <> l' \/ f <> f') -> indom h l f.
Proof. intros. apply* @LibHeap.indom_write_inv. Qed.

Lemma binds_write_eq_inv : forall h l f v v',
  binds (write h l f v') l f v -> v = v'.
Proof. intros. apply* @LibHeap.binds_write_eq_inv. Qed.

Lemma binds_write_neq_inv : forall h l f v l' f' v',
  binds (write h l' f' v') l f v -> (l <> l' \/ f <> f') -> binds h l f v.
Proof. intros. apply* @LibHeap.binds_write_neq_inv. Qed.

Lemma indom_rem : forall h l f l' f',
  indom h l f -> (l <> l' \/ f <> f') -> indom (rem h l' f') l f.
Proof. intros. apply* @LibHeap.indom_rem. Qed.

Lemma indom_rem_inv : forall h l f l' f',
  indom (rem h l f) l' f' -> (l <> l' \/ f <> f') /\ indom h l' f'.
Proof. intros. forwards* [? ?]: @LibHeap.indom_rem_inv H. Qed.

Lemma read_rem_neq : forall h l f l' f',
  indom h l f -> (l <> l' \/ f <> f') -> read (rem h l' f') l f = read h l f.
Proof. intros. apply* @LibHeap.read_rem_neq. Qed.

Lemma not_indom_empty : forall l f,
  ~ indom empty_heap l f.
Proof. intros. apply* @LibHeap.not_indom_empty. Qed.

Lemma not_binds_empty : forall l f v,
  ~ binds empty_heap l f v.
Proof. intros. apply* @LibHeap.not_binds_empty. Qed.

End Properties.

(**************************************************************)
(** * Other results *)

(** [binds] on location is functional *)

Lemma binds_func_loc : forall h f l l1 l2,
  binds h l f (value_loc l1) ->
  binds h l f (value_loc l2) ->
  l1 = l2.
Proof. introv B1 B2. forwards E: binds_func B1 B2. inverts~ E. Qed.

(** Checking if a location l is bound to a given value in the heap
    is decidable. *)

Global Instance indom_decidable : forall h l f,
  Decidable (indom h l f).
Proof. intros. apply Heap.indom_decidable. Qed.

(**************************************************************)
(** * Properties of write_fields *)

Lemma write_fields_nil : forall h l,
  write_fields h l nil = h.
Proof. auto. Qed.

Lemma write_fields_cons : forall h l f v fvs,
  write_fields h l ((f,v)::fvs) = write_fields (write h l f v) l fvs.
Proof. auto. Qed.

Hint Rewrite write_fields_nil write_fields_cons : rew_write_fields.
Ltac rew_write_fields := autorewrite with rew_write_fields.

(** An induction principle for proving facts about [write_fields] *)

Lemma write_fields_ind : forall (P : list(field*value)->heap->heap->Prop), forall l h,
  (P nil h h) ->
  (forall f v fvs, P fvs h (write_fields h l fvs) -> P (fvs&(f,v)) h (write (write_fields h l fvs) l f v)) ->
  (forall fvs, P fvs h (write_fields h l fvs)).
Proof.
  introv MN MC. intros. unfold write_fields. induction fvs using list_ind_last; rew_list.
  auto. destruct a as [f' v']. apply~ MC.
Qed.

Lemma binds_write_fields_neq : forall h l f v l' fvs',
  binds h l f v -> l <> l' ->
  binds (write_fields h l' fvs') l f v.
Proof. intros. lets: binds_write_neq. apply* write_fields_ind. Qed.

Lemma binds_write_fields_neq_inv : forall h l l' fvs' f v,
  binds (write_fields h l' fvs') l f v -> l <> l' -> binds h l f v.
Proof. introv B N. gen B. lets: binds_write_neq_inv. apply* write_fields_ind. Qed.

Lemma indom_write_fields : forall h l f l' fvs',
  indom h l f -> indom (write_fields h l' fvs') l f.
Proof. introv D. lets: indom_write. apply* write_fields_ind. Qed.

(**************************************************************)
(** * Properties of bound *)

Lemma binds_bound : forall h l f v,
  binds h l f v -> bound h l.
Proof. intros. exists f. apply* binds_indom. Qed.

Lemma indom_bound : forall h l f,
  indom h l f -> bound h l.
Proof. intros. exists* f. Qed.

Lemma not_bound_indom : forall h l f,
  (~ bound h l) -> indom h l f -> False.
Proof. introv N D. apply N. apply* indom_bound. Qed.

Lemma not_bound_binds : forall h l f v,
  (~ bound h l) -> binds h l f v -> False.
Proof. introv N D. apply N. apply* binds_bound. Qed.

Lemma bound_binds : forall h l,
  bound h l -> exists f v, binds h l f v.
Proof. introv [f D]. rewrite* indom_equiv_binds in D. Qed.

(**************************************************************)
(** * Properties of freshness *)

Lemma fresh_not_null : forall h l,
  fresh h l -> l <> loc_null.
Proof. introv [N _]. auto. Qed.

Hint Resolve fresh_not_null.

(** Elimination of fresh *)

Lemma fresh_not_bound : forall h l,
  fresh h l -> bound h l -> False.
Proof. introv [_ N] D. false. Qed.

Lemma fresh_bound_neq : forall h l l',
  fresh h l' -> bound h l -> l <> l'.
Proof. introv B F E. subst. apply* fresh_not_bound. Qed.

Lemma fresh_not_indom : forall h l f,
  fresh h l -> indom h l f -> False.
Proof. intros. apply* fresh_not_bound. apply* indom_bound. Qed.

Lemma fresh_indom_neq : forall h l l' f,
  fresh h l' -> indom h l f -> l <> l'.
Proof. introv B F E. subst. apply* fresh_not_indom. Qed.

Lemma fresh_not_binds : forall h l f v,
  fresh h l -> binds h l f v -> False.
Proof. intros. apply* fresh_not_indom. applys* binds_indom. Qed.

Lemma fresh_binds_neq : forall h l l' f v,
  fresh h l' -> binds h l f v -> l <> l'.
Proof. introv B F E. subst. apply* fresh_not_binds. Qed.

(** Preservation of fresh *)

Lemma fresh_write : forall l' h l f v,
  fresh h l' -> l <> l' -> fresh (write h l f v) l'.
Proof.
  introv [L B] N. split. auto.
  intros B'. lets (f'&v'&R): bound_binds B'.
  lets [(?&?&?)|(?&?)]: binds_write_inv R.
    false.
    apply* not_bound_binds.
Qed.

Lemma fresh_write_weaken : forall l' h l f v,
  fresh (write h l f v) l' -> fresh h l'.
Proof.
  introv [L B]. split. auto.
  intros [f' B']. apply B. eapply indom_bound.
  apply* indom_write.
Qed.

(**************************************************************)
(** ** Hints for proving freshness goals *)

Hint Extern 1 (fresh _ ?l) =>
  match goal with H: fresh _ ?l |- _ =>
    apply (fresh_write_weaken H) end.

Hint Resolve fresh_binds_neq.

Hint Extern 1 (_ <> _ :> ref) => congruence.

(**************************************************************)
(** ** Tactics *)

(*--------------------------------------------------------------*)

(** The following tactic strengthens [congruence] by making it
    able to bruteforce a goal that concludes on a disjunction *)

Ltac congruence_on_disjunction :=
  let rec go tt :=
    match goal with
    | |- _ \/ _ => first [ left; go tt | right; go tt ]
    | |- _ => congruence
    end in
  go tt.

Lemma congruence_on_disjunction_demo : forall (l l' : nat),
  l <> l' -> (l <> l' \/ l' <> l \/ l <> l').
Proof. intros. try congruence. congruence_on_disjunction. Qed.

(*--------------------------------------------------------------*)

(** The tactic [indom_simpl_step] simplifies a goal of the
    form [indom (write h l f v) l' f'] by handling the case
    where [l'] is syntactically [l] and [f'] is syntactically [f],
    and otherwise turning the goal into [indom h l' f'].
    It also handles the [write_fields]. Note that you might
    need to do a case analysis on [l = l'] and [f = f'] before
    calling this tactic. It also handles the empty heap.  *)

Ltac indom_simpl_step :=
  match goal with
  | |- indom (write ?h ?l ?f _) ?l ?f =>
     apply indom_write_eq
  | |- indom (write_fields _ _ nil) _ _ =>
     rewrite write_fields_nil; indom_simpl_step
  | |- indom (write_fields _ _ (_::_)) _ _ =>
     rewrite write_fields_cons; indom_simpl_step
  | |- indom (write ?h ?l' ?f' _) ?l ?f =>
     apply indom_write
  | |- indom ?h _ _ =>
     let P := get_head h in progress (unfold P); indom_simpl_step
  | |- _ =>
     progress (unfolds); indom_simpl_step
  end.

(** The tactic [indom_simpl] iterates [indom_simpl_step]. *)

Tactic Notation "indom_simpl" :=
  repeat indom_simpl_step.
Tactic Notation "indom_simpl" "~" :=
  indom_simpl; auto_tilde.
Tactic Notation "indom_simpl" "*" :=
  indom_simpl; auto_star.

(*--------------------------------------------------------------*)

(** The tactic [binds_simpl_step] simplifies goal of the form
    [binds (write h l f v) f' l' v'] by handling the case where
    [l'] is syntactically [l] and [f'] is syntactically [f],
    and otherwise discarding the write, producing [l <> l' \/ f <> f']
    as subgoal and trying to prove it using [congruence].
    The tactic also handles [write_fields] in the case where [l <> l']. *)

Ltac binds_simpl_step :=
  match goal with
  | |- binds (write ?h ?l ?f _) ?l ?f _ =>
     apply binds_write_eq
  | |- binds (write_fields ?h ?l' ?fvs') ?l _ _ =>
     let F := fresh in
     assert (F : l <> l');
       [ try congruence
       | apply binds_write_fields_neq; [ clear F | apply F ]]
  | |- binds (write ?h ?l' ?f' _) ?l ?f _ =>
     let F := fresh in
     assert (F : l <> l' \/ f <> f');
       [ try congruence_on_disjunction
       | apply binds_write_neq; [ clear F | apply F ]]
  | |- binds ?h _ _ _ =>
     let P := get_head h in progress (unfold P); binds_simpl_step
  | |- _ =>
     progress (unfolds); binds_simpl_step
  end.

(** The tactic [binds_simpl] iterates [binds_simpl_step]. *)

Tactic Notation "binds_simpl" :=
  repeat binds_simpl_step.
Tactic Notation "binds_simpl" "~" :=
  binds_simpl; auto_tilde.
Tactic Notation "binds_simpl" "*" :=
  binds_simpl; auto_star.

(*--------------------------------------------------------------*)

(** The tactic [binds_case H] helps extracting information from an
    assumption [H] of the form [binds (write h l' f' v') l f v].
    If [l'] is syntactically [l] and [f'] is syntactically [f],
    then the tactic simplifies [H] to [v' = v]. Otherwise, if
    [l' <> l] or [f' <> f] is provable using [congruence], then
    the tactic simplifies [H] to [binds h l f v]. Otherwise, the
    tactic performs the case analysis and generates two subgoals,
    one corresponding to each case.
    The tactic also handles [write_fields] by unfolding the head
    write in write_fields, if any. It also handles the empty heap. *)

Ltac binds_case_step H :=
  match type of H with
  | binds (write ?h ?l ?f _) ?l ?f _ =>
     apply binds_write_eq_inv in H (*; try solve [ congruence ] *)
  | binds (write ?h ?l' ?f' ?v') ?l ?f ?v =>
     first [
       let F := fresh in let H' := fresh in
       assert (F : l <> l' \/ f <> f');
         [ congruence_on_disjunction
         | rename H into H';
           lets H: (binds_write_neq_inv H' F); clear F H' ]
     | let H' := fresh in rename H into H';
       let N := fresh "N" in let E1 := fresh "E1" in
       let E2 := fresh "E2" in let E3 := fresh "E3" in
       destruct (binds_write_inv H') as [(E1&E2&E3)|(N&H)];
         [ clear H'; try solve [ false; congruence ];
           try subst_hyp E1; try subst_hyp E2; try subst_hyp E3
         | clear H' ]
     ]
  | binds (write_fields _ _ nil) _ _ _ =>
     rewrite write_fields_nil in H
  | binds (write_fields _ _ (_::_)) _ _ _ =>
     rewrite write_fields_cons in H; binds_case_step H
  | binds (write_fields _ _ _) _ _ _ =>
     fail 2 "list given to write_fields should not be abstract"
  | binds empty_heap _ _ _ =>
     false (not_binds_empty H)
  | binds ?h _ _ _ =>
     let P := get_head h in progress (unfold P in H); binds_case_step H
  end.

Tactic Notation "binds_case" hyp(H) :=
  binds_case_step H.
Tactic Notation "binds_case" "~" hyp(H) :=
  binds_case H; auto_tilde.
Tactic Notation "binds_case" "*" hyp(H) :=
  binds_case H; auto_star.

(** The tactic [binds_cases] iterates [binds_case] *)

Tactic Notation "binds_cases" hyp(H) :=
  repeat (binds_case H).
Tactic Notation "binds_cases" "~" hyp(H) :=
  binds_cases H; auto_tilde.
Tactic Notation "binds_cases" "*" hyp(H) :=
  binds_cases H; auto_star.


From prelude Require Import functions.
From algebra Require Import upred_big_op.
From program_logic Require Import sts saved_prop tactics.
From heap_lang Require Export heap wp_tactics.
From barrier Require Export barrier.
From barrier Require Import protocol.
Import uPred.

(** The CMRAs we need. *)
(* Not bundling heapG, as it may be shared with other users. *)
Class barrierG Σ := BarrierG {
  barrier_stsG :> stsG heap_lang Σ sts;
  barrier_savedPropG :> savedPropG heap_lang Σ idCF;
}.
(** The Functors we need. *)
Definition barrierGF : gFunctorList := [stsGF sts; savedPropGF idCF].
(* Show and register that they match. *)
Instance inGF_barrierG `{H : inGFs heap_lang Σ barrierGF} : barrierG Σ.
Proof. destruct H as (?&?&?). split; apply _. Qed.

(** Now we come to the Iris part of the proof. *)
Section proof.
Context {Σ : gFunctors} `{!heapG Σ, !barrierG Σ}.
Context (heapN N : namespace).
Local Notation iProp := (iPropG heap_lang Σ).

Definition ress (P : iProp) (I : gset gname) : iProp :=
  (∃ Ψ : gname → iProp,
    ▷ (P -★ Π★{set I} Ψ) ★ Π★{set I} (λ i, saved_prop_own i (Ψ i)))%I.

Coercion state_to_val (s : state) : val :=
  match s with State Low _ => #0 | State High _ => #1 end.
Arguments state_to_val !_ /.

Definition state_to_prop (s : state) (P : iProp) : iProp :=
  match s with State Low _ => P | State High _ => True%I end.
Arguments state_to_val !_ /.

Definition barrier_inv (l : loc) (P : iProp) (s : state) : iProp :=
  (l ↦ s ★ ress (state_to_prop s P) (state_I s))%I.

Definition barrier_ctx (γ : gname) (l : loc) (P : iProp) : iProp :=
  (■ (heapN ⊥ N) ★ heap_ctx heapN ★ sts_ctx γ N (barrier_inv l P))%I.

Definition send (l : loc) (P : iProp) : iProp :=
  (∃ γ, barrier_ctx γ l P ★ sts_ownS γ low_states {[ Send ]})%I.

Definition recv (l : loc) (R : iProp) : iProp :=
  (∃ γ P Q i,
    barrier_ctx γ l P ★ sts_ownS γ (i_states i) {[ Change i ]} ★
    saved_prop_own i Q ★ ▷ (Q -★ R))%I.

Global Instance barrier_ctx_always_stable (γ : gname) (l : loc) (P : iProp) :
  AlwaysStable (barrier_ctx γ l P).
Proof. apply _. Qed.

(* TODO: Figure out if this has a "Global" or "Local" effect.
   We want it to be Global. *)
Typeclasses Opaque barrier_ctx send recv.

Implicit Types I : gset gname.

(** Setoids *)
Global Instance ress_ne n : Proper (dist n ==> (=) ==> dist n) ress.
Proof. solve_proper. Qed.
Global Instance state_to_prop_ne n s :
  Proper (dist n ==> dist n) (state_to_prop s).
Proof. solve_proper. Qed.
Global Instance barrier_inv_ne n l :
  Proper (dist n ==> eq ==> dist n) (barrier_inv l).
Proof. solve_proper. Qed.
Global Instance barrier_ctx_ne n γ l : Proper (dist n ==> dist n) (barrier_ctx γ l).
Proof. solve_proper. Qed.
Global Instance send_ne n l : Proper (dist n ==> dist n) (send l).
Proof. solve_proper. Qed.
Global Instance recv_ne n l : Proper (dist n ==> dist n) (recv l).
Proof. solve_proper. Qed.

(** Helper lemmas *)
Lemma ress_split i i1 i2 Q R1 R2 P I :
  i ∈ I → i1 ∉ I → i2 ∉ I → i1 ≠ i2 →
  (saved_prop_own i2 R2 ★
    saved_prop_own i1 R1 ★ saved_prop_own i Q ★
    (Q -★ R1 ★ R2) ★ ress P I)
  ⊑ ress P ({[i1]} ∪ ({[i2]} ∪ (I ∖ {[i]}))).
Proof.
  intros. rewrite /ress !sep_exist_l. apply exist_elim=>Ψ.
  rewrite -(exist_intro (<[i1:=R1]> (<[i2:=R2]> Ψ))).
  rewrite [(Π★{set _} (λ _, saved_prop_own _ _))%I](big_sepS_delete _ I i) //.
  do 4 (rewrite big_sepS_insert; last set_solver).
  rewrite !fn_lookup_insert fn_lookup_insert_ne // !fn_lookup_insert.
  set savedQ := _ i Q. set savedΨ := _ i (Ψ _).
  sep_split left: [savedQ; savedΨ; Q -★ _; ▷ (_ -★ Π★{set I} _)]%I.
  - rewrite !assoc saved_prop_agree /=. strip_later.
    apply wand_intro_l. to_front [P; P -★ _]%I. rewrite wand_elim_r.
    rewrite (big_sepS_delete _ I i) //.
    sep_split right: [Π★{set _} _]%I.
    + rewrite !assoc.
      eapply wand_apply_r'; first done.
      apply: (eq_rewrite (Ψ i) Q (λ x, x)%I); last by eauto with I.
      rewrite eq_sym. eauto with I.
    + apply big_sepS_mono; [done|] => j.
      rewrite elem_of_difference not_elem_of_singleton=> -[??].
      by do 2 (rewrite fn_lookup_insert_ne; last naive_solver).
  - rewrite !assoc [(saved_prop_own i2 _ ★ _)%I]comm; apply sep_mono_r.
    apply big_sepS_mono; [done|]=> j.
    rewrite elem_of_difference not_elem_of_singleton=> -[??].
    by do 2 (rewrite fn_lookup_insert_ne; last naive_solver).
Qed.

(** Actual proofs *)
Lemma newbarrier_spec (P : iProp) (Φ : val → iProp) :
  heapN ⊥ N →
  (heap_ctx heapN ★ ∀ l, recv l P ★ send l P -★ Φ (%l))
  ⊑ #> newbarrier #() {{ Φ }}.
Proof.
  intros HN. rewrite /newbarrier. wp_seq.
  rewrite -wp_pvs. wp eapply wp_alloc; eauto with I ndisj.
  apply forall_intro=>l. rewrite (forall_elim l). apply wand_intro_l.
  rewrite !assoc. apply pvs_wand_r.
  (* The core of this proof: Allocating the STS and the saved prop. *)
  eapply sep_elim_True_r; first by eapply (saved_prop_alloc (F:=idCF) _ P).
  rewrite pvs_frame_l. apply pvs_strip_pvs. rewrite sep_exist_l.
  apply exist_elim=>i.
  trans (pvs ⊤ ⊤ (heap_ctx heapN ★
    ▷ (barrier_inv l P (State Low {[ i ]})) ★ saved_prop_own i P)).
  - rewrite -pvs_intro. cancel [heap_ctx heapN].
    rewrite {1}[saved_prop_own _ _]always_sep_dup. cancel [saved_prop_own i P].
    rewrite /barrier_inv /ress -later_intro. cancel [l ↦ #0]%I.
    rewrite -(exist_intro (const P)) /=. rewrite -[saved_prop_own _ _](left_id True%I (★)%I).
    by rewrite !big_sepS_singleton /= wand_diag -later_intro.
  - rewrite (sts_alloc (barrier_inv l P) ⊤ N); last by eauto.
    rewrite !pvs_frame_r !pvs_frame_l.
    rewrite pvs_trans'. apply pvs_strip_pvs. rewrite sep_exist_r sep_exist_l.
    apply exist_elim=>γ.
    rewrite /recv /send. rewrite -(exist_intro γ) -(exist_intro P).
    rewrite -(exist_intro P) -(exist_intro i) -(exist_intro γ).
    rewrite always_and_sep_l wand_diag later_True right_id.
    rewrite [heap_ctx _]always_sep_dup [sts_ctx _ _ _]always_sep_dup.
    rewrite /barrier_ctx const_equiv // left_id.
    ecancel_pvs [saved_prop_own i _; heap_ctx _; heap_ctx _;
                 sts_ctx _ _ _; sts_ctx _ _ _].
    rewrite (sts_own_weaken ⊤ _ _ (i_states i ∩ low_states) _
                            ({[ Change i ]} ∪ {[ Send ]})).
    + apply pvs_mono.
      rewrite -sts_ownS_op; eauto using i_states_closed, low_states_closed.
      set_solver.
    + intros []; set_solver.
    + set_solver.
    + auto using sts.closed_op, i_states_closed, low_states_closed.
Qed.

Lemma signal_spec l P (Φ : val → iProp) :
  (send l P ★ P ★ Φ #()) ⊑ #> signal (%l) {{ Φ }}.
Proof.
  rewrite /signal /send /barrier_ctx. rewrite sep_exist_r.
  apply exist_elim=>γ. rewrite -!assoc. apply const_elim_sep_l=>?. wp_let.
  (* I think some evars here are better than repeating *everything* *)
  eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
    eauto with I ndisj.
  ecancel [sts_ownS γ _ _].
  apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
  apply const_elim_sep_l=>Hs. destruct p; last done.
  rewrite {1}/barrier_inv =>/={Hs}. rewrite later_sep.
  eapply wp_store with (v' := #0); eauto with I ndisj.
  strip_later. cancel [l ↦ #0]%I.
  apply wand_intro_l. rewrite -(exist_intro (State High I)).
  rewrite -(exist_intro ∅). rewrite const_equiv /=; last by eauto using signal_step.
  rewrite left_id -later_intro {2}/barrier_inv -!assoc. apply sep_mono_r.
  sep_split right: [Φ _]; last first.
  { apply wand_intro_l. eauto with I. }
  (* Now we come to the core of the proof: Updating from waiting to ress. *)
  rewrite /ress sep_exist_r. apply exist_mono=>{Φ} Φ.
  ecancel [Π★{set I} (λ _, saved_prop_own _ _)]%I. strip_later.
  rewrite wand_True. eapply wand_apply_l'; eauto with I.
Qed.

Lemma wait_spec l P (Φ : val → iProp) :
  (recv l P ★ (P -★ Φ #())) ⊑ #> wait (%l) {{ Φ }}.
Proof.
  rename P into R. wp_rec.
  rewrite {1}/recv /barrier_ctx. rewrite !sep_exist_r.
  apply exist_elim=>γ. rewrite !sep_exist_r. apply exist_elim=>P.
  rewrite !sep_exist_r. apply exist_elim=>Q. rewrite !sep_exist_r.
  apply exist_elim=>i. rewrite -!(assoc (★)%I). apply const_elim_sep_l=>?.
  wp_focus (! _)%E.
  (* I think some evars here are better than repeating *everything* *)
  eapply (sts_fsaS _ (wp_fsa _)) with (N0:=N) (γ0:=γ); simpl;
    eauto with I ndisj.
  ecancel [sts_ownS γ _ _].
  apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
  apply const_elim_sep_l=>Hs.
  rewrite {1}/barrier_inv =>/=. rewrite later_sep.
  eapply wp_load; eauto with I ndisj.
  ecancel [▷ l ↦{_} _]%I. strip_later.
  apply wand_intro_l. destruct p.
  { (* a Low state. The comparison fails, and we recurse. *)
    rewrite -(exist_intro (State Low I)) -(exist_intro {[ Change i ]}).
    rewrite [(■ sts.steps _ _ )%I]const_equiv /=; last by apply rtc_refl.
    rewrite left_id -[(▷ barrier_inv _ _ _)%I]later_intro {3}/barrier_inv.
    rewrite -!assoc. apply sep_mono_r, sep_mono_r, wand_intro_l.
    wp_op; first done. intros _. wp_if. rewrite !assoc.
    rewrite -always_wand_impl always_elim.
    rewrite -{2}pvs_wp. apply pvs_wand_r.
    rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro Q) -(exist_intro i).
    rewrite const_equiv // left_id -later_intro.
    ecancel_pvs [heap_ctx _; saved_prop_own _ _; Q -★ _; R -★ _; sts_ctx _ _ _]%I.
    apply sts_own_weaken; eauto using i_states_closed. }
  (* a High state: the comparison succeeds, and we perform a transition and
     return to the client *)
  rewrite [(_ ★ □ (_ → _ ))%I]sep_elim_l.
  rewrite -(exist_intro (State High (I ∖ {[ i ]}))) -(exist_intro ∅).
  change (i ∈ I) in Hs.
  rewrite const_equiv /=; last by eauto using wait_step.
  rewrite left_id -[(▷ barrier_inv _ _ _)%I]later_intro {2}/barrier_inv.
  rewrite -!assoc. apply sep_mono_r. rewrite /ress.
  rewrite !sep_exist_r. apply exist_mono=>Ψ.
  rewrite !(big_sepS_delete _ I i) //= !wand_True later_sep.
  ecancel [▷ Π★{set _} Ψ; Π★{set _} (λ _, saved_prop_own _ _)]%I.
  apply wand_intro_l.  set savedΨ := _ i (Ψ _). set savedQ := _ i Q.
  to_front [savedΨ; savedQ]. rewrite saved_prop_agree /=.
  wp_op; [|done]=> _. wp_if. rewrite !assoc. eapply wand_apply_r'; first done.
  eapply wand_apply_r'; first done.
  apply: (eq_rewrite (Ψ i) Q (λ x, x)%I); by eauto with I.
Qed.

Lemma recv_split E l P1 P2 :
  nclose N ⊆ E →
  recv l (P1 ★ P2) ⊑ |={E}=> recv l P1 ★ recv l P2.
Proof.
  rename P1 into R1. rename P2 into R2. intros HN.
  rewrite {1}/recv /barrier_ctx.
  apply exist_elim=>γ. rewrite sep_exist_r.  apply exist_elim=>P.
  apply exist_elim=>Q. apply exist_elim=>i. rewrite -!(assoc (★)%I).
  apply const_elim_sep_l=>?. rewrite -pvs_trans'.
  (* I think some evars here are better than repeating *everything* *)
  eapply pvs_mk_fsa, (sts_fsaS _ pvs_fsa) with (N0:=N) (γ0:=γ); simpl;
    eauto with I ndisj.
  ecancel [sts_ownS γ _ _].
  apply forall_intro=>-[p I]. apply wand_intro_l. rewrite -!assoc.
  apply const_elim_sep_l=>Hs. rewrite /pvs_fsa.
  eapply sep_elim_True_l.
  { eapply saved_prop_alloc_strong with (x := R1) (G := I). }
  rewrite pvs_frame_r. apply pvs_strip_pvs. rewrite sep_exist_r.
  apply exist_elim=>i1. rewrite always_and_sep_l. rewrite -assoc.
  apply const_elim_sep_l=>Hi1. eapply sep_elim_True_l.
  { eapply saved_prop_alloc_strong with (x := R2) (G := I ∪ {[ i1 ]}). }
  rewrite pvs_frame_r. apply pvs_mono. rewrite sep_exist_r.
  apply exist_elim=>i2. rewrite always_and_sep_l. rewrite -assoc.
  apply const_elim_sep_l=>Hi2.
  rewrite ->not_elem_of_union, elem_of_singleton in Hi2.
  destruct Hi2 as [Hi2 Hi12]. change (i ∈ I) in Hs.
  (* Update to new state. *)
  rewrite -(exist_intro (State p ({[i1]} ∪ ({[i2]} ∪ (I ∖ {[i]}))))).
  rewrite -(exist_intro ({[Change i1 ]} ∪ {[ Change i2 ]})).
  rewrite [(■ sts.steps _ _)%I]const_equiv; last by eauto using split_step.
  rewrite left_id {1 3}/barrier_inv.
  (* FIXME ssreflect rewrite fails if there are evars around. Also, this is very slow because we don't have a proof mode. *)
  rewrite -(ress_split _ _ _ Q R1 R2); [|done..].
  rewrite {1}[saved_prop_own i1 _]always_sep_dup.
  rewrite {1}[saved_prop_own i2 _]always_sep_dup !later_sep.
  rewrite -![(▷ saved_prop_own _ _)%I]later_intro.
  ecancel [▷ l ↦ _; saved_prop_own i1 _; saved_prop_own i2 _ ;
           ▷ ress _ _ ; ▷ (Q -★ _) ; saved_prop_own i _]%I.
  apply wand_intro_l. rewrite !assoc. rewrite /recv.
  rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro R1) -(exist_intro i1).
  rewrite -(exist_intro γ) -(exist_intro P) -(exist_intro R2) -(exist_intro i2).
  rewrite [heap_ctx _]always_sep_dup [sts_ctx _ _ _]always_sep_dup.
  rewrite /barrier_ctx const_equiv // left_id.
  ecancel_pvs [saved_prop_own i1 _; saved_prop_own i2 _; heap_ctx _; heap_ctx _;
               sts_ctx _ _ _; sts_ctx _ _ _].
  rewrite !wand_diag later_True !right_id.
  rewrite -sts_ownS_op; eauto using i_states_closed.
  - apply sts_own_weaken;
      eauto using sts.closed_op, i_states_closed. set_solver.
  - set_solver.
Qed.

Lemma recv_weaken l P1 P2 :
  (P1 -★ P2) ⊑ (recv l P1 -★ recv l P2).
Proof.
  apply wand_intro_l. rewrite /recv. rewrite sep_exist_r. apply exist_mono=>γ.
  rewrite sep_exist_r. apply exist_mono=>P. rewrite sep_exist_r.
  apply exist_mono=>Q. rewrite sep_exist_r. apply exist_mono=>i.
  ecancel [barrier_ctx _ _ _; sts_ownS _ _ _; saved_prop_own _ _].
  strip_later. apply wand_intro_l. by rewrite !assoc wand_elim_r wand_elim_r.
Qed.

Lemma recv_mono l P1 P2 :
  P1 ⊑ P2 → recv l P1 ⊑ recv l P2.
Proof.
  intros HP%entails_wand. apply wand_entails. rewrite HP. apply recv_weaken.
Qed.

End proof.


Theorem test (A:Prop) : A \/ A -> A.
  Fail let H := idtac in intros H; destruct H as H'.
  (* Disjunctive/conjunctive introduction pattern expected. *)
  Fail let H' := idtac in intros H; destruct H as H'.
Abort.


Require Import mathcomp.ssreflect.all_ssreflect.
Require Import Paco.paco.
Require Import Int63.

Require Import Utils.ZooidTac.
Require Import Zooid2.Types.

Set Implicit Arguments.
Set Primitive Projections.

(*Inductive subT : Type -> Type -> Prop :=
| subT_eq T : subT T T
| subT_sumL T S1 S2 : subT T S1 -> subT T (S1 + S2)
| subT_sumR T S1 S2 : subT T S2 -> subT T (S1 + S2)
| subT_sumLR T1 T2 S1 S2 :
  subT T1 S1 -> subT T2 S2 -> subT (T1 + T2) (S1 + S2)
| subT_sumRL T1 T2 S1 S2 :
  subT T1 S1 -> subT T2 S2 -> subT (T2 + T1) (S1 + S2)
.

Definition sum_map {A B C : Type} (f1 : A -> C) (f2 : B -> C)
  : A + B -> C :=
  fun s =>
    match s with
    | inl a => f1 a
    | inr b => f2 b
    end.

Inductive subTf : forall (T S: Type), ((T -> nat) -> (S -> nat) -> Prop) :=
| subTf_eq T f: @subTf T T f f
| subTf_sumL T S1 S2 f g1 g2:
  subT T S1 ->
  @subTf T S1 f g1 ->
  @subTf T (S1 + S2) f (sum_map g1 g2)
| subTf_sumR T S1 S2 f g1 g2:
  subT T S2 ->
  @subTf T S2 f g2 ->
  @subTf T (S1 + S2) f (sum_map g1 g2)
| subTf_sumLR T1 T2 S1 S2 f1 f2 g1 g2:
  subT T1 S1 -> subT T2 S2 ->
  @subTf T1 S1 f1 g1 -> @subTf T2 S2 f2 g2 ->
  @subTf (T1 + T2) (S1 + S2) (sum_map f1 f2) (sum_map g1 g2)
| subTf_sumRL T1 T2 S1 S2 f1 f2 g1 g2:
  subT T1 S1 -> subT T2 S2 ->
  @subTf T1 S1 f1 g1 -> @subTf T2 S2 f2 g2 ->
  @subTf (T2 + T1) (S1 + S2) (sum_map f2 f1) (sum_map g1 g2)
.

Definition sub_altT (AT1 AT2 : AltT) :=
  subT AT1.(sumT) AT2.(sumT) /\ subTf AT1.(sumT_alt) AT2.(sumT_alt).*)

Definition is_k_def {A} n k :=
  match @find_k A n k with
  | b_bot => true
  | _ => false
  end.

Inductive subtype_ (S : LocalType -> LocalType -> Prop)
  : LocalType -> LocalType -> Prop :=
| sub_bot: @subtype_ S b_bot b_bot
| sub_end: @subtype_ S b_end b_end
| sub_send L1 L2 AT a k1 k2:
  b_unroll L1 = b_act AT a k1 ->
  b_unroll L2 = b_act AT a k2 ->
  lact a = a_send ->
  (*(forall n, find_k_bot n k1 == find_k_bot n k2)->*)
  (forall n, S (find_k n k1) (find_k n k2)) ->
  @subtype_ S L1 L2
| sub_recv L1 L2 AT a k1 k2:
  b_unroll L1 = b_act AT a k1 ->
  b_unroll L2 = b_act AT a k2 ->
  lact a = a_recv ->
  (*(forall n, is_k_def n k2 -> is_k_def n k1) ->*)
  (forall n, is_k_def n k2 -> S (find_k n k1) (find_k n k2)) ->
  @subtype_ S L1 L2
.

Derive Inversion subtype_inv with
    (forall S L1 L2, @subtype_ S L1 L2) Sort Prop.
Definition subtype := paco2 (subtype_) bot2.

Lemma subtype_monotone: monotone2 (subtype_).
Proof.
  move=> L1 L2 r r' H0 H1;  case: H0.
  - by constructor.
  - by constructor.
  - move=> {}L1 {}L2 AT a k1 k2 u1 u2 sd hp.
    by apply: (sub_send r' _ _ u1 u2 sd)=>n; apply H1, hp.
  - move=> {}L1 {}L2 AT a k1 k2 u1 u2 sd hp.
    by apply: (sub_recv r' _ _ u1 u2 sd)=>n hp'; apply H1, hp.
Qed.

Check subtype.
Check lty_accepts.

Lemma subtype_trace (L1 L2: LocalType) p TRC:
  @subtype L1 L2 -> @lty_accepts p TRC L1 -> @lty_accepts p TRC L2.
Proof.
  move=> sub t1; move: (conj sub t1)=>{sub t1}.
  move=> /(ex_intro (fun L1=> _) L1) {L1}.
  move: TRC L2; apply /paco2_acc=> r _ cih.
  move: cih=>/(_ _ _ (ex_intro _ _ (conj _ _))).
  move=> cih t L2 [L1 [sub tra1]].
  case u1: (b_unroll L1).
  Print b_unroll.
  Search b_unroll.
  - move=> _ /(paco2_unfold (@lty_lts_monotone p))=>[].
  Admitted.


(*
  Reduction from:
    Weak call-by-name leftmost outermost normalization of closed terms (wCBNclosed)
  to:
    Weak call-by-name leftmost outermost normalization (wCBN)
*)

From Undecidability.LambdaCalculus Require Import wCBN Util.term_facts Util.wCBN_facts.
Require Undecidability.L.Util.L_facts.
Require Import Undecidability.Synthetic.Definitions.

Set Default Goal Selector "!".

Theorem reduction : wCBNclosed ⪯ wCBN.
Proof.
  exists (@proj1_sig L.term _).
  intros [s Hs]. cbn. split.
  - intros [t Ht]. exists (L.lam t). split; [assumption|].
    intros u H%stepE. destruct H.
  - intros [t [Hst Ht]].
    assert (L_facts.closed t) as H't.
    { apply (@steps_bound 0) in Hst; [now apply L_facts.closed_dcl|].
      apply L_facts.closed_dcl. apply closed_I. intros k.
      now rewrite L_subst_wCBN_subst. }
    apply (closed_halt_iff H't) in Ht.
    destruct Ht as [t' ?]. subst t.
    exists t'. assumption.
Qed.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.

(* Why3 assumption *)
Definition unit  := unit.

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a}(v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Inductive array (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a}(v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a}(v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a}(a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a}(a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a}(n:Z) (v:a): (array a) :=
  (mk_array n (map.Map.const v:(map.Map.map Z a))).

Axiom char : Type.
Parameter char_WhyType : WhyType char.
Existing Instance char_WhyType.

(* Why3 assumption *)
Definition matches(a1:(array char)) (i1:Z) (a2:(array char)) (i2:Z)
  (n:Z): Prop := ((0%Z <= i1)%Z /\ (i1 <= ((length a1) - n)%Z)%Z) /\
  (((0%Z <= i2)%Z /\ (i2 <= ((length a2) - n)%Z)%Z) /\ forall (i:Z),
  ((0%Z <= i)%Z /\ (i < n)%Z) -> ((get a1 (i1 + i)%Z) = (get a2
  (i2 + i)%Z))).

Axiom matches_empty : forall (a1:(array char)) (a2:(array char)) (i1:Z)
  (i2:Z), ((0%Z <= i1)%Z /\ (i1 <= (length a1))%Z) -> (((0%Z <= i2)%Z /\
  (i2 <= (length a2))%Z) -> (matches a1 i1 a2 i2 0%Z)).

Axiom matches_right_extension : forall (a1:(array char)) (a2:(array char))
  (i1:Z) (i2:Z) (n:Z), (matches a1 i1 a2 i2 n) ->
  ((i1 <= (((length a1) - n)%Z - 1%Z)%Z)%Z ->
  ((i2 <= (((length a2) - n)%Z - 1%Z)%Z)%Z -> (((get a1 (i1 + n)%Z) = (get a2
  (i2 + n)%Z)) -> (matches a1 i1 a2 i2 (n + 1%Z)%Z)))).

(* Why3 goal *)
Theorem matches_contradiction_at_first : forall (a1:(array char)) (a2:(array
  char)) (i1:Z) (i2:Z) (n:Z), (0%Z < n)%Z -> ((~ ((get a1 i1) = (get a2
  i2))) -> ~ (matches a1 i1 a2 i2 n)).
Proof.
unfold get.
intros (n1,a1) (n2,a2) i1 i2 n Hn.
simpl; intro Heq.
red.
 intro Hmatch.
 elim Hmatch; simpl; intros (h0,h1) (h2,h3).
absurd (Map.get a1 i1 = Map.get a2 i2); [ assumption | idtac ].
replace i1 with (i1 + 0)%Z.
 replace i2 with (i2 + 0)%Z.
apply (h3 0%Z).
omega.
omega.
omega.
Qed.


From Coq Require Import
     Morphisms.

From ExtLib Require Import
     Structures.Monad.

From Paco Require Import paco.

From ITree Require Import
     Axioms
     ITree
     ITreeFacts
     Props.Infinite
     Props.EuttNoRet.

From ITree.Extra Require Import
     Dijkstra.DijkstraMonad
     Dijkstra.PureITreeBasics
     Dijkstra.DelaySpecMonad
     ITrace.ITraceDefinition
     ITrace.ITraceFacts
     ITrace.ITraceBind
     ITrace.ITracePreds.

Import Monads.
Import MonadNotation.

#[local] Open Scope monad_scope.
#[local] Open Scope delayspec_scope.

(** Contains TraceSpec, the type family of Specification Monads for uninterpretted ITrees. Also contains the effect observation from ITrees into TraceSpec and the proof that it is a monad morphism *)

Section TraceSpec.
  Context (E : Type -> Type).

  Definition TraceSpecInput (A : Type) := {p : itrace E A -> Prop | resp_eutt p}.

  Instance proper_eutt_spec_in {A} {p : TraceSpecInput A} : Proper (@eutt _ A A eq ==> iff) (proj1_sig p).
  Proof.
    intros b1 b2 Heutt. destruct p as [p Hp]. simpl. split; intros;
    eapply Hp; try apply H; auto. symmetry. auto.
  Qed.

  Definition TraceSpec (A : Type) := ev_list E -> {w : TraceSpecInput A -> Prop |
                                      forall (p p' : TraceSpecInput A), (forall b, b ∈ p -> b ∈ p') -> w p -> w p'  }.

  #[global] Instance EqM_TraceSpec : Eq1 TraceSpec := fun _ w1 w2 => forall log p, w1 log ∋ p <-> w2 log ∋ p.
  #[global] Instance EqMTS_equiv {R}: Equivalence (EqM_TraceSpec R).
  Proof.
    do 2 constructor; unfold EqM_TraceSpec in *; intros; try apply H0; try apply H; auto.
    apply H0. auto.
  Qed.

  (* look over this code *)
  (* https://github.com/FStarLang/FStar/blob/dm4all/examples/dm4all/IORWLocal.fst *)

  Notation "↑ log" := (ev_list_to_stream log) (at level 30).

  Program Definition ret_ts1 {A : Type} (a : A) : TraceSpec A := fun log p => p ( Ret a).

  Program Definition ret_ts2 {A : Type} (a : A) : TraceSpec A := fun log p => p (↑log ++ Ret a).

  (* RE : forall A B, E1 A -> A -> E2 B -> B -> Prop
     (forall a1 a2, RE e1 a1 e2 a2 -> corec (k1 a1) (k2 a2)) -> eutt VisF e1 k1 VisF e2 k2

*)

  Program Definition bind_ts1_all {A B : Type} (w : TraceSpec A) (g : A -> TraceSpec B) :=
    fun log p => w log (fun b : itree (EvAns E) A  => (forall a log', b ≈ (↑log' ++ Ret a) -> g a log' p ) /\ (all_infinite b -> p (noret_cast b) )  ).
  Next Obligation.
    intros b1 b2 Heutt. split; intros; split; basic_solve.
    - apply H. rewrite Heutt. auto.
    - rewrite <- Heutt. apply H1. rewrite Heutt. auto.
    - apply H. rewrite <- Heutt. auto.
    - rewrite Heutt. apply H1. rewrite <- Heutt. auto.
  Qed.

  Program Definition bind_ts1 {A B : Type} (w : TraceSpec A) (g : A -> TraceSpec B) : TraceSpec B :=
    fun log p => w log (fun b : itree (EvAns E) A => (exists a, exists log', b ≈ (↑log' ++ Ret a)  /\ g a log' p) \/
                                 (all_infinite b /\ p (noret_cast b )) ).
  Next Obligation.
    intros b1 b2 Heutt. split; intros; basic_solve.
    - left. exists a. exists log'.
      rewrite <- Heutt. auto.
    - right. rewrite <- Heutt. auto.
    - left. exists a. exists log'. rewrite Heutt.
      auto.
    - right. rewrite Heutt. auto.
  Qed.
  Next Obligation.
    destruct (w log) as [wl Hwl]. simpl in *.
    eapply Hwl; try apply H0. simpl. clear H0. intros.
    basic_solve.
    - left. exists a. exists log'. split; auto.
      destruct (g a log') as [gal Hgal]. simpl in *.
      eapply Hgal; try apply H1. auto.
    - right. auto.
 Qed.

  #[global] Instance TraceSpecMonad : Monad TraceSpec :=
    {
      ret := @ret_ts2;
      bind := @bind_ts1;
    }.

  (*If initial logs are allow to be inf, and b in inf then for any a there is some log,
    b = log ++ ret a, even if b never actually returns it, this is problematic, so I will
    restrict it, I think this restriction is justifiable*)

  Lemma apply_monot : forall (A : Type) (w : TraceSpec A) (log : ev_list E) (p p' : TraceSpecInput A),
      (forall b, p ∋ b -> p' ∋ b) -> w log ∋ p -> w log ∋ p'.
  Proof.
    intros. destruct (w log) as [w' Hw'].
    simpl in *. eauto.
  Qed.

  #[global] Program Instance TraceSpecMonadLaws : MonadLawsE TraceSpec.
  Next Obligation.
    rename x into a.
    red. red. cbn. split; intros; basic_solve.
    - apply inv_append_eutt in H. destruct H. subst. auto.
    - exfalso. assert (may_converge a (↑ log ++ Ret a) ).
      { apply may_converge_append. apply finite_list_to_stream. }
      eapply all_infinite_not_converge; eauto.
    - left. exists a. exists log. split; auto. reflexivity.
  Qed.
  Next Obligation.
    rename x into w. red. red. cbn. split; intros; basic_solve.
    - eapply apply_monot; try apply H. clear H.
      simpl. intros. basic_solve.
      + rewrite H. auto.
      + apply noret_cast_nop in H.
        rewrite H. auto.
    - eapply apply_monot; try apply H. clear H.
      intros. simpl. destruct (classic_converge_itrace b).
      + basic_solve. left. exists r. exists log0. split.
        * symmetry. auto.
        * rewrite H0. auto.
      + right. split; auto. rewrite noret_cast_nop in H; auto.
  Qed.
  Next Obligation.
    rename x into w.
    red. red. cbn. split; intros; basic_solve.
    - eapply apply_monot; try apply H. clear H. simpl. intros.
      basic_solve.
      + left. exists a. exists log'. auto.
      + exfalso.
        assert (may_converge a (↑log' ++ Ret a) ).
        { apply may_converge_append. apply finite_list_to_stream. }
        assert (all_infinite (@noret_cast (EvAns E) A A b) ).
        { apply all_infinite_bind. auto. }
        rewrite <- H0 in H2. unfold noret_cast in H3. cbn in H3.
        eapply all_infinite_not_converge with (r := a) ; eauto.
        apply all_infinite_bind. auto.
      + right. split; auto.
        destruct p as [p Hp]. simpl in *. eapply Hp; try apply H1.
        eapply eutt_clo_bind with (UU := fun a b => False); intuition.
        apply noret_bind_nop. auto.
    - eapply apply_monot; try apply H. clear H. simpl. intros.
      basic_solve.
      + left. exists a. exists log'. auto.
      + right. split; auto. right. split.
        * apply all_infinite_bind. auto.
        * destruct p as [p Hp]. simpl in *. eapply Hp; try apply H0.
          eapply eutt_clo_bind with (UU := fun a b => False); intuition.
          apply euttNoRet_sym. apply noret_bind_nop. auto.
   Qed.
  Next Obligation.
    intros w1 w2 Hw k1 k2 Hk. do 2 red in Hw. do 3 red in Hk.
    repeat red. unfold bind_ts1. simpl. split; intros.
    - rewrite <- Hw. destruct (w1 log) as [w1l Hw1l]; simpl in *. eapply Hw1l; try apply H;
      simpl. intros. basic_solve; auto.
      left. exists a. exists log'. split; auto. rewrite <- Hk. auto.
    - rewrite Hw. destruct (w2 log) as [w2l Hw2l]; simpl in *. eapply Hw2l; try apply H;
      simpl. intros. basic_solve; auto.
      left. exists a. exists log'. split; auto. rewrite Hk. auto.
  Qed.

  Program Definition obs_trace (A : Type) (t : itree E A) : TraceSpec A :=
    fun log p => forall b, b ⊑ t -> p (↑log ++ b).

  #[global] Instance TraceSpecObs : EffectObs (itree E) TraceSpec := obs_trace.

  Lemma bind_split_diverge:
    forall (A B : Type) (log : ev_list E) (p : TraceSpecInput B) (b : itrace E B)
      (b' : itree (EvAns E) A) (g' : A -> itree (EvAns E) B),
      (ITree.bind b' g' ≈ b)%itree ->
      all_infinite (↑ log ++ b') ->
      p ∋ ITree.bind (↑ log ++ b') (fun _ : A => ITree.spin) -> p ∋ ↑ log ++ b.
  Proof.
    intros A B log p b b' g' Hsplit Hdiv Hp.
    rewrite <- Hsplit.
    enough (↑ log ++ ITree.bind b' g' ≈ ITree.bind (↑ log ++ b') (fun _ => ITree.spin)).
    { rewrite H. auto. }
    unfold append. rewrite bind_bind.
    eapply eutt_clo_bind with (RR := eq) (UU := eq); try reflexivity.
    intros. apply euttNoRet_subrel. eapply euttNoRet_trans with (t2 := b').
    + apply euttNoRet_sym. apply noret_bind_nop. eapply all_infinite_bind_append; eauto.
    + apply noret_bind_nop. eapply all_infinite_bind_append; eauto.
  Qed.

  #[global] Instance TraceSpecMorph : MonadMorphism (itree E) TraceSpec TraceSpecObs.
  Proof.
    constructor.
    - intros. repeat red. unfold obs, TraceSpecObs. cbn. split; intros.
      + apply H. apply trace_refine_ret.
      + apply trace_refine_ret_inv_l in H0.
        rewrite H0. auto.
    - intros. repeat red. cbn.
      split; intros.
      + destruct (classic_converge_itrace b); basic_solve.
        * left. exists r. setoid_rewrite <- H1.
          exists (log ++ log0)%list. split.
          ++ rewrite append_assoc. reflexivity.
          ++ intros bf Hbf.
             set (fun r : A => bf) as g.
             assert ( ITree.bind b g ≈ (↑log0 ++ bf) ).
             {
               rewrite <- H1. unfold append. rewrite bind_bind.
               setoid_rewrite bind_ret_l. unfold g. reflexivity.
             }
             rewrite append_assoc. rewrite <- H2. apply H.
             unfold g. apply trace_refine_converge_bind with (r := r); auto.
             rewrite <- H1. apply may_converge_append. apply finite_list_to_stream.
        * right. split.
          ++ apply append_div; auto.
          ++ unfold append.
             rewrite bind_bind. apply H.
             apply trace_refine_diverge_bind; auto.
     + apply decompose_trace_refine_bind in H0 as Hbind.
       basic_solve. apply H in H2 as ?H. destruct (classic_converge_itrace b'); basic_solve.
       *
         (* easily convince myself that H is unused without needing the refactor rest*)
         clear H. assert (H : True); auto.

         assert (Hbind : (ITree.bind b' g' ⊑ ITree.bind m f)).
         { rewrite H1. auto. }
         rewrite <- H4 in H1.
         setoid_rewrite bind_bind in H1.
         setoid_rewrite bind_ret_l in H1.
         assert (↑ log0 ++ (g' r) ≈ b)%itree; auto. clear H1.
         specialize (H5 (g' r) ).  rewrite <- H6 in H0.

         assert (↑log ++ b ≈ ↑log' ++ g' r /\ a = r)%itree.
         {
           rewrite <- H6. rewrite <- H4 in H3.
           rewrite <- append_assoc. rewrite <- append_assoc in H3. apply inv_append_eutt in H3.
           destruct H3. subst. split; reflexivity.
         }
         destruct H1 as [Hevsplit ?]. subst. rewrite Hevsplit.
         (*Hevsplit : log ++ n ≈ log' ++ g' r*)
         apply H5.
         (* then need to show g' r ⊑ f r*)
         rewrite H6 in H0.
         (* comes from trace_refine_bind_cont_inv
            because b' converges to r and b' >>= g' ⊑ m >>= f
          *)
         apply trace_refine_bind_cont_inv with (r:= r) in Hbind; auto.
         rewrite <- H4. eapply may_converge_append. apply finite_list_to_stream.
       * eapply bind_split_diverge; eauto.
       * assert (may_converge a b').
         { eapply may_converge_two_list; eauto. }
         exfalso. eapply all_infinite_not_converge; eauto.
       * eapply bind_split_diverge; eauto.
  Qed.

  #[global] Instance TraceSpecOrder : OrderM TraceSpec :=
    fun _ w1 w2 => forall log p, p ∈ (w2 log) -> p ∈ (w1 log).

  #[global] Instance TraceSpecOrderLaws : OrderedMonad TraceSpec.
  Proof.
    constructor.
    - intros. repeat red. auto.
    - intros. repeat red in H. repeat red in H0.
      repeat red. intros. apply H. apply H0. auto.
    - intros. repeat red in H0. repeat red in H. repeat red. intros. repeat red in H1.
      eapply H. destruct (w2 log) as [w2' Hw2]. cbn. eapply Hw2; try apply H1.
      intros. cbn in *. basic_solve.
      + left. exists a. exists log'. split; auto.
        eapply H0. auto.
      + right. auto.
  Qed.

  Definition verify_cond {A : Type} : TraceSpec A -> itree E A -> Prop :=
    DijkstraProp (itree E) TraceSpec TraceSpecObs A.

  Program Definition encode {A : Type} (post : itrace E A -> Prop) (pre : ev_list E -> Prop) : TraceSpec A :=
    fun log p => pre log /\ forall b, post (↑ log ++ b) -> p (↑ log ++ b).

  Program Definition encode_dyn {A : Type} (post : ev_list E -> itrace E A -> Prop) (pre : ev_list E -> Prop) : TraceSpec A :=
    fun log p => pre log /\ forall b, post log (↑ log ++ b) -> p (↑ log ++ b).

End TraceSpec.

Arguments TraceSpecMonad {E}.
Arguments TraceSpecMonadLaws {E}.
Arguments TraceSpecOrder {E}.
Arguments TraceSpecOrderLaws {E}.
Arguments TraceSpecObs {E}.
Arguments TraceSpecMorph {E}.

Section NonDetExample.

Variant NonDet : Type -> Type :=
  Decide : NonDet bool.

Definition decide_ex : itree NonDet unit :=
  ITree.iter (fun _ => ITree.bind (trigger Decide) (fun b : bool => if b then Ret (inl tt) else Ret (inr tt) )) tt.

Definition decide_ex_pre : ev_list NonDet -> Prop := fun log => log = nil.

Variant is_bool (b : bool) : forall A, EvAns NonDet A -> Prop :=
  | is_bool_matches : is_bool b unit (evans bool Decide b)
.

Hint Constructors is_bool : itree.

Definition fal_decide_ex : itrace NonDet unit -> Prop :=
  front_and_last (is_bool true) (is_bool false) (fun _ => True).

Definition decide_ex_post : itrace NonDet unit -> Prop :=
  fun b => (all_infinite b -> trace_forall (is_bool true) (fun _ => True) b) /\
        (may_converge tt b -> fal_decide_ex b).

Lemma decide_ex_satisfies_spec : verify_cond NonDet (encode NonDet decide_ex_post decide_ex_pre ) decide_ex.
Proof.
  repeat red. cbn. intros. destruct H as [Hlog H].
  red in Hlog. apply H. clear H. subst. cbn. red. split; intros.
  - unfold append in *. rewrite bind_ret_l in H. rewrite bind_ret_l.
    unfold decide_ex in *.
    generalize dependent b. pcofix CIH. intros b Hb Hdiv.
    pfold. red.
    rewrite unfold_iter in Hb at 1. rewrite bind_bind in Hb.
    apply bind_trigger_refine in Hb as Hb'; try (exists true; auto).
    basic_solve. destruct a.
    + rewrite bind_ret_l in H0. cbn in H0. rewrite tau_eutt in H0.
      punfold H. red in H. cbn in H. clear Hb.
      enough (paco1 (trace_forall_ (is_bool true) (fun _ => True) ) r b).
      { punfold H1. }
      dependent induction H.
      *  pfold. red. rewrite <- x. constructor; auto with itree. intros.
        destruct a. right. pclearbot. eapply CIH.
        ++ assert (k1 tt ≈ k' tt)%itree; try apply REL.
           rewrite H. auto.
        ++ apply simpobs in x. rewrite x in Hdiv. pinversion Hdiv.
           ddestruction. apply H1.
      *  pfold. red. rewrite <- x. constructor. left.  eapply IHeqitF; eauto.
         apply simpobs in x. rewrite x in Hdiv. rewrite tau_eutt in Hdiv. auto.
   + rewrite bind_ret_l in H0. cbn in H0. apply trace_refine_ret_inv_l in H0.
     rewrite H in Hdiv. pinversion Hdiv. ddestruction.
     specialize (H2 tt).
     rewrite H0 in H2. pinversion H2.
  - red. rewrite append_nil. rewrite append_nil in H. unfold decide_ex in *.
    induction H.
    + exfalso. rewrite H in H0. rewrite unfold_iter in H0.
      rewrite bind_bind in H0. rewrite bind_trigger in H0.
      revert H0; apply refine_ret_vis_contra.
    + rewrite H. destruct e; try contradiction.
      destruct b. destruct ev. destruct ans.
      * eapply front_and_last_cons; eauto; try reflexivity. apply IHmay_converge.
        clear IHmay_converge. rewrite unfold_iter in H0. rewrite bind_bind in H0.
        rewrite H in H0. eapply bind_trigger_refine in H0; try (exists true; auto).
        basic_solve.
        pinversion H0. ddestruction.
        assert (k tt ≈ k' tt)%itree; try apply REL. rewrite bind_ret_l in H2.
        cbn in *. rewrite tau_eutt in H2. rewrite H3. auto.
      * clear IHmay_converge. rewrite unfold_iter in H0. rewrite bind_bind in H0.
        rewrite H in H0. eapply bind_trigger_refine in H0; try (exists true; auto).
        basic_solve.
        pinversion H0. ddestruction.
        rewrite bind_ret_l in H2. cbn in H2.
        apply trace_refine_ret_inv_l in H2.
        eapply front_and_last_base with (r := tt); eauto with itree.
        pfold. red. cbn. constructor. intros. left.
        rewrite <- H2. destruct v. auto.
  Qed.

End NonDetExample.


Require Import VST.floyd.proofauto.
Require Import CertiGraph.binheap.binary_heap_Zmodel.
Require Export CertiGraph.binheap.binary_heap_pro.
Require Export CertiGraph.binheap.env_binary_heap_pro.

Definition exch_spec :=
  DECLARE _exch WITH j : Z, k : Z, arr: val, arr_contents: list heap_item, lookup : val, lookup_contents : list Z
  PRE [tuint, tuint, tptr t_item, tptr tuint]
  PROP (0 <= j < Zlength arr_contents; 0 <= k < Zlength arr_contents;
        Zlength arr_contents <= Int.max_unsigned;
        Zlength lookup_contents <= Int.max_unsigned)
    PARAMS (Vint (Int.repr j); Vint (Int.repr k); arr; lookup)
    GLOBALS ()
    SEP (linked_heap_array arr_contents arr lookup_contents lookup)
  POST [tvoid]
    EX lookup_contents' : list Z,
      PROP (lookup_oob_eq (Zexchange arr_contents j k) lookup_contents lookup_contents')
      LOCAL ()
      SEP (linked_heap_array (Zexchange arr_contents j k) arr lookup_contents' lookup).

Definition less_spec :=
  DECLARE _less WITH i : Z, j : Z, arr: val, arr_contents: list heap_item, arr' : val, lookup : list Z
  PRE [tuint, tuint, tptr t_item]
    PROP (0 <= i < Zlength arr_contents; 0 <= j < Zlength arr_contents;
          Zlength arr_contents <= Int.max_unsigned)
    PARAMS (Vint (Int.repr i); Vint (Int.repr j); arr)
    GLOBALS ()
    SEP (linked_heap_array arr_contents arr lookup arr')
  POST [tint]
    PROP ()
    LOCAL (temp ret_temp (Val.of_bool (cmp (Znth i arr_contents) (Znth j arr_contents))))
    SEP (linked_heap_array arr_contents arr lookup arr').

Definition swim_spec :=
  DECLARE _swim WITH k : Z, arr: val, arr_contents: list heap_item, lookup : val, lookup_contents : list Z
  PRE [tuint, tptr t_item, tptr tuint]
    PROP (0 <= k < Zlength arr_contents;
          weak_heap_ordered_bottom_up arr_contents k;
          Zlength arr_contents <= Int.max_unsigned;
          Zlength lookup_contents <= Int.max_unsigned)
    PARAMS (Vint (Int.repr k); arr; lookup)
    GLOBALS ()
    SEP (linked_heap_array arr_contents arr lookup_contents lookup)
  POST [tvoid]
    EX arr_contents' : list (Z * int * int), EX lookup_contents' : list Z,
      PROP (lookup_oob_eq arr_contents' lookup_contents lookup_contents';
            heap_ordered arr_contents'; Permutation arr_contents arr_contents')
      LOCAL ()
      SEP (linked_heap_array arr_contents' arr lookup_contents' lookup).

Definition sink_spec :=
  DECLARE _sink WITH k : Z, arr: val, arr_contents: list heap_item, first_available : Z, lookup : val, lookup_contents : list Z
  PRE [tuint, tptr t_item, tuint, tptr tuint]
    PROP (0 <= k <= Zlength arr_contents;
          first_available = Zlength arr_contents;
          (k = Zlength arr_contents -> (2 * k) <= Int.max_unsigned);
          (k < Zlength arr_contents -> (2 * (first_available - 1) <= Int.max_unsigned)); (* i = fa - 1 -> (2 * i + 1) = 2 * fa - 1, must be representable *)
          weak_heap_ordered_top_down arr_contents k;
          Zlength lookup_contents <= Int.max_unsigned)
    PARAMS (Vint (Int.repr k); arr; Vint (Int.repr first_available); lookup)
    GLOBALS ()
    SEP (linked_heap_array arr_contents arr lookup_contents lookup)
  POST [tvoid]
    EX arr_contents' : list heap_item, EX lookup_contents' : list Z,
      PROP (lookup_oob_eq arr_contents' lookup_contents lookup_contents';
            heap_ordered arr_contents'; Permutation arr_contents arr_contents')
      LOCAL ()
      SEP (linked_heap_array arr_contents' arr lookup_contents' lookup).

Definition pq_size_spec :=
  DECLARE _pq_size WITH pq : val, h : heap
  PRE [tptr t_pq]
    PROP ()
    PARAMS (pq)
    GLOBALS ()
    SEP (valid_pq pq h)
  POST [tuint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (heap_size h))))
    SEP (valid_pq pq h).

Definition capacity_spec :=
  DECLARE _capacity WITH pq : val, h : heap
  PRE [tptr t_pq]
    PROP ()
    PARAMS (pq)
    GLOBALS ()
    SEP (valid_pq pq h)
  POST [tuint]
    PROP ()
    LOCAL (temp ret_temp (Vint (Int.repr (heap_capacity h))))
    SEP (valid_pq pq h).

Definition pq_remove_min_nc_spec :=
  DECLARE _pq_remove_min_nc WITH pq : val, h : heap, i : val
  PRE [tptr t_pq, tptr t_item]
    PROP (heap_size h > 0)
    PARAMS (pq; i)
    GLOBALS ()
    SEP (valid_pq pq h; hitem_ i)
  POST [tvoid]
  EX h', EX iv : heap_item,
    PROP (heap_capacity h = heap_capacity h';
          Permutation (heap_items h) (iv :: heap_items h');
          Forall (cmp_rel iv) (heap_items h'))
    LOCAL ()
    SEP (valid_pq pq h'; hitem iv i).

Definition pq_insert_nc_spec :=
  DECLARE _pq_insert_nc WITH pq : val, h : heap, priority : Z, data : int
  PRE [tptr t_pq, tint, tint]
    PROP (heap_size h < heap_capacity h)
    PARAMS (pq; Vint (Int.repr priority); Vint data)
    GLOBALS ()
    SEP (valid_pq pq h)
  POST [tuint]
  EX h' : heap, EX key : Z,
    PROP (heap_capacity h = heap_capacity h';
          Permutation (((key, Int.repr priority, data): heap_item) :: heap_items h) (heap_items h'))
    LOCAL (temp ret_temp (Vint (Int.repr key)))
    SEP (valid_pq pq h').

Definition pq_make_spec :=
  DECLARE _pq_make WITH size : Z
  PRE [tuint]
  PROP (4 <= 12 * size <= Int.max_unsigned)
    PARAMS (Vint (Int.repr size))
    GLOBALS ()
    SEP ()
  POST [tptr t_pq]
    EX pq: val, EX h : heap,
    PROP (heap_size h = 0;
         heap_capacity h = size)
    LOCAL (temp ret_temp pq)
    SEP (valid_pq pq h). (* and the free_toks I get from mallocN *)

Definition pq_free_spec :=
  DECLARE _pq_free WITH pq : val, h : heap
  PRE [tptr t_pq]
  PROP ()
    PARAMS (pq)
    GLOBALS ()
    SEP (valid_pq pq h) (* and the free toks I get from pq_make*)
  POST [tvoid]
    PROP ()
    LOCAL ()
    SEP (emp).

Definition pq_edit_priority_spec :=
  DECLARE _pq_edit_priority WITH pq : val, h : heap, key : Z, newpri : int
  PRE [tptr t_pq, tint, tint]
  PROP (In key (proj_keys h))
    PARAMS (pq; Vint (Int.repr (key)); Vint newpri)
    GLOBALS ()
    SEP (valid_pq pq h) (* and the free toks I get from pq_make*)
  POST [tvoid]
    EX h': heap,
    PROP (Permutation (heap_items h') (update_pri_by_key (heap_items h) key newpri);
         heap_capacity h' = heap_capacity h)
    LOCAL ()
    SEP (valid_pq pq h').


From demo Require Import simplified_iris.
From stdpp Require Import list.

Open Scope Z_scope.

Definition insert: val :=
  rec: "insert" "t" "x" :=
    match: !"t" with
      NONE => "t" <- InjR ("x", (ref NONE, ref NONE))
    | SOME "node" =>
      let: "v" := Fst "node" in
      let: "l" := Fst (Snd "node") in
      let: "r" := Snd (Snd "node") in
      if: "x" = "v"
      then #()
      else (if: "x" < "v"
            then "insert" "l" "x"
            else "insert" "r" "x")
    end.

Definition search: val :=
  rec: "search" "t" "x" :=
    match: !"t" with
      NONE => #false
    | SOME "node" =>
      let: "v" := Fst "node" in
      let: "l" := Fst (Snd "node") in
      let: "r" := Snd (Snd "node") in
      if: "x" = "v"
      then #true
      else (if: "x" < "v"
            then "search" "l" "x"
            else "search" "r" "x")
    end.

Section proof.
Context `{!heapGS Σ}.
Implicit Types (t l r:loc).

Definition tree_pre (tree: loc -d> gset Z -d> iPropO Σ): loc -d> gset Z -d> iPropO Σ :=
  (λ t els, (⌜els = ∅⌝ ∧ t ↦ NONEV) ∨
    (∃ left_els right_els (key: Z) l r,
        ⌜els = {[key]} ∪ left_els ∪ right_els⌝ ∗
        ⌜∀ e, e ∈ left_els → e < key⌝ ∗
        ⌜∀ e, e ∈ right_els → key < e⌝ ∗
        t ↦ SOMEV (#key, (#l, #r)) ∗
        ▷ tree l left_els ∗ ▷ tree r right_els))%I.

Local Instance tree_pre_contractive : Contractive tree_pre.
Proof. solve_contractive. Qed.

Definition tree : loc → gset Z → iProp Σ := fixpoint tree_pre.

Theorem tree_unfold t els :
  tree t els ⊣⊢
  (⌜els = ∅⌝ ∧ t ↦ NONEV) ∨
    (∃ left_els right_els (key: Z) l r,
        ⌜els = {[key]} ∪ left_els ∪ right_els⌝ ∗
        ⌜∀ e, e ∈ left_els → e < key⌝ ∗
        ⌜∀ e, e ∈ right_els → key < e⌝ ∗
        t ↦ SOMEV (#key, (#l, #r)) ∗
        ▷ tree l left_els ∗ ▷ tree r right_els).
Proof. apply (fixpoint_unfold tree_pre). Qed.

Lemma tree_empty t :
  t ↦ NONEV -∗ tree t ∅.
Proof.
  iIntros "Ht".
  iApply tree_unfold; iLeft; auto.
Qed.

Theorem wp_tree_insert t (x:Z) els :
  {{{ tree t els }}}
    insert #t #x
  {{{ RET #(); tree t ({[x]} ∪ els) }}}.
Proof.
  iLöb as "IH" forall (t els).
  iIntros (Φ) "Ht HΦ".
  wp_rec; wp_pures.
  iDestruct (tree_unfold with "Ht") as "[Ht|Ht]".
  - iDestruct "Ht" as (->) "Ht".
    (* this is just "symbolic execution", directed by the program syntax *)
    wp_load; wp_pures.
    wp_alloc r.
    wp_alloc l.
    wp_store.
    iApply "HΦ".
    iModIntro.

    (* here we build a singleton [tree] predicate out of points-to facts *)
    iApply tree_unfold.
    iRight.
    iExists ∅, ∅, _, _, _.
    iFrame.
    iSplit; first by (iPureIntro; set_solver).
    iSplit; first by (iPureIntro; set_solver).
    iSplit; first by (iPureIntro; set_solver).
    rewrite -!tree_empty.
    iFrame.
  - iDestruct "Ht" as (????? -> Hleft Hright) "(Ht&Hl&Hr)".
    wp_load; wp_pures.
    case_bool_decide as Heqb; wp_pures.
    + iModIntro.
      inversion Heqb; subst.
      iApply "HΦ".

      (* another [tree] separation logic theorem (no code involved) *)
      rewrite !assoc_L.
      replace {[key; key]} with ({[key]}: gset Z) by set_solver.
      iApply tree_unfold; iRight.
      iExists left_els, right_els, _, _, _; iFrame.
      iPureIntro.
      split_and!; set_solver.
    + assert (x ≠ key) by (intros ->; auto).
      case_bool_decide as Heqb2; wp_pures.
      * iApply ("IH" with "Hl").
        iIntros "!> Hl".
        iApply "HΦ".

        iApply tree_unfold; iRight.
        iExists ({[x]} ∪ left_els), right_els, _, _, _; iFrame.
        iPureIntro.
        (* [set_solver] does a lot of work here for us *)
        set_solver.
      * iApply ("IH" with "Hr").
        iIntros "!> Hr".
        iApply "HΦ".

        iApply tree_unfold; iRight.
        iExists left_els, ({[x]} ∪ right_els), _, _, _; iFrame.
        iPureIntro.
        assert (key < x) by lia.
        (* [set_solver] does a lot of work here for us *)
        set_solver.
Qed.

Theorem wp_tree_search t (x:Z) els :
  {{{ tree t els }}}
    search #t #x
  {{{ RET #(bool_decide (x ∈ els)); tree t els }}}.
Proof.
  iLöb as "IH" forall (t els).
  iIntros (Φ) "Ht HΦ".
  set (x_in_els:=bool_decide (x ∈ els)).
  wp_rec; wp_pures.
  iDestruct (tree_unfold with "Ht") as "[Ht|Ht]".
  - iDestruct "Ht" as (->) "Ht".
    wp_load; wp_pures.
    iApply "HΦ".
    by iApply tree_empty.
  - iDestruct "Ht" as (????? -> Hleft Hright) "(Ht&Hl&Hr)".
    wp_load; wp_pures.
    case_bool_decide as Heqb; wp_pures.
    + inversion Heqb; subst.
      replace x_in_els with true.
      { iApply "HΦ".
        iApply tree_unfold; iRight.
        eauto 10 with iFrame. }
      rewrite /x_in_els.
      apply symmetry, bool_decide_eq_true.
      set_solver.
    + assert (x ≠ key) by (intros ->; auto).
      case_bool_decide as Heqb2; wp_pures.
      * iApply ("IH" with "Hl").
        iIntros "!> Hl".
        replace (bool_decide (x ∈ left_els)) with x_in_els.
        { iApply "HΦ".
          iApply tree_unfold; iRight.
          eauto 10 with iFrame. }
        apply bool_decide_ext.
        assert (~(key < x)) by lia.
        set_solver.
      * iApply ("IH" with "Hr").
        iIntros "!> Hr".
        replace (bool_decide (x ∈ right_els)) with x_in_els.
        { iApply "HΦ".
          iApply tree_unfold; iRight.
          eauto 10 with iFrame. }
        apply bool_decide_ext.
        assert (key < x) by lia.
        set_solver.
Qed.

End proof.