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

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

   (i) context-free grammar simplification
   (i) context-free grammar Chomsky normalization and

   More information can be found in the paper "Formalization of
   the Chomsky Normal Form for Context-Free Grammars", submitted
   to SBMF 2019.

   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.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import Logic. Import Decidable.
Require Import
        syntax_ott
        syntaxb_ott
        rules_inf
        Typing
        Infrastructure.

Require Import Strings.String.

Lemma BA_AB: forall B A,
  sim A B -> sim B A.
Proof.
  introv H.
  induction* H.
Qed.

Lemma flike_not_ground: forall v,
 value v ->
 FLike (principal_type v) ->
 not(Ground (principal_type v)).
Proof.
  introv val fl.
  inductions val; simpl in *; try solve[inverts* fl;
  inverts* H0;inverts* H2];
  try solve[unfold not; intros nt; inverts* nt].
  inverts* fl. inverts H1.
  unfold not; intros nt; inverts* nt.
Qed.

Lemma TypedReduce_unique: forall v r1 r2 (A: typ) B p b,
    value v -> Typing nil v Chk B -> TypedReduce v p b A r1 -> TypedReduce v p b A r2 -> r1 = r2.
Proof.
  introv Val H R1 R2.
  gen r2 B.
  lets R1': R1.
  inductions R1; introv R2 typ;
    try solve [inverts* R2].
  - inverts* R2; try solve[inverts* H0].
  - inverts* R2; try solve[inverts H].
    inverts* Val; inverts* H0. inverts* H2. inverts H3.
    inverts H; simpl in *. inverts H4.
    exfalso. apply H; auto.
    inverts* H. inverts* H.
  - inverts* R2; try solve[ inverts* H7];try solve[inverts* H0];
    try solve[inverts* H3].
    inverts Val. rewrite H6 in H2; inverts H2.
    exfalso.
    apply H7.
    eauto.
  - inverts* R2;
    try solve[forwards*: flike_not_ground H];
    try solve[inverts* H].
  - inverts* R2;
    try solve[inverts* H];
    try solve[inverts* H0];
    try solve[inverts* H1];
    try solve[inverts H9].
  -
    inverts* R2;
    try solve[inverts* H6];
    try solve[inverts* H5];
    try solve[inverts* H].
    inverts H8; simpl;eauto.
    inverts H0.
    exfalso; apply H1; simpl;eauto.
    inverts H8.
    exfalso; apply H6; simpl;eauto.
  - inverts* R2;
    try solve[inverts H3];
    try solve[inverts* H1];
    try solve[inverts* H].
    inverts* Val.
    forwards*: flike_not_ground H.
    exfalso.
    apply H9.
    apply BA_AB; auto.
  - inverts* R2; try solve[inverts* H5];
    try solve[inverts* H4];
    try solve[inverts* H7];
    try solve[inverts* H].
    inverts* Val.
    rewrite <- H6 in H2. inverts H2.
    inverts* Val.
    forwards*: flike_not_ground H3.
    exfalso; apply H7;
    apply sim_refl.
  -
  inverts* R2; simpl in *;try solve[inverts* H7];
  try solve[inverts* H1];
  try solve[inverts* H0].
  exfalso; apply H; eauto.
  exfalso; apply H;simpl; eauto.
  exfalso.
  apply H.
  apply BA_AB; auto.
  exfalso; apply H;
  apply sim_refl.
Qed.

Lemma fill_auxi: forall E1 E0 e0 e1 r2 r1,
 fill E0 e0 = fill E1 e1 ->
 wellformed E0 ->
 wellformed E1 ->
 step e0 r1 ->
 step e1 r2 ->
 (E1 = E0)/\ (e0 = e1).
Proof.
  introv eq wf1 wf2 red1 red2. gen E1 e0 e1 r1 r2.
  inductions E0; unfold fill in *;  intros.
  - inductions E1; unfold fill in *; inverts* eq.
    inverts wf2.
    forwards*: step_not_value red1.
  - inductions E1; unfold fill in *; inverts* eq.
    inverts wf1.
    forwards*: step_not_value red2.
  - inductions E1; unfold fill in *; inverts* eq.
  - inductions E1; unfold fill in *; inverts* eq.
    inverts wf2.
    forwards*: step_not_value red1.
  - inductions E1; unfold fill in *; inverts* eq.
    inverts wf1.
    forwards*: step_not_value red2.
Qed.

Lemma fill_typ: forall E e1 A,
 wellformed E ->
 Typing nil (fill E e1) Chk A ->
 exists B, Typing nil e1 Chk B.
Proof.
  introv wf Typ. gen e1 A.
  inductions E; intros.
  - simpl in *.
    inverts Typ. inverts H.
    inverts wf.
    forwards*: Typing_chk H9.
  - unfold fill in *.
    inverts Typ.
    inverts* H.
  - unfold fill in *.
    inverts Typ.
    inverts* H.
    - simpl in *.
    inverts Typ. inverts H.
    inverts wf.
    forwards*: Typing_chk H4.
  - unfold fill in *.
    inverts Typ.
    inverts* H.
Qed.

Theorem step_unique: forall A e r1 r2,
    Typing nil e Chk A -> step e r1 -> step e r2 -> r1 = r2.
Proof.
  introv Typ Red1.
  gen A r2.
  lets Red1' : Red1.
  induction Red1;
    introv Typ Red2.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H0; inverts* H0;
    forwards*: step_not_value Red1;
    forwards*: step_not_value Red1];
    try solve[destruct E; unfold fill in H0; inverts* H0;
    forwards*: step_not_value Red1;eapply value_fanno;eauto;reflexivity;
    forwards*: step_not_value Red1;eapply value_fanno;eauto;reflexivity];
    try solve[destruct E; unfold fill in H1; inverts* H1;
    forwards*: step_not_value Red1;
    forwards*: step_not_value Red1].
    forwards*: fill_auxi H0. inverts H3.
    forwards*: fill_typ Typ. inverts H3.
    forwards*: IHRed1 Red1 H2. congruence.
    forwards*: fill_auxi H0. inverts H3.
    forwards*: fill_typ Typ. inverts H3.
    forwards*: IHRed1 Red1 H2. congruence.
    destruct E; unfold fill in *; inverts* H0;
    try solve[forwards*: step_not_value Red1].
    inverts H. inverts* H4.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H0; inverts* H0;
    forwards*: step_not_value Red1;
    forwards*: step_not_value Red1];
    try solve[destruct E; unfold fill in H1; inverts* H1;
    forwards*: step_not_value Red1;
    forwards*: step_not_value Red1];
    try solve[destruct E; unfold fill in H0; inverts* H0;
    forwards*: step_not_value Red1;eapply value_fanno;eauto;reflexivity;
    forwards*: step_not_value Red1;eapply value_fanno;eauto;reflexivity].
    forwards*: fill_auxi H0. inverts H3.
    forwards*: fill_typ Typ. inverts H3.
    forwards*: IHRed1 Red1 H2. congruence.
    forwards*: fill_auxi H0. inverts H3.
    forwards*: fill_typ Typ. inverts H3.
    forwards*: IHRed1 Red1 H2.
    destruct E; unfold fill in *; inverts* H0;
    try solve[forwards*: step_not_value Red1].
    inverts H. inverts* H4.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H1; inverts* H1;
    forwards*: step_not_value H3;eapply value_fanno;eauto;reflexivity;
    forwards*: step_not_value H3];
    try solve[inverts* H9];
    try solve[inverts* H0].
  - inverts* Red2;
    try solve[destruct E; unfold fill in H3; inverts* H3;
    forwards*: step_not_value H5;
    forwards*: step_not_value H5];
    try solve[inverts* H1].
    rewrite H10 in *. inverts H1.
    inverts Typ. inverts H1.
    forwards*: TypedReduce_unique H2 H11.
    congruence.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H2; inverts* H2;
    forwards*: step_not_value H4;
    forwards*: step_not_value H4];
    try solve[inverts* H8];
    try solve[inverts* H0].
    inverts Typ.
    inverts H2.
    forwards*: TypedReduce_unique H0 H8.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H3; inverts* H3;
    forwards*: step_not_value H5;
    forwards*: step_not_value H5];
    try solve[inverts H0].
    rewrite H2 in *. inverts* H13.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H3; inverts* H3;
    forwards*: step_not_value H5;
    forwards*: step_not_value H5];
    try solve[inverts* H1].
    rewrite H10 in *.
    inverts H1.
    inverts Typ.
    inverts H1.
    forwards*: TypedReduce_unique H2 H11.
    congruence.
    rewrite H10 in *.
    inverts H1.
    inverts Typ.
    inverts H1.
    forwards*: TypedReduce_unique H2 H11.
    congruence.
  - inverts* Red2;
    try solve[destruct E; unfold fill in H1; inverts* H1;
    forwards*: step_not_value H3;
    forwards*: step_not_value H3];
    try solve[inverts* H8];
    try solve[inverts* H0];
    try solve[inverts* H5].
    destruct E; unfold fill in H1; inverts* H1;
    try solve[forwards*: step_not_value H3].
    inverts H2. inverts H5.
    destruct E; unfold fill in H1; inverts* H1;
    try solve[forwards*: step_not_value H3].
    inverts H2. inverts H5.
  -
    inverts* Red2;
    try solve[destruct E; unfold fill in H; inverts* H;
    forwards*: step_not_value H1;eapply value_fanno;eauto;reflexivity;
    forwards*: step_not_value H1].
  -
    inverts* Red2;
    try solve[destruct E; unfold fill in H; inverts* H;
    forwards*: step_not_value H1;eapply value_fanno;eauto;reflexivity;
    forwards*: step_not_value H1].
  -
    inverts* Red2;
    try solve[destruct E; unfold fill in H1; inverts* H1;
    forwards*: step_not_value H3;eapply value_fanno;eauto;reflexivity;
    forwards*: step_not_value H3].
Qed.


(*
 * Copyright © 2013 http://io7m.com
 *
 * Permission to use, copy, modify, and/or distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)
Require SetWeak.

(** A trivial and extremely inefficient implementation of the [SetWeak]
interface implemented with lists. *)
Module Make (P : SetWeak.Parameters) : SetWeak.Signature with Definition e := P.t.

Definition e := P.t.

Definition t := list e.

Definition singleton (x : e) := cons x nil.

Fixpoint is_in
  (x : e)
  (s : t)
: Prop :=
  match s with
  | nil       => False
  | cons y ys => (x = y) \/ (x <> y /\ is_in x ys)
  end.

Theorem is_in_decidable : forall (x : e) (s : t),
  {is_in x s}+{~is_in x s}.
Proof.
  induction s as [|sh sr].
    right; auto.
    destruct IHsr as [IHL|IHR].
      destruct (P.t_eq_decidable x sh) as [H_eq|H_neq].
        rewrite H_eq.
        left; left; reflexivity.
        simpl; auto.
      destruct (P.t_eq_decidable x sh) as [H_eq|H_neq].
        rewrite H_eq.
        left; left; reflexivity.
        simpl in *; intuition.
Qed.

Fixpoint remove
  (x : e)
  (s : t)
: t :=
  match s with
  | nil       => nil
  | cons y ys =>
    match P.t_eq_decidable x y with
    | left _  => remove x ys
    | right _ => cons y (remove x ys)
    end
  end.

Fixpoint insert
  (x : e)
  (s : t)
: t := cons x (remove x s).

Definition empty := @nil e.

Theorem remove_is_in_false : forall (x : e) (s : t),
  ~is_in x (remove x s).
Proof.
  intros x s.
  induction s as [|y ys].
    (* s = nil *)
    simpl; auto.
    (* s = y :: ys *)
    simpl; destruct (P.t_eq_decidable x y) as [H_xy_eq|H_xy_neq].
      (* x = y *)
      assumption.
      (* x <> y *)
      simpl.
      unfold not.
      intros H_contra_goal.
      destruct H_contra_goal as [H_cg_L|H_cg_R].
        contradict H_xy_neq; assumption.
        destruct H_cg_R as [H_cg_RL H_cg_RR].
          auto.
Qed.

Theorem remove_preserves_is_in : forall (x0 x1 : e) (s : t),
  x0 <> x1 -> (is_in x0 (remove x1 s) <-> is_in x0 s).
Proof.
  intros x0 x1 s H_x0x1_neq.
  apply conj.
    intros H_in_remove.
    induction s as [|y ys].
      (* s = nil *)
      simpl; auto.
      (* s = y :: ys *)
      simpl in *. destruct (P.t_eq_decidable x1 y) as [H_x1y_eq|H_x1y_neq].
        (* x1 = y *)
        right; apply conj.
          rewrite H_x1y_eq in H_x0x1_neq.
          assumption.
          apply (IHys H_in_remove).
        (* x1 <> y *)
        destruct H_in_remove as [H_in_remove_L|H_in_remove_R].
          left; assumption.
          right; apply conj.
            destruct H_in_remove_R as [H_in_remove_RL H_in_remove_RR].
              assumption.
            destruct H_in_remove_R as [H_in_remove_RL H_in_remove_RR].
              apply (IHys H_in_remove_RR).

    intros H_in_remove.
    induction s as [|y ys].
      (* s = nil *)
      simpl; auto.
      (* s = y :: ys *)
      simpl in *. destruct (P.t_eq_decidable x1 y) as [H_x1y_eq|H_x1y_neq].
        (* x1 = y *)
        destruct H_in_remove as [H_in_remove_L|H_in_remove_R].
          contradict H_x0x1_neq.
            rewrite H_in_remove_L.
            rewrite H_x1y_eq.
            reflexivity.
          destruct H_in_remove_R as [H_in_remove_RL H_in_remove_RR].
            apply (IHys H_in_remove_RR).
        (* x1 <> y *)
        simpl; destruct H_in_remove as [H_in_remove_L|H_in_remove_R].
          left; assumption.
          right; apply conj.
            destruct H_in_remove_R as [H_in_remove_RL H_in_remove_RR].
              assumption.
            destruct H_in_remove_R as [H_in_remove_RL H_in_remove_RR].
              apply (IHys H_in_remove_RR).
Qed.

Lemma not_in_cons_0 : forall (x0 x1 : e) (s : t),
  x0 <> x1 -> ~is_in x0 (cons x1 s) -> ~is_in x0 s.
Proof.
  intros x0 x1 s H_neq H_not_in.
  simpl in *; intuition.
Qed.

Lemma not_in_cons_1 : forall (x0 x1 : e) (s : t),
  x0 <> x1 -> ~is_in x0 s -> ~is_in x0 (cons x1 s).
Proof.
  intros x0 x1 s H_neq H_not_in.
  simpl in *; intuition.
Qed.

Lemma remove_preserves_is_in_false : forall (x0 x1 : e) (s : t),
  ~is_in x0 s -> ~is_in x0 (remove x1 s).
Proof.
  intros x0 x1 s H_not_in.
  destruct (P.t_eq_decidable x0 x1) as [H_x0x1_eq|H_x0x1_neq].
    rewrite H_x0x1_eq.
    apply remove_is_in_false.
    induction s as [|sh sr].
      auto.
      simpl; destruct (P.t_eq_decidable x1 sh) as [H_x1sh_eq|H_x1sh_neq].
        rewrite <- H_x1sh_eq in H_not_in.
        assert (~is_in x0 sr) as H_not_in_rest.
          apply (not_in_cons_0 x0 x1 sr H_x0x1_neq H_not_in).
        apply (IHsr H_not_in_rest).
        simpl in *.
        intuition.
Qed.

Theorem remove_preserves_is_in_false_alt : forall (x0 x1 : e) (s : t),
  x0 <> x1 -> ~is_in x0 (remove x1 s) -> ~is_in x0 s.
Proof.
  intros x0 x1 s H_neq H_not_in.
  induction s as [|sh sr].
    simpl; auto.
    simpl in H_not_in.
    destruct (P.t_eq_decidable x1 sh) as [H_x1sh_eq|H_x1sh_neq].
      assert (~is_in x0 sr) by (apply (IHsr H_not_in)).
      rewrite <- H_x1sh_eq.
      apply (not_in_cons_1 x0 x1 sr H_neq H).
      simpl in *; intuition.
Qed.

Theorem is_in_empty_false : forall (x : e), ~is_in x empty.
Proof.
  intros x.
  compute; auto.
Qed.

Theorem insert_is_in : forall (x : e) (s : t),
  is_in x (insert x s).
Proof.
  intros x s.
  induction s as [|y ys].
    (* s = nil *)
    simpl; auto.
    (* s = y :: ys *)
    simpl; left; reflexivity.
Qed.

Theorem insert_preserves_is_in : forall (x0 x1 : e) (s : t),
  x0 <> x1 -> is_in x0 s -> is_in x0 (insert x1 s).
Proof.
  intros x0 x1 s H_x0x1_neq H_x0_in.
  induction s as [|y ys].
    (* s = nil *)
    simpl; auto.
    (* s = y :: ys *)
    simpl in *; destruct H_x0_in as [H_x0_in_L|H_x0_in_R].
      right; apply conj.
        assumption.
        destruct (P.t_eq_decidable x1 y) as [H_x1y_eq|H_x1y_neq].
          (* x1 = y *)
          contradict H_x0x1_neq.
            rewrite H_x0_in_L.
            rewrite H_x1y_eq.
            reflexivity.
          (* x1 <> y *)
          left; assumption.
      right; apply conj.
        assumption.
        destruct (P.t_eq_decidable x1 y) as [H_x1y_eq|H_x1y_neq].
          (* x1 = y *)
          destruct (remove_preserves_is_in x0 x1 ys H_x0x1_neq).
            destruct H_x0_in_R as [H_x0_in_RL H_x0_in_RR].
              auto.
          (* x1 <> y *)
          right; apply conj.
            destruct H_x0_in_R as [H_x0_in_RL H_x0_in_RR].
              assumption.
            destruct (remove_preserves_is_in x0 x1 ys H_x0x1_neq).
              destruct H_x0_in_R as [H_x0_in_RL H_x0_in_RR].
                auto.
Qed.

Theorem insert_preserves_is_in_false : forall (x0 x1 : e) (s : t),
  x0 <> x1 -> (~is_in x0 (insert x1 s) <-> ~is_in x0 s).
Proof.
  intros x0 x1 s H_x0x1_neq.
  apply conj.
    intros H_not_in.
    induction s as [|y ys].
      (* s = nil *)
      simpl; auto.
      (* s = y :: ys *)
      simpl in *; destruct (P.t_eq_decidable x1 y) as [H_x1y_eq|H_x1y_neq].
        (* x1 = y *)
        unfold not.
        intros H_contra_goal.
        destruct H_not_in.
          destruct H_contra_goal as [H_cg_L|H_cg_R].
            contradict H_x0x1_neq.
              rewrite H_x1y_eq.
              rewrite H_cg_L.
              reflexivity.
            right; apply conj.
              assumption.
              destruct H_cg_R as [H_cg_RL H_cg_RR].
                destruct (remove_preserves_is_in x0 x1 ys H_x0x1_neq).
                  auto.
        (* x1 <> y *)
        unfold not.
        intros H_contra_goal.
        destruct H_not_in.
          destruct H_contra_goal as [H_cg_L|H_cg_R].
            right; apply conj.
              assumption.
              left; assumption.
            right; apply conj.
              assumption.
              right; apply conj.
                destruct H_cg_R as [H_cg_RL H_cg_RR].
                  auto.
                destruct H_cg_R as [H_cg_RL H_cg_RR].
                  destruct (remove_preserves_is_in x0 x1 ys H_x0x1_neq).
                    auto.

    intros H_not_in.
    induction s as [|y ys].
      (* s = nil *)
      simpl in *.
      unfold not.
      intros H_contra_goal.
      destruct H_contra_goal as [H_cg_L|H_cg_R].
        contradict H_x0x1_neq.
          assumption.
        tauto.
      (* s = y :: ys *)
      simpl in *; destruct (P.t_eq_decidable x1 y) as [H_x1y_eq|H_x1y_neq].
        (* x1 = y *)
        unfold not.
        intros H_contra_goal.
        destruct H_contra_goal as [H_cg_L|H_cg_R].
          contradict H_x0x1_neq.
            assumption.
          destruct H_not_in.
            right; apply conj.
              rewrite <- H_x1y_eq.
              assumption.
              destruct H_cg_R as [H_cg_RL H_cg_RR].
                destruct (remove_preserves_is_in x0 x1 ys H_x0x1_neq).
                  auto.
        (* x1 <> y *)
        unfold not.
        intros H_contra_goal.
        destruct H_not_in.
          simpl in *. destruct H_contra_goal as [H_cg_L|H_cg_R].
            contradict H_x0x1_neq.
              assumption.
            destruct H_cg_R as [H_cg_RL H_cg_RR].
              destruct H_cg_RR as [H_cg_RRL|H_cg_RRR].
                left; assumption.
                right; apply conj.
                  destruct H_cg_RRR as [H_cg_RRRL H_cg_RRRR].
                    assumption.
                  destruct H_cg_RRR as [H_cg_RRRL H_cg_RRRR].
                    destruct (remove_preserves_is_in x0 x1 ys H_x0x1_neq).
                      auto.
Qed.

Theorem singleton_eq : forall (x : e),
  singleton x = insert x empty.
Proof.
  reflexivity.
Qed.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Import Coq.Program.Basics.
Require Import Coq.Classes.Morphisms.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Values.
Require Import compcert.common.Memory.
Require Import liblayers.lib.Functor.
Require Import liblayers.lib.Monad.
Require Import liblayers.lib.Lens.
Require Export liblayers.lib.Lift.

(** * Prerequisites *)

(** We're going to lift the memory operations and theorems from a base
  type [bmem] to a "richer" type [mem], which contains [bmem] as a
  component. Formally, this means that we have a [Lens mem bmem] which
  provides us with well-behaved accessors to the [bmem] component
  inside of [mem]. While this is enough to lift most of the memory
  operations and theorems, we also need to know the value of
  the empty memory state of the richer type [mem]; indeed there's no
  way we would be able to construct that just from [empty : bmem].
  However, the simpler memory state contained within this empty [mem]
  should correspond to the empty [bmem] from the base memory states. *)

Class LiftMemoryModelOps {mem bmem: Type} (π: mem -> bmem)
  `{bmem_ops: Mem.MemoryModelOps bmem}
  `{bmem_set: !LensOps π} :=
{
  liftmem_empty: mem
}.

Class LiftMemoryModel {mem bmem: Type} (π: mem -> bmem)
  `{mem_liftops: LiftMemoryModelOps mem bmem π}: Prop :=
{
  liftmem_lens :> Lens π;
  liftmem_get_empty: π liftmem_empty = Mem.empty
}.

(** Using all of this, we can build a set of memory operations on the
  source type [mem] from the operations on the view type [bmem]. *)

Section LIFTOPS.
  Global Instance liftmem_ops `{mem_liftops: LiftMemoryModelOps}:
    Mem.MemoryModelOps mem :=
  {
    empty :=
      liftmem_empty;
    alloc wm lo hi :=
      lift π (fun m => Mem.alloc m lo hi) wm;
    nextblock wm :=
      lift π Mem.nextblock wm;
    free wm b lo hi :=
      lift π (fun m => Mem.free m b lo hi) wm;
    load chunk wm b ofs :=
      lift π (fun m => Mem.load chunk m b ofs) wm;
    store chunk wm b ofs v :=
      lift π (fun m => Mem.store chunk m b ofs v) wm;
    loadbytes wm b ofs n :=
      lift π (fun m => Mem.loadbytes m b ofs n) wm;
    storebytes wm b ofs vs :=
      lift π (fun m => Mem.storebytes m b ofs vs) wm;
    perm wm b ofs k p :=
      lift π (fun m => Mem.perm m b ofs k p) wm;
    valid_pointer wm b ofs :=
      lift π (fun m => Mem.valid_pointer m b ofs) wm;
    drop_perm wm b lo hi p :=
      lift π (fun m => Mem.drop_perm m b lo hi p) wm;
    extends wm1 wm2 :=
      lift π Mem.extends wm1 wm2;
    inject f wm1 wm2 :=
      lift π (Mem.inject f) wm1 wm2;
    inject_neutral thr wm :=
      lift π (Mem.inject_neutral thr) wm;
    unchanged_on P wm1 wm2 :=
      Mem.unchanged_on P (π wm1) (π wm2)
  }.
End LIFTOPS.

(** ** Properties of the [inject_incr] relation *)

(** Those are needed to enable rewriting using [liftmem_inject_same_context]. *)

Global Instance: Reflexive inject_incr.
Proof.
  firstorder.
Qed.

Global Instance: Transitive inject_incr.
Proof.
  firstorder.
Qed.

(** * Lifting the properties *)

Section LIFTDERIVED.
  Context `{HW: LiftMemoryModel}.

  (** Show that the operations derived from the [Mem.MemoryBaseOps]
    instance above are equivalent to lifting the operations derived
    from the original [Mem.MemoryBaseOps]. *)

  Theorem lift_loadv chunk wm addr:
    Mem.loadv chunk wm addr =
    lift π (fun m => Mem.loadv chunk m addr) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_storev chunk a v wm:
    Mem.storev chunk wm a v =
    lift π (fun m => Mem.storev chunk m a v) wm.
  Proof.
    unfold Mem.storev.
    destruct a; reflexivity.
  Qed.

  Theorem lift_free_list l wm:
    Mem.free_list wm l =
    lift π (fun m => Mem.free_list m l) wm.
  Proof with lift_auto.
    revert wm.
    induction l as [ | [[b lo] hi] l IHl]; intros...
    destruct (Mem.free (π wm) b lo hi)...
    rewrite IHl...
    destruct (Mem.free_list b0 l)...
  Qed.

  Theorem lift_valid_block (wm: mem) (b: block):
    Mem.valid_block wm b <->
    lift π (fun m => Mem.valid_block m b) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_range_perm (wm: mem) b lo hi k p:
    Mem.range_perm wm b lo hi k p <->
    lift π (fun m => Mem.range_perm m b lo hi k p) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_valid_access (wm: mem) chunk b ofs p:
    Mem.valid_access wm chunk b ofs p <->
    lift π (fun m => Mem.valid_access m chunk b ofs p) wm.
  Proof.
    reflexivity.
  Qed.

  Theorem lift_weak_valid_pointer (wm: mem) b ofs:
    Mem.weak_valid_pointer wm b ofs =
    lift π (fun m => Mem.weak_valid_pointer m b ofs) wm.
  Proof.
    reflexivity.
  Qed.
End LIFTDERIVED.

Hint Rewrite
  @lift_loadv
  @lift_storev
  @lift_free_list
  @lift_valid_block
  @lift_range_perm
  @lift_valid_access
  @lift_weak_valid_pointer
  using typeclasses eauto : lift.

(** Replace [(get Mem.empty)] by the underlying [Mem.empty]. *)
Hint Rewrite
  @liftmem_get_empty
  using typeclasses eauto: lens.

Section LIFTMEM.
  Context mem bmem `{Hmem: LiftMemoryModel mem bmem}.

  Local Arguments fmap : simpl never.

  Global Instance liftmem_spec:
    Mem.MemoryModel bmem -> Mem.MemoryModel mem.
  Proof.
    intro Hbmem; esplit.
    lift π Mem.valid_not_valid_diff.
    lift π Mem.perm_implies.
    lift π Mem.perm_cur_max.
    lift π Mem.perm_cur.
    lift π Mem.perm_max.
    lift π Mem.perm_valid_block.
    lift π Mem.range_perm_implies.
    lift π Mem.range_perm_cur.
    lift π Mem.range_perm_max.
    lift π Mem.valid_access_implies.
    lift π Mem.valid_access_valid_block.
    lift π Mem.valid_access_perm.
    lift π Mem.valid_pointer_nonempty_perm.
    lift π Mem.valid_pointer_valid_access.
    lift π Mem.weak_valid_pointer_spec.
    lift π Mem.valid_pointer_implies.
    lift π Mem.nextblock_empty.
    lift π Mem.perm_empty.
    lift π Mem.valid_access_empty.
    lift π Mem.valid_access_load.
    lift π Mem.load_valid_access.
    lift π Mem.load_type.
    lift π Mem.load_cast.
    lift π Mem.load_int8_signed_unsigned.
    lift π Mem.load_int16_signed_unsigned.
    lift π Mem.loadv_int64_split.
    lift π Mem.range_perm_loadbytes.
    lift π Mem.loadbytes_range_perm.
    lift π Mem.loadbytes_load.
    lift π Mem.load_loadbytes.
    lift π Mem.loadbytes_length.
    lift π Mem.loadbytes_empty.
    lift π Mem.loadbytes_concat.
    lift π Mem.loadbytes_split.
    lift π Mem.nextblock_store.
    lift π Mem.store_valid_block_1.
    lift π Mem.store_valid_block_2.
    lift π Mem.perm_store_1.
    lift π Mem.perm_store_2.
    lift π Mem.store_valid_access_1.
    lift π Mem.store_valid_access_2.
    lift π Mem.store_valid_access_3.
    lift π Mem.valid_access_store.
    lift π Mem.load_store_similar.
    lift π Mem.load_store_similar_2.
    lift π Mem.load_store_same.
    lift π Mem.load_store_other.
    lift π Mem.load_store_pointer_overlap.
    lift π Mem.load_store_pointer_mismatch.
    lift π Mem.load_pointer_store.
    lift π Mem.loadbytes_store_same.
    lift π Mem.loadbytes_store_other.
    lift π Mem.store_signed_unsigned_8.
    lift π Mem.store_signed_unsigned_16.
    lift π Mem.store_int8_zero_ext.
    lift π Mem.store_int8_sign_ext.
    lift π Mem.store_int16_zero_ext.
    lift π Mem.store_int16_sign_ext.
    lift π Mem.store_float32_truncate.
    lift π Mem.storev_int64_split.
    lift π Mem.storebytes_range_perm.
    lift π Mem.perm_storebytes_1.
    lift π Mem.perm_storebytes_2.
    lift π Mem.storebytes_valid_access_1.
    lift π Mem.storebytes_valid_access_2.
    lift π Mem.nextblock_storebytes.
    lift π Mem.storebytes_valid_block_1.
    lift π Mem.storebytes_valid_block_2.
    lift π Mem.range_perm_storebytes.
    lift π Mem.storebytes_store.
    lift π Mem.store_storebytes.
    lift π Mem.loadbytes_storebytes_same.
    lift π Mem.loadbytes_storebytes_other.
    lift π Mem.load_storebytes_other.
    lift π Mem.loadbytes_storebytes_disjoint.
    lift π Mem.storebytes_concat.
    lift π Mem.storebytes_split.
    lift π Mem.alloc_result.
    lift π Mem.nextblock_alloc.
    lift π Mem.valid_block_alloc.
    lift π Mem.fresh_block_alloc.
    lift π Mem.valid_new_block.
    lift π Mem.valid_block_alloc_inv.
    lift π Mem.perm_alloc_1.
    lift π Mem.perm_alloc_2.
    lift π Mem.perm_alloc_3.
    lift π Mem.perm_alloc_4.
    lift π Mem.perm_alloc_inv.
    lift π Mem.valid_access_alloc_other.
    lift π Mem.valid_access_alloc_same.
    lift π Mem.valid_access_alloc_inv.
    lift π Mem.load_alloc_unchanged.
    lift π Mem.load_alloc_other.
    lift π Mem.load_alloc_same.
    lift π Mem.load_alloc_same'.
    lift π Mem.loadbytes_alloc_unchanged.
    lift π Mem.loadbytes_alloc_same.
    lift π Mem.free_range_perm.
    lift π Mem.range_perm_free.
    lift π Mem.nextblock_free.
    lift π Mem.valid_block_free_1.
    lift π Mem.valid_block_free_2.
    lift π Mem.perm_free_1.
    lift π Mem.perm_free_2.
    lift π Mem.perm_free_3.
    lift π Mem.perm_free_list.
    lift π Mem.valid_access_free_1.
    lift π Mem.valid_access_free_2.
    lift π Mem.valid_access_free_inv_1.
    lift π Mem.valid_access_free_inv_2.
    lift π Mem.load_free.
    lift π Mem.loadbytes_free.
    lift π Mem.loadbytes_free_2.
    lift π Mem.nextblock_drop.
    lift π Mem.drop_perm_valid_block_1.
    lift π Mem.drop_perm_valid_block_2.
    lift π Mem.range_perm_drop_1.
    lift π Mem.range_perm_drop_2.
    lift π Mem.perm_drop_1.
    lift π Mem.perm_drop_2.
    lift π Mem.perm_drop_3.
    lift π Mem.perm_drop_4.
    lift π Mem.load_drop.
    lift π Mem.loadbytes_drop.
    lift π Mem.mext_next.
    lift π Mem.extends_refl.
    lift π Mem.load_extends.
    lift π Mem.loadv_extends.
    lift π Mem.loadbytes_extends.
    lift π Mem.store_within_extends.
    lift π Mem.store_outside_extends.
    lift π Mem.storev_extends.
    lift π Mem.storebytes_within_extends.
    lift π Mem.storebytes_outside_extends.
    lift π Mem.alloc_extends.
    lift π Mem.free_left_extends.
    lift π Mem.free_right_extends.
    lift π Mem.free_parallel_extends.
    lift π Mem.valid_block_extends.
    lift π Mem.perm_extends.
    lift π Mem.valid_access_extends.
    lift π Mem.valid_pointer_extends.
    lift π Mem.weak_valid_pointer_extends.
    lift π Mem.mi_freeblocks.
    lift π Mem.mi_mappedblocks.
    lift π Mem.mi_no_overlap.
    lift π Mem.valid_block_inject_1.
    lift π Mem.valid_block_inject_2.
    lift π Mem.perm_inject.
    lift π Mem.range_perm_inject.
    lift π Mem.valid_access_inject.
    lift π Mem.valid_pointer_inject.
    lift π Mem.weak_valid_pointer_inject.
    lift π Mem.address_inject.
    lift π Mem.valid_pointer_inject_no_overflow.
    lift π Mem.weak_valid_pointer_inject_no_overflow.
    lift π Mem.valid_pointer_inject_val.
    lift π Mem.weak_valid_pointer_inject_val.
    lift π Mem.inject_no_overlap.
    lift π Mem.different_pointers_inject.
    lift π Mem.disjoint_or_equal_inject.
    lift π Mem.aligned_area_inject.
    lift π Mem.load_inject.
    lift π Mem.loadv_inject.
    lift π Mem.loadbytes_inject.
    lift π Mem.store_mapped_inject.
    lift π Mem.store_unmapped_inject.
    lift π Mem.store_outside_inject.
    lift π Mem.storev_mapped_inject.
    lift π Mem.storebytes_mapped_inject.
    lift π Mem.storebytes_unmapped_inject.
    lift π Mem.storebytes_outside_inject.
    lift π Mem.storebytes_empty_inject.
    lift π Mem.alloc_right_inject.
    lift π Mem.alloc_left_unmapped_inject.
    lift π Mem.alloc_left_mapped_inject.
    lift π Mem.alloc_parallel_inject.
    lift π Mem.free_inject.
    lift π Mem.free_left_inject.
    lift π Mem.free_list_left_inject.
    lift π Mem.free_right_inject.
    lift π Mem.drop_outside_inject.
    lift π Mem.neutral_inject.
    lift π Mem.empty_inject_neutral.
    lift π Mem.alloc_inject_neutral.
    lift π Mem.store_inject_neutral.
    lift π Mem.drop_inject_neutral.
    lift π Mem.unchanged_on_refl.
    lift π Mem.perm_unchanged_on.
    lift π Mem.perm_unchanged_on_2.
    lift π Mem.loadbytes_unchanged_on_1.
    lift π Mem.loadbytes_unchanged_on.
    lift π Mem.load_unchanged_on_1.
    lift π Mem.load_unchanged_on.
    lift π Mem.store_unchanged_on.
    lift π Mem.storebytes_unchanged_on.
    lift π Mem.alloc_unchanged_on.
    lift π Mem.free_unchanged_on.
    lift π Mem.unchanged_on_empty.
    lift π Mem.unchanged_on_trans.
    lift π Mem.unchanged_on_weak.
    lift π Mem.unchanged_on_or.
    lift π Mem.unchanged_on_exists.
  Qed.
End LIFTMEM.


(* coq-prelude
 * Copyright (C) 2018 ANSSI
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program. If not, see <http://www.gnu.org/licenses/>.
 *)

From Coq Require Import Equivalence Setoid Morphisms.
From Prelude Require Export Equality.

Set Universe Polymorphism.

Declare Scope monad_scope.
Delimit Scope monad_scope with monad.

#[local]
Open Scope prelude_scope.

Definition compose {a b c} (g : b -> c) (f : a -> b) : a -> c :=
  fun (x: a) => g (f x).

Definition id {a : Type} (x : a) : a := x.

Notation "f <<< g" := (compose f g) (at level 50) : function_scope.
Notation "f >>> g" := (compose g f) (at level 50) : function_scope.

Notation "'fun*' x .. z '=>' p" := (fun x => .. (fun z => p%monad) ..)
  (x binder, z binder, at level 200, only parsing) : function_scope.

Notation "f $ x" :=
  (f x) (only parsing, at level 99, right associativity) : prelude_scope.

(** * Functor *)

Class Functor (f : Type -> Type) : Type :=
  { functor_has_eq :> forall {a} `{Equality a}, Equality (f a)
  ; map {a b : Type} : (a -> b) -> f a -> f b
  ; functor_identity {a} `{Equality a} (x : f a) : map id x == id x
  ; functor_map_identity {a b c} `{Equality c} (u : b -> c) (v : a -> b) (x : f a)
    : map (u <<< v) x == map u (map v x)
  }.

Arguments map [f _ a b] (_ _%monad).
Arguments functor_identity [f _ a _] (x).
Arguments functor_map_identity [f _ a b c _] (u v x).

Definition fconst {f a b} `{Functor f} (x : a) (ft : f b) : f a :=
  map (fun _ => x) ft.

Arguments fconst [f a b _] x ft%monad.

Notation "f <$> g" := (map f g) (at level 27, left associativity) : monad_scope.
Notation "f <$ g" := (fconst f g) (at level 27, left associativity) : monad_scope.

#[local]
Open Scope monad_scope.

(** * Applicative *)

Reserved Notation "f <*> g" (at level 28, left associativity).

Class Applicative (f : Type -> Type) : Type :=
  { applicative_is_functor :> Functor f
  ; pure {a} : a -> f a
  ; apply {a b} : f (a -> b) -> f a -> f b
    where "f <*> g" := (apply f g)
  ; applicative_identity {a} `{Equality a} (v : f a) : pure id <*> v == v
  ; applicative_composition {a b c} `{Equality c} (u : f (b -> c)) (v : f (a -> b)) (w : f a)
    : pure compose <*> u <*> v <*> w == u <*> (v <*> w)
  ; applicative_homomorphism {a b} `{Equality b} (v : a -> b) (x : a)
    : (pure v) <*> (pure x) == pure (v x)
  ; applicative_interchange {a b} `{Equality b} (u : f (a -> b)) (y : a)
    : u <*> (pure y) == (pure (fun z => z y)) <*> u
  ; applicative_pure_map {a b} `{Equality b} (g : a -> b) (x : f a)
    : g <$> x == pure g <*> x
  }.

Arguments pure [f _ a] (x).
Arguments apply [f _ a b] (_%monad _%monad).
Arguments applicative_identity [f _ a _] (v).
Arguments applicative_composition [f _ a b c _] (u v w).
Arguments applicative_homomorphism [f _ a b _] (v x).
Arguments applicative_interchange [f _ a b _] (u y).
Arguments applicative_pure_map [f _ a b _] (g x).

Notation "f <*> g" := (apply f g) (at level 28, left associativity) : monad_scope.

Definition liftA2 {f a b c} `{Applicative f} (g : a -> b -> c) (x : f a) (y : f b) : f c :=
  apply (map g x) y.

Arguments liftA2 [f a b c _] (g x%monad y%monad).

Definition rseq {f a b} `{Applicative f} (x : f a) (y : f b) : f b :=
  (id <$ x) <*> y.

Arguments rseq [f a b _] (x%monad y%monad).

Notation "f *> g" := (rseq f g) (at level 28, left associativity) : monad_scope.

Definition lseq {f a b} `{Applicative f} (x : f a) (y : f b) : f a :=
  liftA2 (fun x _ => x) x y.

Arguments lseq [f a b _] (x%monad y%monad).

Notation "f <* g" := (lseq f g) (at level 28, left associativity) : monad_scope.

(** * Monad *)

Reserved Notation "f >>= g" (at level 20, left associativity).

Class Monad (m:  Type -> Type) :=
  { monad_is_apply :> Applicative m
  ; bind {a b} : m a -> (a -> m b) -> m b
    where "f >>= g" := (bind f g)
  ; bind_left_identity {a b} `{Equality b} (x : a) (f : a -> m b)
    : pure x >>= f == f x
  ; bind_right_identity {a} `{Equality a} (x : m a)
    : x >>= (fun y => pure y) == x
  ; bind_associativity {a b c} `{Equality c} (f : m a) (g : a -> m b) (h : b -> m c)
    : (f >>= g) >>= h == f >>= (fun x => (g x) >>= h)
  ; bind_morphism {a b} `{Equality b} (x : m a) (f f' : a -> m b)
    : f == f' -> bind x f == bind x f'
  ; bind_map {a b} `{Equality b} (x : m a) (f : a -> b)
    : f <$> x == (x >>= (fun y => pure (f y)))
  }.

Notation "f >>= g" := (bind f g) (at level 20, left associativity) : monad_scope.

Arguments bind [m _ a b] (f%monad g%monad).
Arguments bind_left_identity [m _ a b _] (x f).
Arguments bind_right_identity [m _ a _] (x).
Arguments bind_associativity [m _ a b c _] (f g h).
Arguments bind_morphism [m _ a b _] (x f f').
Arguments bind_map [m _ a b _] (x f).

#[local]
Open Scope signature_scope.

#[program]
Instance bind_Proper (m : Type -> Type) `{Monad m} (a b : Type) `{Equality b}
  : Proper (@eq (m a) ==> @equal (a -> m b) _ ==> @equal (m b) functor_has_eq) (@bind m _ _ _).

Next Obligation.
  add_morphism_tactic.
  intros x f g equ.
  apply bind_morphism.
  exact equ.
Qed.

Definition join {m a} `{Monad m} (x : m (m a)) : m a :=
  x >>= id.

Arguments join [m a _] (x%monad).

Definition void {m a} `{Monad m} (x : m a) : m unit :=
  x >>= fun _ => pure tt.

Arguments void [m a _] (x%monad).

Definition when {m a} `{Monad m} (cond : bool) (x : m a) : m unit :=
  if cond then void x else pure tt.

Arguments when [m a _] (cond x%monad).

Declare Custom Entry monad.

Notation "'do' p 'end'" := p (p custom monad at level 10) : prelude_scope.

Notation "p ';' q" := (bind p%monad (fun _ => q%monad))
  (in custom monad at level 10, q at level 10, right associativity, only parsing).

Notation "'let*' a ':=' p 'in' q" := (bind p%monad (fun a => q%monad))
  (in custom monad at level 0, a ident, p constr, q at level 10, right associativity, only parsing).

Notation "'let' a ':=' p 'in' q" := (let a := p in q%monad)
  (in custom monad at level 5, a ident, p constr, q at level 10, right associativity, only parsing).

Notation "x" := x%monad (in custom monad at level 0, x constr at level 200, only parsing).

#[local]
Definition test_monad_notation {m} `{Monad m}
  (compute : nat -> m nat) (p : m unit) (q : nat -> m bool) : nat -> m bool := fun* _ => do
    p >>= (fun _ => q 2%nat);
    p;
    let z := 3 in
    let* x := id <$> compute 3 in
    let* y := compute 4 in
    q (x + y + z)
  end.


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

(** * doTriplets

Pierre Letouzey & Laurent Thery

Propagation as transitive closure of the one step propagation
*)

From Stalmarck Require Export doTriplet.
From Stalmarck Require Import PolyListAux.

(** Reflexive transitive closure of doTriplet *)
Inductive doTripletsP : State -> list triplet -> State -> Prop :=
  | doTripletsRef :
      forall (S1 S2 : State) (L : list triplet),
      eqState S1 S2 -> doTripletsP S1 L S2
  | doTripletsTrans :
      forall (S1 S2 S3 : State) (L : list triplet) (t : triplet),
      In t L ->
      doTripletP S1 t S2 -> doTripletsP S2 L S3 -> doTripletsP S1 L S3.

#[export] Hint Resolve doTripletsRef : stalmarck.

(** It is compatible *)
Theorem doTripletsComp :
 forall (S1 S2 S3 S4 : State) (L : list triplet),
 doTripletsP S1 L S2 -> eqState S3 S1 -> eqState S4 S2 -> doTripletsP S3 L S4.
Proof.
intros S1 S2 S3 S4 L H'; generalize S3 S4; elim H'; clear H' L S1 S2 S3 S4;
 auto with stalmarck.
intros S1 S2 L H' S3 S4 H'0 H'1.
apply doTripletsRef; auto with stalmarck.
apply eqStateTrans with (S2 := S1); auto with stalmarck.
apply eqStateTrans with (S2 := S2); auto with stalmarck.
intros S1 S2 S3 L t H' H'0 H'1 H'2 S0 S4 H'3 H'4.
elim (doTripletEqCompEx S1 S2 S0 t);
 [ intros S6 E; Elimc E; intros H'11 H'12 | idtac | idtac ];
 auto with stalmarck.
apply doTripletsTrans with (S2 := S6) (t := t); auto with stalmarck.
Qed.

(** Transitive *)
Theorem doTripletsRTrans :
 forall (S1 S2 S3 : State) (L : list triplet),
 doTripletsP S1 L S2 -> doTripletsP S2 L S3 -> doTripletsP S1 L S3.
Proof.
intros S1 S2 S3 L H'; elim H'; auto with stalmarck.
intros S4 S5 L0 H'0 H'1.
apply doTripletsComp with (S1 := S5) (S2 := S3); auto with stalmarck.
intros S4 S5 S0 L0 t H'0 H'1 H'2 H'3 H'4.
apply doTripletsTrans with (S2 := S5) (t := t); auto with stalmarck.
Qed.

(** We only add equation *)
Theorem doTripletsUnionEx :
 forall (S1 S2 : State) (L : list triplet),
 doTripletsP S1 L S2 -> exists S3 : State, eqState S2 (unionState S3 S1).
Proof.
intros S1 S2 L H'; elim H'; auto with stalmarck.
intros S3 S4 H'0 H'1; exists S3; auto with stalmarck.
apply eqStateTrans with (S2 := S3); auto with stalmarck.
red in |- *; split; auto with stalmarck.
intros S3 S4 S5 L0 t H'0 H'1 H'2 H'3.
elim (doTripletUnionEx S3 S4 t); [ intros S6 E | idtac ]; auto with stalmarck.
elim H'3; intros S7 E0.
exists (unionState S7 S6).
apply eqStateTrans with (S2 := unionState S7 S4); auto with stalmarck.
rewrite E; auto with stalmarck.
apply unionStateAssoc; auto with stalmarck.
Qed.

(** The state always grows *)
Theorem doTripletsIncl :
 forall (S1 S2 : State) (L : list triplet),
 doTripletsP S1 L S2 -> inclState S1 S2.
Proof.
intros S1 S2 L H'.
elim (doTripletsUnionEx S1 S2 L); [ intros S3 E | idtac ]; auto with stalmarck.
apply inclStateEqStateComp with (S1 := S1) (S3 := unionState S3 S1); auto with stalmarck.
Qed.

(** It is a congruence *)
Theorem doTripletCongruent :
 forall (S1 S2 S3 : State) (L : list triplet),
 doTripletsP S1 L S2 -> doTripletsP (unionState S3 S1) L (unionState S3 S2).
Proof.
intros S1 S2 S3 L H'; Elimc H'; clear S1 S2 L; auto with stalmarck.
intros S1 S2 S0 L t H' H'0 H'1 H'2.
apply doTripletsRTrans with (S2 := unionState S3 S2); auto with stalmarck.
elim (doTripletCongruentEx S1 S2 S3 t);
 [ intros S4 E; Elimc E; intros H'8 H'9 | idtac ];
 auto with stalmarck.
apply doTripletsRTrans with (S2 := S4); auto with stalmarck.
apply doTripletsTrans with (S2 := S4) (t := t); auto with stalmarck.
Qed.

(** It is monotone *)
Theorem doTripletsMonotoneEx :
 forall (S1 S2 S3 : State) (L : list triplet),
 doTripletsP S1 L S3 ->
 inclState S1 S2 -> exists S4 : State, doTripletsP S2 L S4 /\ inclState S3 S4.
Proof.
intros S1 S2 S3 L H' H'0.
lapply (doTripletCongruent S1 S3 S2 L); [ intros H'5 | idtac ]; auto with stalmarck.
exists (unionState S2 S3); split; auto with stalmarck.
apply doTripletsComp with (S1 := unionState S2 S1) (S2 := unionState S2 S3);
 auto with stalmarck.
red in |- *; split; auto with stalmarck.
Qed.

(** It is confluent *)
Theorem doTripletsConftEx :
 forall (L : list triplet) (S1 S2 S3 : State),
 doTripletsP S1 L S2 ->
 doTripletsP S1 L S3 ->
 exists S4 : State, doTripletsP S2 L S4 /\ doTripletsP S3 L S4.
Proof.
intros L S1 S2 S3 H' H'0.
elim (doTripletsUnionEx S1 S2 L); [ intros S4 E | idtac ]; auto with stalmarck.
elim (doTripletsUnionEx S1 S3 L); [ intros S5 E0 | idtac ]; auto with stalmarck.
exists (unionState S5 S2); split; auto with stalmarck.
apply doTripletsComp with (S1 := unionState S4 S1) (S2 := unionState S4 S3);
 auto with stalmarck.
apply doTripletCongruent; auto with stalmarck.
apply eqStateTrans with (S2 := unionState S5 (unionState S4 S1)); auto with stalmarck.
apply eqStateTrans with (S2 := unionState (unionState S5 S4) S1); auto with stalmarck.
apply unionStateAssoc; auto with stalmarck.
apply eqStateTrans with (S2 := unionState (unionState S4 S5) S1); auto with stalmarck.
apply eqStateTrans with (S2 := unionState S4 (unionState S5 S1)); auto with stalmarck.
apply eqStateTrans with (S2 := unionState (unionState S4 S5) S1); auto with stalmarck.
apply eqStateSym; auto with stalmarck.
apply unionStateAssoc; auto with stalmarck.
apply doTripletsComp with (S1 := unionState S5 S1) (S2 := unionState S5 S2);
 auto with stalmarck.
apply doTripletCongruent; auto with stalmarck.
Qed.

(** We don't lose realizability of memories if the triplets are realized *)
Theorem doTripletsRealizeStateEval :
 forall (f : rNat -> bool) (S1 S2 : State) (L : list triplet),
 realizeState f S1 ->
 doTripletsP S1 L S2 ->
 realizeTriplets f L -> f zero = true -> realizeState f S2.
Proof.
intros f S1 S2 L H' H'0; generalize H'; elim H'0; auto with stalmarck.
intros S3 S4 L0 H'1 H'2 H'3 H'4.
apply realizeStateIncl with (S1 := S3); auto with stalmarck; inversion H'1; auto with stalmarck.
intros S3 S4 S5 L0 t H'1 H'2 H'3 H'4 H'5 H'6 H'7.
apply H'4; auto with stalmarck.
apply realizeStateEval with (2 := H'2); auto with stalmarck.
Qed.

Theorem doTripletsTermExAux :
 forall (L : list triplet) (S1 S2 : State),
 doTripletsP S1 L S2 ->
 forall t : triplet,
 In t L ->
 doTripletsP S1 (rem _ tripletDec t L) S2 \/
 (exists S3 : State,
    (exists S4 : State,
       doTripletsP S1 (rem _ tripletDec t L) S3 /\
       doTripletP S3 t S4 /\ doTripletsP S4 (rem _ tripletDec t L) S2)).
Proof.
intros L S1 S2 H'; Elimc H'; clear L S1 S2; auto with stalmarck.
intros S1 S2 S3 L t H' H'0 H'1 H'2 t0 H'3.
case (tripletDec t t0); intros H.
elim (H'2 t);
 [ intros H'6
 | intros H'6; Elimc H'6; intros S0 E; Elimc E; intros S4 E; Elimc E;
    intros H'6 H'7; Elimc H'7; intros H'7 H'8
 | idtac ]; auto with stalmarck.
right; exists S1; exists S2; split; auto with stalmarck; split; auto with stalmarck.
rewrite <- H; auto with stalmarck.
rewrite <- H; auto with stalmarck.
right; exists S1; exists S2; split; auto with stalmarck; split; auto with stalmarck.
rewrite <- H; auto with stalmarck.
apply doTripletsRTrans with (S2 := S0); auto with stalmarck.
rewrite <- H; auto with stalmarck.
apply doTripletsComp with (S1 := S4) (S2 := S3); auto with stalmarck.
rewrite <- H; auto with stalmarck.
apply doTripletInvol with (t := t) (S1 := S1) (S2 := S2); auto with stalmarck.
apply doTripletsIncl with (L := rem triplet tripletDec t L); auto with stalmarck.
elim (H'2 t0);
 [ intros H'6
 | intros H'6; Elimc H'6; intros S0 E; Elimc E; intros S4 E; Elimc E;
    intros H'6 H'7; Elimc H'7; intros H'7 H'8
 | idtac ]; auto with stalmarck.
left.
apply doTripletsTrans with (S2 := S2) (t := t); auto with stalmarck.
right; exists S0; exists S4; split; [ idtac | split ]; auto with stalmarck.
apply doTripletsTrans with (S2 := S2) (t := t); auto with stalmarck.
Qed.

(** Once we have used  a triplet we can do without *)
Theorem doTripletsTermEx :
 forall (L : list triplet) (S1 S2 : State),
 doTripletsP S1 L S2 ->
 eqState S1 S2 \/
 (exists t : triplet,
    (exists S3 : State,
       In t L /\
       doTripletP S1 t S3 /\ doTripletsP S3 (rem _ tripletDec t L) S2)).
Proof.
intros L S1 S2 H'; inversion H'; auto with stalmarck.
right; exists t; exists S3; split; try split; auto with stalmarck.
lapply (doTripletsTermExAux L S3 S2);
 [ intros H'3; elim (H'3 t);
    [ intros H'6
    | intros H'6; Elimc H'6; intros S5 E; Elimc E; intros S6 E; Elimc E;
       intros H'6 H'7; Elimc H'7; intros H'7 H'8
    | idtac ]
 | idtac ]; auto with stalmarck.
apply doTripletsRTrans with (S2 := S5); auto with stalmarck.
apply doTripletsComp with (S1 := S6) (S2 := S2); auto with stalmarck.
apply doTripletInvol with (t := t) (S1 := S1) (S2 := S3); auto with stalmarck.
apply doTripletsIncl with (L := rem triplet tripletDec t L); auto with stalmarck.
Qed.

(** The more we have triplets the more we can do *)
Theorem doTripletsInclList :
 forall (L1 L2 : list triplet) (S1 S2 : State),
 incl L1 L2 -> doTripletsP S1 L1 S2 -> doTripletsP S1 L2 S2.
Proof.
intros L1 L2 S1 S2 H' H'0; generalize L2 H'; elim H'0; clear H'0 H' L2; auto with stalmarck.
intros S3 S4 S5 L0 t H' H'0 H'1 H'2 L2 H'3.
apply doTripletsTrans with (S2 := S4) (t := t); auto with datatypes stalmarck.
Qed.


From stdpp Require Export sets gmultiset countable.
From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates big_op.
From iris.prelude Require Import options.

(* The multiset union CMRA *)
Section gmultiset.
  Context `{Countable K}.
  Implicit Types X Y : gmultiset K.

  Canonical Structure gmultisetO := discreteO (gmultiset K).

  Local Instance gmultiset_valid_instance : Valid (gmultiset K) := λ _, True.
  Local Instance gmultiset_validN_instance : ValidN (gmultiset K) := λ _ _, True.
  Local Instance gmultiset_unit_instance : Unit (gmultiset K) := (∅ : gmultiset K).
  Local Instance gmultiset_op_instance : Op (gmultiset K) := disj_union.
  Local Instance gmultiset_pcore_instance : PCore (gmultiset K) := λ X, Some ∅.

  Lemma gmultiset_op X Y : X ⋅ Y = X ⊎ Y.
  Proof. done. Qed.
  Lemma gmultiset_core X : core X = ∅.
  Proof. done. Qed.
  Lemma gmultiset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->%leibniz_equiv].
      rewrite gmultiset_op. apply gmultiset_disj_union_subseteq_l.
    - intros ->%gmultiset_disj_union_difference. by exists (Y ∖ X).
  Qed.

  Lemma gmultiset_ra_mixin : RAMixin (gmultiset K).
  Proof.
    apply ra_total_mixin; eauto.
    - by intros X Y Z ->%leibniz_equiv.
    - by intros X Y ->%leibniz_equiv.
    - solve_proper.
    - intros X1 X2 X3. by rewrite !gmultiset_op assoc_L.
    - intros X1 X2. by rewrite !gmultiset_op comm_L.
    - intros X. by rewrite gmultiset_core left_id.
    - intros X1 X2 HX. rewrite !gmultiset_core. exists ∅.
      by rewrite left_id.
  Qed.

  Canonical Structure gmultisetR := discreteR (gmultiset K) gmultiset_ra_mixin.

  Global Instance gmultiset_cmra_discrete : CmraDiscrete gmultisetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma gmultiset_ucmra_mixin : UcmraMixin (gmultiset K).
  Proof.
    split; [done | | done]. intros X.
    by rewrite gmultiset_op left_id_L.
  Qed.
  Canonical Structure gmultisetUR := Ucmra (gmultiset K) gmultiset_ucmra_mixin.

  Global Instance gmultiset_cancelable X : Cancelable X.
  Proof.
    apply: discrete_cancelable=> Y Z _ ?. fold_leibniz. by apply (inj (X ⊎.)).
  Qed.

  Lemma gmultiset_opM X mY : X ⋅? mY = X ⊎ default ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

  Lemma gmultiset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma gmultiset_local_update X Y X' Y' : X ⊎ Y' = X' ⊎ Y → (X,Y) ~l~> (X', Y').
  Proof.
    intros HXY. rewrite local_update_unital_discrete=> Z' _. intros ->%leibniz_equiv.
    split; first done. apply leibniz_equiv_iff, (inj (.⊎ Y)).
    rewrite -HXY !gmultiset_op.
    by rewrite -(comm_L _ Y) (comm_L _ Y') assoc_L.
  Qed.

  Lemma gmultiset_local_update_alloc X Y X' : (X,Y) ~l~> (X ⊎ X', Y ⊎ X').
  Proof. apply gmultiset_local_update. by rewrite (comm_L _ Y) assoc_L. Qed.

  Lemma gmultiset_local_update_dealloc X Y X' :
    X' ⊆ Y → (X,Y) ~l~> (X ∖ X', Y ∖ X').
  Proof.
    intros ->%gmultiset_disj_union_difference. apply local_update_total_valid.
    intros _ _ ->%gmultiset_included%gmultiset_disj_union_difference.
    apply gmultiset_local_update. apply gmultiset_eq=> x.
    repeat (rewrite multiplicity_difference || rewrite multiplicity_disj_union).
    lia.
  Qed.

  Lemma big_opMS_singletons X :
    ([^op mset] x ∈ X, {[+ x +]}) = X.
  Proof.
    induction X as [|x X IH] using gmultiset_ind.
    - rewrite big_opMS_empty. done.
    - unfold_leibniz. rewrite big_opMS_disj_union // big_opMS_singleton IH //.
  Qed.

End gmultiset.

Global Arguments gmultisetO _ {_ _}.
Global Arguments gmultisetR _ {_ _}.
Global Arguments gmultisetUR _ {_ _}.