(* This file is part of the Linear Logic  formalization in Coq: https://github.com/brunofx86/LL *)

(** ** Cut Cases

In this file we prove the cases for cut-elimination. Each lemma contains a case for the respective connective (and its dual).
 *)

(* Require Export Tactics.
Set Implicit Arguments. *)

Require Import myTactics.

Lemma aux_CUT_ap n1 n2 h B L M1 M2 v:
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; 0; m; B; L -> exists m, m |~> 0; B; L) ->
  S h = n1 + n2 -> 0%nat = lexp_weight (v ⁺) -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; v ⁺ :: M1 ->
               n2 |~> 0; B; v ⁻ :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H Hh Hw P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * {
      inversion Hn2; subst; inversion Hh; try cut_free.
      - simpl_cases2.
        refine (tab_bot_right_zero _ P _ _ _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_par_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_zero _ _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_with_right_zero _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - refine (tab_copy_right_zero _ _ _ P H2 _ _ Hn1 _) ; eauto.
      - simpl_cases2;
          refine (tab_quest_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - apply resolvers2 in H2; firstorder; inversion H2.
    }
  * apply resolvers2 in H0; firstorder; inversion H0.
  * simpl_cases2.
    top_commutes.
  * simpl_cases2;
      refine (tab_bot_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * simpl_cases2;
      refine (tab_plus1_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * refine (tab_copy_left_zero _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; inversion H0.
Qed.
Arguments aux_CUT_ap [n1 n2 h B L M1 M2 v].

Lemma aux_CUT_tz n1 n2 h B L M1 M2:
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; 0; m; B; L ->
                         exists m, m |~> 0; B; L) ->
  S h = n1 + n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; ⊤ :: M1 ->
               n2 |~> 0; B; 0 :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H0; firstorder; inversion H0.
  * apply resolvers2 in H0; firstorder; inversion H0.
  * {
      simpl_cases4.
      inversion Hn2; subst; inversion Hh; try cut_free.
      - simpl_cases2;
          refine (tab_bot_right_zero _ P _ _ _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_par_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_zero _ _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_zero _ _ _ P _ H4 H3 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_with_right_zero _ _ P _ H3 H4 H6 Hn1 Hn2); eauto.
      - refine (tab_copy_right_zero _ _ _ P H2 _ _ Hn1 _) ; eauto.
      - simpl_cases2;
          refine (tab_quest_right_zero _ _ _ P _ H4 H3 Hn1 _); eauto.
      - apply resolvers2 in H2; firstorder; inversion H2.
    }

  * simpl_cases2;
      refine (tab_bot_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * simpl_cases2;
      refine (tab_plus1_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * refine (tab_copy_left_zero _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; inversion H0.
Qed.
Arguments aux_CUT_tz [n1 n2 h B L M1 M2].

Lemma aux_CUT_bo n1 n2 h B L M1 M2:
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; 0; m; B; L -> exists m, m |~> 0; B; L) ->
  S h = n1 + n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; ⊥ :: M1 ->
               n2 |~> 0; B; 1 :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H0; firstorder; inversion H0.
  * apply resolvers2 in H0; firstorder; inversion H0.
  * simpl_cases2;
      top_commutes.
  * {
      simpl_cases4.
      inversion Hn2; subst; inversion Hh; try cut_free.
      - apply resolvers in H2; firstorder; inversion H2.
      - apply resolvers2 in H2; firstorder.
        eexists.
        rewrite P, H3, H0, union_nil.
        eauto.
      - simpl_cases2; top_commutes.
      - simpl_cases2;
          refine (tab_bot_right_unit' _ P _ _ H3 H4 Hn1 _ ); eauto.
      - simpl_cases2;
          refine (tab_par_right_unit' _ _ P _ H3 H4 Hn1 _); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_unit' _ _ P _ H3 H5 H7 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_unit' _ _ P _ H3 H4 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_unit' _ _  P _ H3 H4 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_with_right_unit' _ _ P _ H3 H5 H7 Hn1 Hn2); eauto.
      - refine (tab_copy_right_unit' _ _ P H2 _ H5 Hn1 _); eauto.
      - simpl_cases2.
        refine (tab_quest_right_unit' _ _ P _ H3 H4 Hn1 _); eauto.
      - apply resolvers2 in H2; firstorder; inversion H2.
    }
  * simpl_cases2;
      refine (tab_par_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * simpl_cases2;
      refine (tab_plus1_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero _ _ P _ H1 H2 H4 Hn1 _ ); eauto.
  * refine (tab_copy_left_zero _ _ _ P H0 H1 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left_zero _ _ _ P _ H2 H1 Hn1 _); eauto.
  * apply resolvers2 in H0; firstorder; inversion H0.
Qed.
Arguments aux_CUT_bo [n1 n2 h B L M1 M2].

Lemma aux_CUT_tp n1 n2 w h B L F G M1 M2:
  (forall m : nat,
      m <= w ->
      forall (h n : nat) (L B : Multiset),
        n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
  w = lexp_weight F + lexp_weight G ->
  S h = n1 + n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; (F ** G) :: M1 ->
               n2 |~> 0; B; (F° $ G°) :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; inversion H1.
  * apply resolvers2 in H1; firstorder; inversion H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2;
      refine (tab_bot_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * {
      destruct (eq_dec (F ** G) (F0 ** G0)) as [Te|notTe].
      rewrite <- Te in *.
      apply tns_eq in Te.
      destruct Te as [Te1 Te2].
      rewrite <- Te1, <- Te2 in *.
      clear Te1. clear Te2.
      + {
          simpl_cases4. (* Tensor é principal em Hn1 *)
          inversion Hn2; subst; inversion Hh; try cut_free.
          - apply resolvers in H1; firstorder; inversion H1.
          - apply resolvers2 in H1; firstorder; inversion H1.
          - simpl_cases2; top_commutes.
          - simpl_cases2;
              refine (tab_bot_right _ P _ _ H6 H4 Hn1 Hn2); eauto.
          -
            destruct (eq_dec (F1 $ G1) (F° $ G°)) as [Te|notTe].
            rewrite Te in *.
            apply par_eq in Te.
            destruct Te as [Te1 Te2].
            rewrite Te1, Te2 in *.
            clear Te1; clear Te2.
            *
              simpl_cases4. (* Par é principal em Hn2 *)
              rewrite meq_swap_cons in H4.
              assert (exists m, m |~> 0 ; B; F° :: (N ++ M0)) as Hyp.
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (0+0);
                  refine (sig3_cut _ _ _ H5 H4); auto]; resolve_max.

              destruct Hyp as [p Hp].
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (0+0);
                  refine (sig3_cut _ _ _ H3 Hp); auto].
              resolve_max.
              rewrite P, H1, H2.
              app_normalize.
            * simpl_cases2.
              assert (exists m, m |~> 0 ; B; F1 :: G1 :: (x ++ M1)) as Hyp.
              rewrite meq_swap_cons in H4;
                rewrite H1 in H4.
              rewrite union_rotate_cons in H4.
              refine (H0 _ _ _ _ _ _);
                [ | change (0%nat) with (0+0);
                    refine (sig3_cut _ _ _ Hn1 H4);
                    auto]. resolve_max.
              solve_permutation.
              destruct Hyp as [t Ht];
                eexists; refine (sig3_par _ Ht); auto;
                  resolve_rewrite.
          - simpl_cases2;
              refine (tab_tensor_right _ _ P _ H4 H6 H8 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_plus1_right _ _ P _ H6 H4 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_plus2_right _ _  P _ H6 H4 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_with_right _ _ P _ _ H6 H8 Hn1 Hn2); eauto.
          - refine (tab_copy_right _ _ P H1 _ H6 Hn1 _); eauto.
          - simpl_cases2;
              refine (tab_quest_right _ _ P _ H6 H4 Hn1 _); eauto.
          - apply resolvers2 in H1; firstorder; inversion H1.
        }
      +
        symmetry in H2.
        simpl_cases2.
        refine (tab_tensor_left_zero' _ _ P _ H1 H3 H5 Hn1 _); eauto.
    }

  * simpl_cases2;
      refine (tab_plus1_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_with_left_zero' _ _ P _ H2 H3 H5 Hn1 _ ); eauto.
  * refine (tab_copy_left _ _ _ P H1 _ H3 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * apply resolvers2 in H1; firstorder; inversion H1.
Qed.
Arguments aux_CUT_tp [n1 n2 w h B L F G M1 M2].

Lemma aux_CUT_pw n1 n2 w h B L F G M1 M2:
  (forall m : nat,
      m <= w ->
      forall (h n : nat) (L B : Multiset),
        n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
  w = lexp_weight F + lexp_weight G ->
  S h = n1 + n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; (F & G) :: M1 ->
               n2 |~> 0; B; (F° ⊕ G°) :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; inversion H1.
  * apply resolvers2 in H1; firstorder; inversion H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2;
      refine (tab_bot_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_tensor_left_zero' _ _ P _ H2 H3 H5 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus1_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * {
      destruct (eq_dec (F & G) (F0 & G0)) as [Te|notTe].
      rewrite <- Te in *.
      apply wth_eq in Te.
      destruct Te as [Te1 Te2].
      rewrite <- Te1, <- Te2 in *.
      clear Te1; clear Te2.
      + {
          simpl_cases4. (* With é principal em Hn1 *)
          inversion Hn2; subst; inversion Hh; try cut_free.
          - apply resolvers in H1; firstorder; inversion H1.
          - apply resolvers2 in H1; firstorder; inversion H1.
          - simpl_cases2; top_commutes.
          - simpl_cases2;
              refine (tab_bot_right _ P _ _ H6 H4 Hn1 Hn2); eauto.
          - simpl_cases2;
              refine (tab_par_right' _ _ P _ H6 H4 Hn1 _ ); eauto.
          - simpl_cases2;
              refine (tab_tensor_right _ _ P _ H4 H6 H8 Hn1 _ ); eauto.
          - destruct (eq_dec (F° ⊕ G°) (F1 ⊕ G1)) as [Te|notTe].
            rewrite <- Te in *.
            apply pls_eq in Te.
            destruct Te as [Te1 Te2].
            rewrite <- Te1 in *.
            clear Te1; clear Te2.
            *
              simpl_cases4. (* Plus1 é principal em Hn2 *)
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (0+0);
                  refine (sig3_cut _ _ _ H3 H4);
                  auto; resolve_rewrite ]; resolve_max.
            * symmetry in H1. simpl_cases2.
              refine (tab_plus1_right _ _ P _ H1 H4 Hn1 _ ); eauto.
          - destruct (eq_dec (F° ⊕ G°) (F1 ⊕ G1)) as [Te|notTe].
            rewrite <- Te in *.
            apply pls_eq in Te.
            destruct Te as [Te1 Te2].
            rewrite <- Te2 in *.
            clear Te1; clear Te2.
            *
              simpl_cases4. (* Plus2 é principal em Hn2 *)
              refine (H _ _ _ _ _ _ _);
                [|change (0%nat) with (0+0);
                  refine (sig3_cut _ _ _ H5 H4);
                  auto; resolve_rewrite ]; resolve_max.
            * symmetry in H1. simpl_cases2.
              refine (tab_plus2_right _ _ P _ H1 H4 Hn1 _ ); eauto.
          - simpl_cases2;
              refine (tab_with_right _ _ P _ _ H6 H8 Hn1 Hn2); eauto.
          - refine (tab_copy_right _ _ P H1 _ H6 Hn1 _); eauto.
          - simpl_cases2;
              refine (tab_quest_right _ _ P _ H6 H4 Hn1 _); eauto.
          - apply resolvers2 in H1; firstorder; inversion H1.
        }
      + symmetry in H2. simpl_cases2.
        refine (tab_with_left_zero' _ _ P _ H1 H3 H5 Hn1 _); eauto.
    }
  * refine (tab_copy_left _ _ _ _ _ _ H3 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * apply resolvers2 in H1; firstorder; inversion H1.
Qed.
Arguments aux_CUT_pw [n1 n2 w h B L F G M1 M2].

Lemma aux_CUT_bq n1 n2 w h B L F M1 M2:
  (forall m : nat,
      m <= w ->
      forall (h n : nat) (L B : Multiset),
        n ~> 0; m; h; B; L -> exists m0 : nat, m0 |~> 0; B; L) ->
  (forall m : nat,
      m <= h ->
      forall (n : nat) (L B : Multiset),
        n ~> 0; S w; m; B; L -> exists m, m |~> 0; B; L) ->
  w = lexp_weight F ->
  S h = n1 + n2 -> L =mul= M1 ++ M2 ->
  n1 |~> 0; B; (! F) :: M1 ->
               n2 |~> 0; B; (? F°) :: M2 ->
                            exists m, m |~> 0 ; B; L.
Proof.
  intros H H0 Hw Hh P Hn1 Hn2.
  inversion Hn1; subst; inversion Hh; try cut_free.
  * apply resolvers in H1; firstorder; inversion H1.
  * apply resolvers2 in H1; firstorder; inversion H1.
  * simpl_cases2; top_commutes.
  * simpl_cases2;
      refine (tab_bot_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_par_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2.
    simpl_cases_tns.

    assert (exists m, m |~> 0 ; B; F0 :: (L1 ++ M2)) as Hyp.
    rewrite HL1 in H3.
    rewrite meq_swap_cons in H3.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0); refine (sig3_cut _ _ _ H3 Hn2);
          auto; try resolve_rewrite]; resolve_max.

    destruct Hyp as [t Ht];
      eexists;
      refine (sig3_tensor _ Ht H5); auto; resolve_rewrite.

    assert (exists m, m |~> 0 ; B; G :: (L2 ++ M2)) as Hyp.
    rewrite HL2 in H5;
      rewrite meq_swap_cons in H5.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0); refine (sig3_cut _ _ _ H5 Hn2);
          auto; try resolve_rewrite]; resolve_max.

    destruct Hyp as [t Ht];
      eexists;
      refine (sig3_tensor _ H3 Ht); auto; resolve_rewrite.
  * simpl_cases2;
      refine (tab_plus1_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_plus2_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * simpl_cases2.
    assert (exists m, m |~> 0 ; B; F0 :: (M2 ++ x)) as Hyp1.
    rewrite H1 in H3;
      rewrite meq_swap_cons in H3.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0);
          refine (sig3_cut _ _ _ H3 Hn2); auto;
          try resolve_rewrite; perm_simplify]; resolve_max.

    assert (exists m, m |~> 0 ; B; G :: (M2 ++ x)) as Hyp2.
    rewrite H1 in H5;
      rewrite meq_swap_cons in H5.
    refine (H0 _ _ _ _ _ _);
      [ | change (0%nat) with (0+0);
          refine (sig3_cut _ _ _ H5 Hn2); auto;
          try resolve_rewrite; perm_simplify]; resolve_max.

    destruct Hyp1 as [t1 Ht1];
      destruct Hyp2 as [t2 Ht2];

      eexists;
      refine (sig3_with _ Ht1 Ht2);
      resolve_rewrite.
    rewrite <- app_comm_cons. solve_permutation.
  * refine (tab_copy_left _ _ _ P _ _ _ Hn1 _); eauto.
  * simpl_cases2;
      refine (tab_quest_left _ _ _ P _ H3 H2 Hn1 _); eauto.
  * {
      apply resolvers2 in H1; firstorder; inversion H1. (* Bang é principal em Hn1 *)
      rewrite H3 in Hn1.
      rewrite <- H6 in *.
      clear H1; clear H6.
      inversion Hn2; subst; inversion Hh; try cut_free.
      - apply resolvers in H1; firstorder; inversion H1.
      - apply resolvers2 in H1; firstorder; inversion H1.
      - simpl_cases2; top_commutes.
      - simpl_cases2;
          refine (tab_bot_right_unit  _ _ _ _ H3 H5 Hn1 Hn2); eauto.
      - simpl_cases2;
          refine (tab_par_right_unit _ _ _ _ H3 H5 Hn1 _ ); eauto.
      - simpl_cases2;
          refine (tab_tensor_right_unit _ _ _ _  H3 H6 H8 Hn1 _ ); eauto.
      - simpl_cases2;
          refine (tab_plus1_right_unit _ _ _ _ H3 H5 Hn1 Hn2 ); eauto.
      - simpl_cases2;
          refine (tab_plus2_right_unit _ _ _ _ H3 H5 Hn1 Hn2 ); eauto.
      - simpl_cases2;
          refine (tab_with_right_unit _ _ _ _ H3 H6 H8 Hn1 _ ); eauto.
      - refine (tab_copy_right_unit _ _ _ H1 _ _ Hn1 Hn2) ; eauto.
      - destruct (eq_dec (? F0°) (? F1)) as [Te|notTe].
        rewrite <- Te in *; rewrite qst_eq in Te.
        rewrite <- Te in *. clear Te.
        + simpl_cases4. (* Quest é principal em Hn2 *)
          eapply H0 with (m:=S n + n0); resolve_max.
          change (0%nat) with (0+0);
            refine (sig3_ccut _ _ _ Hn1 H5); eauto.
        + symmetry in H1. simpl_cases2.
          assert (exists m, m |~> 0 ; F1 :: B ; x) as Hyp.
          eapply height_preserving_weakning_sig3 with (D:=[F1]) in Hn1;
            rewrite union_comm_app in Hn1. simpl in Hn1.
          rewrite H3 in H5.
          refine (H0 _ _ _ _ _ _);
            [|change (0%nat) with (0+0);
              refine (sig3_cut _ _ _ Hn1 H5);
              auto; try resolve_rewrite]; resolve_max.
          destruct Hyp as [t Ht];
            eexists;
            refine (sig3_quest _ Ht); auto;
              resolve_rewrite.
      - apply resolvers2 in H1; firstorder; inversion H1.
    }
Qed.
Arguments aux_CUT_bq [n1 n2 w h B L F M1 M2].


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(* This file contains the class of decidable equality and associated theory
    of updateable functions. *)

Require Import VST.msl.base.

(* Class of decidable equality *)
Class EqDec (A : Type) : Type :=
  eq_dec : forall a a' : A, {a = a'} + {a <> a'}.

Instance EqDec_nat : EqDec nat := eq_nat_dec.

(* Theory of updateable functions, defined over decideable domain *)
Definition upd {A} `{EqDec A} (B : Type) (f : A -> B) (a : A) (b : B) : A -> B :=
  fun a' => if eq_dec a a' then b else f a'.
Arguments upd [A H B] _ _ _ _.

Lemma upd_eq {A} `{EqDec A} : forall B (f : A -> B) a b,
  upd f a b a = b.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a)...
  intro.
  destruct n...
Qed.
Arguments upd_eq [A H B] _ _ _.

Lemma upd_eq' {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a = a' ->
  upd f a b a' = b.
Proof.
  intros. subst a'. apply upd_eq.
Qed.
Arguments upd_eq' [A H B] _ _ _ _ _.

Lemma upd_neq {A} `{EqDec A} : forall B (f : A -> B) a b a',
  a <> a' ->
  upd f a b a' = f a'.
Proof with auto.
  intros.
  unfold upd.
  case (eq_dec a a')...
  intros.
  subst a'.
  destruct H0...
Qed.
Arguments upd_neq [A H B] _ _ _ _ _.

Instance nat_eq_dec: EqDec nat.
Proof.
  repeat intro.
 destruct (lt_eq_lt_dec a a') as [[?|?]| ?]; auto;
  right; intro; subst; eapply lt_irrefl; eauto.
Defined.

Instance EqDec_prod (A: Type) (EA: EqDec A) (B: Type) (EB: EqDec B) : EqDec (A*B).
Proof.
 hnf. decide equality; try apply eq_dec.
Defined.

Instance EqDec_list (A: Type) (EA: EqDec A) : EqDec (list A).
Proof.
 hnf. apply list_eq_dec; intros; apply EA.
Defined.

Instance EqDec_option (A: Type) (EA: EqDec A) : EqDec (option A).
Proof.
  hnf; decide equality.
Defined.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma lfind_hyp_test : (@eq lst (rev (append (Cons (Zero) (Nil)) (Nil))) (append (rev (Nil)) (rev (Cons (Zero) (Nil))))).
Admitted.
QuickChick lfind_hyp_test.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.priority.
Require Import prosa.classic.model.arrival.basic.task.
Require Import prosa.classic.model.schedule.uni.schedulability.
Require Import prosa.classic.model.arrival.jitter.job.
Require Import prosa.classic.model.schedule.uni.jitter.schedule.
Require Import prosa.classic.analysis.uni.jitter.workload_bound_fp
               prosa.classic.analysis.uni.jitter.fp_rta_comp.
Require Import prosa.classic.implementation.uni.jitter.job
               prosa.classic.implementation.uni.jitter.task
               prosa.classic.implementation.uni.jitter.arrival_sequence
               prosa.classic.implementation.uni.jitter.schedule.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq bigop div.

Module ResponseTimeAnalysisFP.

  Import JobWithJitter UniprocessorScheduleWithJitter SporadicTaskset Priority Schedulability
         WorkloadBoundFP ResponseTimeIterationFP.
  Import ConcreteJob ConcreteTask ConcreteArrivalSequence ConcreteScheduler.

  (* In this section, we test the jitter-aware FP RTA on a simple task set
     to show that the theorems contain no contradictory assumptions. *)
  Section ExampleRTA.

    Let tsk1 := {| task_id := 1; task_cost := 1; task_period := 5;
                                 task_deadline := 6; task_jitter := 1 |}.
    Let tsk2 := {| task_id := 2; task_cost := 1; task_period := 5;
                                 task_deadline := 6; task_jitter := 0|}.
    Let tsk3 := {| task_id := 3; task_cost := 1; task_period := 6;
                                 task_deadline := 6; task_jitter := 1|}.

    (* Let ts be a task set containing these three tasks, ... *)
    Program Let ts := Build_set [:: tsk1; tsk2; tsk3] _.

    (* ...which can be shown to have valid parameters. *)
    Remark ts_has_positive_costs:
      forall tsk, tsk \in ts -> task_cost tsk > 0.
    Proof.
      intros tsk IN.
      by repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
    Qed.
    Remark ts_has_positive_periods:
      forall tsk, tsk \in ts -> task_period tsk > 0.
    Proof.
      intros tsk IN.
      repeat (move: IN => /orP [/eqP EQ | IN]; subst; compute); by done.
    Qed.

    (* Next, recall the FP RTA schedulability test using RM as the FP policy. *)
    Let RTA_claimed_bounds :=
      fp_claimed_bounds task_cost task_period task_deadline task_jitter (RM task_period).
    Let schedulability_test :=
      fp_schedulable task_cost task_period task_deadline task_jitter (RM task_period).

    (* First, we show that the schedulability test returns the following bounds.
       (Note that although we check the task jitter, these values only include the
        response-time bounds.) *)
    Fact RTA_yields_these_bounds :
      RTA_claimed_bounds ts = Some [:: (tsk1, 2); (tsk2, 2); (tsk3, 3)].
    Proof.
      rewrite /RTA_claimed_bounds /fp_claimed_bounds.
      set RESP := [seq _ | tsk <- ts].
      suff EQ: RESP = [:: (tsk1, Some 2); (tsk2, Some 2); (tsk3, Some 3)].
        by rewrite EQ; compute.
      rewrite /RESP /ts /=; do 2 f_equal.
      {
        rewrite /per_task_rta /=.
        have WORK: total_workload_bound_fp task_cost task_period task_jitter (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk1 1 = 2.
        {
          by compute; rewrite unlock; compute.
        }
        rewrite !WORK /=; clear WORK.
        have WORK: total_workload_bound_fp task_cost task_period task_jitter (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk1 2 = 2.
        {
          by compute; rewrite unlock; compute.
        }
        by rewrite !WORK /=.
      }
      f_equal.
      {
        rewrite /per_task_rta /=.
        have WORK: total_workload_bound_fp task_cost task_period task_jitter (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk2 1 = 2.
        {
          by compute; rewrite unlock; compute.
        }
        rewrite !WORK /=; clear WORK.
        have WORK: total_workload_bound_fp task_cost task_period task_jitter (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk2 2 = 2.
        {
          by compute; rewrite unlock; compute.
        }
        by rewrite !WORK /=.
      }
      do 2 f_equal.
      {
        rewrite /per_task_rta /=.
        have WORK: total_workload_bound_fp task_cost task_period task_jitter (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk3 1 = 3.
        {
          by compute; rewrite unlock; compute.
        }
        rewrite !WORK /=; clear WORK.
        have WORK: total_workload_bound_fp task_cost task_period task_jitter (RM task_period)
                                                 [:: tsk1; tsk2; tsk3] tsk3 3 = 3.
        {
          by compute; rewrite unlock; compute.
        }
        by rewrite !WORK /=; clear WORK.
      }
    Qed.

    (* Since the response-time bounds plus task jitter are no larger than task deadlines,
       the schedulability test indeed returns true. *)
    Fact schedulability_test_succeeds :
      schedulability_test ts = true.
    Proof.
      rewrite /schedulability_test /fp_schedulable -/RTA_claimed_bounds.
      by rewrite RTA_yields_these_bounds.
    Qed.

    (* Now, let's show that the task set is schedulable. *)

    (* Let arr_seq be the periodic arrival sequence from ts... *)
    Let arr_seq := periodic_arrival_sequence ts.

    (* ...subject to rate-monotonic priority. *)
    Let higher_eq_priority := FP_to_JLDP job_task (RM task_period).

    (* Assume that jobs have jitter that is no larger than the jitter of their tasks. *)
     Variable job_jitter: concrete_job -> time.
     Hypothesis H_jitter_is_bounded:
       forall j,
         arrives_in arr_seq j ->
         job_jitter_leq_task_jitter task_jitter job_jitter job_task j.

    (* Next, let sched be the jitter-aware RM schedule with those jitter values. *)
    Let sched := scheduler job_arrival job_cost job_jitter arr_seq higher_eq_priority.

    (* To conclude, based on the definition of deadline miss,... *)
    Let no_deadline_missed_by :=
      task_misses_no_deadline job_arrival job_cost job_deadline job_task arr_seq sched.

    (* ...we use the result of the jitter-aware FP RTA to conclude that
       no task misses its deadline. *)
    Corollary ts_is_schedulable:
      forall tsk,
        tsk \in ts ->
        no_deadline_missed_by tsk.
    Proof.
      rename H_jitter_is_bounded into JIT.
      intros tsk IN.
      unfold valid_sporadic_job, valid_realtime_job in *; des.
      apply taskset_schedulable_by_fp_rta with (task_cost := task_cost)
                (task_period := task_period) (task_deadline := task_deadline) (ts0 := ts)
                (higher_eq_priority0 := RM task_period) (job_jitter0 := job_jitter)
                (task_jitter := task_jitter); try (by done).
      - by apply ts_has_positive_costs.
      - by apply ts_has_positive_periods.
      - by apply periodic_arrivals_are_consistent.
      - - apply periodic_arrivals_is_a_set.
      - by apply periodic_arrivals_all_jobs_from_taskset.
      - by apply periodic_arrivals_are_sporadic.
      - by apply periodic_arrivals_job_cost_le_task_cost.
      - by apply periodic_arrivals_job_deadline_eq_task_deadline.
      - by apply RM_is_reflexive.
      - by apply RM_is_transitive.
      - by apply scheduler_jobs_come_from_arrival_sequence.
      - by apply scheduler_jobs_execute_after_jitter.
      - by apply scheduler_completed_jobs_dont_execute.
      - by apply scheduler_work_conserving, periodic_arrivals_are_consistent.
      - apply scheduler_respects_policy; first by apply periodic_arrivals_are_consistent.
        -- by intros t; apply RM_is_transitive.
        -- intros j1 j2 t ARR1 ARR2; apply leq_total.
      - by apply schedulability_test_succeeds.
    Qed.

  End ExampleRTA.

End ResponseTimeAnalysisFP.


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import pb.

Section common_proof.

Context `{!heapGS Σ}.

Lemma wp_min sl (l:list u64):
  {{{
       is_slice_small sl uint64T 1%Qp l
  }}}
    min (slice_val sl)
  {{{
       (m:u64), RET #m; ⌜length l > 0 → m ∈ l⌝ ∗ ⌜∀ n, n ∈ l → int.Z m ≤ int.Z n⌝ ∗
       is_slice_small sl uint64T 1%Qp l
  }}}.
Proof.
  iIntros (Φ) "Hpre HΦ".
  wp_lam.
  wp_apply (wp_ref_to).
  { naive_solver. }
  iIntros (m_ptr) "Hm".
  wp_pures.
  wp_apply (wp_forSlice (λ j, ∃ (m:u64),
                            "Hm" ∷ m_ptr ↦[uint64T] #m ∗
                            "%H" ∷ ⌜int.Z j = 0 → ∀ (a:u64), int.Z m >= int.Z a⌝ ∗
                            "%HinL" ∷ ⌜int.nat j > 0 → m ∈ l⌝ ∗
                            "%Hmmin" ∷ ⌜∀ n, n ∈ take (int.nat j) l → int.Z m ≤ int.Z n⌝
                        )%I with "[] [$Hpre Hm]").
  {
    iIntros.
    clear Φ.
    iIntros (Φ) "!# [Hpre %Hi] HΦ".
    destruct Hi as [Hi Hilookup].
    iNamed "Hpre".
    wp_pures.
    wp_load.
    wp_pures.
    wp_if_destruct.
    { (* decrease m *)
      admit.
    }
    { (* no need to decrease m *)
      iApply "HΦ".
      iModIntro.
      iExists _; iFrame.
      iPureIntro.
      split.
      {
        intros Hi2 ?.
        exfalso.
        replace (int.Z (word.add i 1)) with (int.Z i + 1) in Hi2 by word.
        word. (* Hi and Hi2 contradictory *)
      }
      split.
      {
        intros _.
        admit.
      }
      {
        intros.
        admit.
      }
    }
  }
  {
    iExists _.
    iFrame "Hm".
    iPureIntro.
    split.
    {
      intros.
      word.
    }
    split.
    {
      intros.
      by exfalso.
    }
    {
      intros.
      exfalso.
      rewrite take_0 in H.
      set_solver.
    }
  }
  iIntros "[HH Hslice]".
  iNamed "HH".
  wp_pures.
  wp_load.
  iApply "HΦ".
  iModIntro.
  iSplitL ""; first admit. (* FIXME: strengthen precond *)
  iDestruct (is_slice_small_sz with "Hslice") as "%Hsz".
  iFrame.
  rewrite -Hsz in Hmmin.
  rewrite firstn_all in Hmmin.
  iPureIntro.
  apply Hmmin.
Admitted.

End common_proof.


Require Import IOA.
Require Import Misc.
Require Import ListOps.
Require Import OptionOps.
Require Import Simulation.
Require Import Automation.
Require Import Channel.

Require Import List.
Require Import Permutation.

Import ListNotations.

Module FlipFlop.

  Inductive FlipFlopAPI := toggle.
  Definition FlipFlop : AutomatonDef FlipFlopAPI :=
    mkAutomatonDef
      FlipFlopAPI
      bool
      EmptySet
      (fun st => True)
      (fun st act st' =>
         match act with
         | inl e => match e with end
         | inr toggle => match st with
                         | false => st' = true
                         | true => st' = false
                         end
         end).

  Definition FlipFlopFalse := parameterize FlipFlop (fun st => st = false).
  Definition FlipFlopTrue := parameterize FlipFlop (fun st => st = true).

  Definition FlipFlopPair : AutomatonDef FlipFlopAPI :=
    compose
      FlipFlopTrue
      FlipFlopFalse
      FlipFlopAPI
      Some
      Some.

  Lemma FlipFlop_opposite :
    invariant
      FlipFlopPair
      (fun st => fst st <> snd st).
  Proof.
    invariant_ind.
    - intros st Hstart.
      inversion Hstart as [[HT] [HF]].
      congruence.
    - intros st st' act P Hstep.
      destruct act as [[[] | []] | []].
      destruct st as [[] []]; simpl in *; intuition; congruence.
  Qed.

End FlipFlop.

(* from Computer-Assisted Simulation Proofs by Sogaard-Andersen,
Garland, Guttag, Lynch, and Pogosyants *)

Module LossyQueue.

  Section Main.

    Variable M : Type.
    Inductive Queue_API :=
    | Insert : M -> Queue_API
    | Remove : M -> Queue_API
    | Crash : Queue_API
    .
    Definition LossyQueue : AutomatonDef Queue_API :=
      mkAutomatonDef
        Queue_API
        (list M)
        EmptySet
        (fun st => st = [])
        (fun st act st' =>
           match act with
           | inl e => match e with end
           | inr Crash => subsequence st st'
           | inr (Insert m) => st' = st ++ [m]
           | inr (Remove m) => hd_error st = Some m /\ st' = tl st
           end).

    (* delayed implementation *)
    Inductive DQueue_internal := Lose.
    Definition DQueue : AutomatonDef Queue_API :=
      mkAutomatonDef
        Queue_API
        (list (M * bool))
        DQueue_internal
        (fun st => st = [])
        (fun st act st' =>
           match act with
           | inl Lose => subsequence_pred (fun x => snd x = true) st st'
           | inr Crash => st' = map (fun x => (fst x, true)) st
           | inr (Insert m) => st' = st ++ [(m, false)]
           | inr (Remove m) => option_map fst (hd_error st) = Some m /\ st' = tl st
           end).

    Theorem LossyQueue_impl_DQueue : refines LossyQueue DQueue.
    Proof.
      apply forward_simulation with
      (fun st_l st_d => map fst st_d = st_l).
      split.
      - intros s1 Hs1.
        inversion Hs1; subst.
        exists []; simpl; intuition.
      - intros s1' s1 act s2'.
        destruct act as [[] | []];
          intros Hstep Hrel.
        + (* insert *)
          inv_clear Hstep.
          exists (s2' ++ [(m, false)]).
          split.
          * rewrite map_app; subst; auto.
          * eapply Step_External; simpl; auto.
        + (* remove *)
          inv_clear Hstep.
          exists (tl s2').
          split.
          * subst. induction s2'; auto.
          * eapply Step_External; simpl; intuition.
            subst; induction s2'; auto.
        + (* crash - can be simulated by crash and lose (drop corresponding) *)
          exists (map (fun m => (m, true)) s1).
          split.
          * clear; induction s1; simpl; congruence.
          * simpl in Hstep.
            apply Step_External with (map (fun m => (m, true)) s1').
            -- subst; simpl.
               clear.
               rewrite list_map_map.
               induction s2'; simpl; auto.
            -- eapply Step_Internal with (int := Lose); eauto.
               simpl.
               clear Hrel.
               induction Hstep; simpl; auto.
    Qed.

  End Main.

End LossyQueue.

(*
two automata with one one-way channel in each direction (a total of 4
automata)
 *)

Module Ping.

  Import Channel.Channel.

  Inductive Ping_API := Ping | Ping_Done.
  Inductive A_PC := A_Ready | A_Sending | A_Sent | A_Received.
  Inductive B_PC := B_Ready | B_Busy.

  Definition A : AutomatonDef (Ping_API + ChannelSenderAPI unit + ChannelReceiverAPI unit) :=
    mkAutomatonDef
      _
      A_PC
      EmptySet
      (fun st => st = A_Ready)
      (fun st act st' =>
         match act with
         | inl e => match e with end
         | inr (inl (inl Ping)) => st' = A_Sending
         | inr (inl (inr (Send tt))) => st = A_Sending /\ st' = A_Sent
         | inr (inr (Recv tt)) => st' = A_Received
         | inr (inl (inl Ping_Done)) => st = A_Received /\ st' = A_Ready
         end).

  Definition B : AutomatonDef (ChannelSenderAPI unit + ChannelReceiverAPI unit) :=
    mkAutomatonDef
      _
      B_PC
      EmptySet
      (fun st => st = B_Ready)
      (fun st act st' =>
         match act with
         | inl e => match e with end
         | inr (inr (Recv tt)) => st' = B_Busy
         | inr (inl (Send tt)) => st = B_Busy /\ st' = B_Ready
         end).

  Definition A_sender : AutomatonDef _ :=
    compose
      A
      (Channel.Reliable unit)
      (* ping api, A's send channel, A's receive channel *)
      (Ping_API + (ChannelAPI unit) + ChannelReceiverAPI unit)
      (fun act => match act with
                  | inl (inl act') => Some (inl (inl act'))
                  | inl (inr (inl act')) => Some (inl (inr act'))
                  | inr act' => Some (inr act')
                  | _ => None
                  end)
      (fun act => match act with
                  | inl (inr act') => Some act'
                  | _ => None
                  end).

  Definition B_sender : AutomatonDef _ :=
    compose
      B
      (Channel.Reliable unit)
      (* B's receive channel, B's send channel *)
      (ChannelReceiverAPI unit + ChannelAPI unit)
      (fun act => match act with
                  | inl act' => Some (inr act')
                  | inr (inl act') => Some (inl act')
                  | _ => None
                  end)
      (fun act => match act with
                  | inr act' => Some act'
                  | _ => None
                  end).

  Definition AB_system_all : AutomatonDef _ :=
    compose
      A_sender
      B_sender
      (* ping api, A's send channel, B's send channel *)
      (Ping_API + ChannelAPI unit + ChannelAPI unit)
      (fun act => match act with
                  | inl act' => Some (inl act')
                  | inr (inr act') => Some (inr act')
                  | _ => None
                  end)
      (fun act => match act with
                  | inl (inr (inr act')) => Some (inl act')
                  | inr act' => Some (inr act')
                  | _ => None
                  end).

  Definition AB_system : AutomatonDef Ping_API :=
    rename
      AB_system_all
      Ping_API
      (fun act => inl (inl act))
      (ChannelAPI unit + ChannelAPI unit)
      (fun act => match act with
                  | inl act' => inl (inr act')
                  | inr act' => inr act'
                  end).

  Goal in_traces AB_system [Ping; Ping_Done].
  Proof with simpl; intuition; eauto.
    unfold in_traces.
    eexists; ebreak_compstate.
    exists_lift; [simpl; cbv; eauto|].
    eexists.
    estep_ext_break...
    estep_int_break (inr (inl (inl (Send tt))))...
    estep_int_break (inr (inl (inr (Recv tt))))...
    estep_int_break (inr (inr (inl (Send tt))))...
    estep_int_break (inr (inr (inr (Recv tt))))...
    estep_ext_break...
  Qed.

End Ping.

(* Butler Lampson, Reliable Messages and Connection Establishment *)

Module ReliableMessaging.

  Section Main.

    Variable M : Type.
    Variable I : Type.
    Variable I_eq_dec : forall (i i' : I), {i = i'} + {i <> i'}.

    (* Spec *)

    Inductive A := A_ok | A_lost.
    Inductive Status := S_ok | S_lost | S_unknown.
    Definition status_eq_a (status : Status) (a : A) : Prop :=
      (status = S_ok /\ a = A_ok) \/ (status = S_lost /\ a = A_lost).
    Record Spec_state := mkSpecState {
                             q : list M;
                             status : Status;
                             rec_s : bool;
                             rec_r : bool
                           }.
    Definition Spec_start (st : Spec_state) : Prop :=
      st = mkSpecState [] S_lost false false.
    Inductive Action :=
    | put : M -> Action
    | getAck : A -> Action
    | get : M -> Action
    | crash_s : Action
    | recover_s : Action
    | crash_r : Action
    | recover_r : Action
    .
    Inductive Spec_internal := lose.
    Definition Spec_transition
               (st : Spec_state) (act : Spec_internal + Action) (st' : Spec_state) : Prop :=
      match act with
      | inl int =>
        match int with
        | lose => (st.(rec_s) = true \/ st.(rec_r) = true) /\
                  ((exists q', one_removed st.(q) q' /\
                               st' = mkSpecState q' (match q' with
                                                     | [] => S_lost
                                                     | _ => st.(status)
                                                     end) st.(rec_s) st.(rec_r)) \/
                   (st' = mkSpecState st.(q) S_lost st.(rec_s) st.(rec_r)))
        end
      | inr ext =>
        match ext with
        | put m => st.(rec_s) = false /\
                   st' = mkSpecState (st.(q) ++ [m]) S_unknown st.(rec_s) st.(rec_r)
        | getAck a => st.(rec_s) = false /\ status_eq_a st.(status) a /\
                      (st' = st \/
                       st' = mkSpecState st.(q) S_lost st.(rec_s) st.(rec_r))
        | get m => st.(rec_r) = false /\ hd_error st.(q) = Some m /\
                   st' = mkSpecState (tl st.(q)) (match (tl st.(q)) with
                                                  | [] => match st.(status) with
                                                          | S_unknown => S_ok
                                                          | _ => st.(status)
                                                          end
                                                  | _ => st.(status)
                                                  end) st.(rec_s) st.(rec_r)
        | crash_s => st' = mkSpecState st.(q) st.(status) true st.(rec_r)
        | recover_s => st.(rec_s) = true /\
                       st' = mkSpecState st.(q) st.(status) false st.(rec_r)
        | crash_r => st' = mkSpecState st.(q) st.(status) st.(rec_s) true
        | recover_r => st.(rec_r) = true /\
                       st' = mkSpecState st.(q) st.(status) st.(rec_s) false
        end
      end.
    Definition Spec : AutomatonDef Action :=
      mkAutomatonDef _ Spec_state _ Spec_start Spec_transition.

    (* Delayed-Decision Spec *)
    (* mark "+" corresponds to true, mark "#" corresponds to false *)
    Record DSpec_state := mkDSpecState {
                              dq : list (M * bool);
                              dstatus : Status * bool;
                              drec_s : bool;
                              drec_r : bool;
                            }.
    Definition DSpec_start (st : DSpec_state) : Prop :=
      st = mkDSpecState [] (S_lost, true) false false.
    Inductive DSpec_internal := mark | drop | unmark.
    Definition DSpec_transition
               (st : DSpec_state) (act : DSpec_internal + Action) (st' : DSpec_state) : Prop :=
      match act with
      | inl int =>
        match int with
        | mark => (st.(drec_s) = true \/ st.(drec_r) = true) /\
                  ((exists q', one_changed (fun e => (fst e, false)) st.(dq) q' /\
                               st' = mkDSpecState q' st.(dstatus) st.(drec_s) st.(drec_r)) \/
                   (st' = mkDSpecState st.(dq) (fst st.(dstatus), false) st.(drec_s) st.(drec_r)))
        | unmark => (st.(drec_s) = true \/ st.(drec_r) = true) /\
                    ((exists q', one_changed (fun e => (fst e, true)) st.(dq) q' /\
                                 st' = mkDSpecState q' st.(dstatus) st.(drec_s) st.(drec_r)) \/
                     (st' = mkDSpecState st.(dq) (fst st.(dstatus), true) st.(drec_s) st.(drec_r)))
        | drop => (exists q', one_removed_pred (fun e => snd e = false) st.(dq) q' /\
                              st' = mkDSpecState q' (match q' with
                                                     | [] => (S_lost, true)
                                                     | _ => st.(dstatus)
                                                     end) st.(drec_s) st.(drec_r)) \/
                  (snd st.(dstatus) = false /\
                   st' = mkDSpecState st.(dq) (S_lost, true) st.(drec_s) st.(drec_r))
        end
      | inr ext =>
        match ext with
        | put m => st.(drec_s) = false /\
                   st' = mkDSpecState (st.(dq) ++ [(m, true)]) (S_unknown, true) st.(drec_s) st.(drec_r)
        | getAck a => st.(drec_s) = false /\ status_eq_a (fst st.(dstatus)) a /\
                      (st' = mkDSpecState st.(dq) (fst st.(dstatus), true) st.(drec_s) st.(drec_r) \/
                       st' = mkDSpecState st.(dq) (S_lost, true) st.(drec_s) st.(drec_r))
        | get m => st.(drec_r) = false /\ option_map fst (hd_error st.(dq)) = Some m /\
                   st' = mkDSpecState (tl st.(dq)) (match (tl st.(dq)) with
                                                    | [] => match st.(dstatus) with
                                                            | (S_unknown, x) => (S_ok, x)
                                                            | _ => st.(dstatus)
                                                            end
                                                    | _ => st.(dstatus)
                                                    end) st.(drec_s) st.(drec_r)
        | crash_s => st' = mkDSpecState st.(dq) st.(dstatus) true st.(drec_r)
        | recover_s => st.(drec_s) = true /\
                       st' = mkDSpecState st.(dq) st.(dstatus) false st.(drec_r)
        | crash_r => st' = mkDSpecState st.(dq) st.(dstatus) st.(drec_s) true
        | recover_r => st.(drec_r) = true /\
                       st' = mkDSpecState st.(dq) st.(dstatus) st.(drec_s) false
        end
      end.
    Definition DSpec : AutomatonDef Action :=
      mkAutomatonDef _ DSpec_state _ DSpec_start DSpec_transition.

  End Main.

End ReliableMessaging.

Module CounterClock.

  Inductive ClockAPI := Tick.

  Definition Clock :=
    mkAutomatonDef ClockAPI unit EmptySet
      (fun _ => True) (fun _ _ _ => True). (* can tick at any time *)

  Inductive CounterAPI := Count : nat -> CounterAPI.

  Definition Counter :=
    mkAutomatonDef
      (CounterAPI + ClockAPI) nat EmptySet
      (fun st => st = 0)
      (fun st act st' =>
         match act with
         | inl e => match e with end
         | inr (inr Tick) => st' = st + 1
         | inr (inl (Count n)) => st = n /\ st' = st
         end).

  Definition CounterClock :=
    compose
      Counter
      Clock
      (CounterAPI + ClockAPI)
      (fun act => Some act)
      (fun act => match act with
                  | inl _ => None
                  | inr act' => Some act'
                  end).

End CounterClock.


(**********************************************************************)
(* 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                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                         Wave_Factor.v                              *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega List Max.
Require Import IntensionalLib.SF_calculus.Test.
Require Import IntensionalLib.SF_calculus.General.
Require Import IntensionalLib.Tree_calculus.Tree_Terms.
Require Import IntensionalLib.Tree_calculus.Tree_Tactics.
Require Import IntensionalLib.Tree_calculus.Tree_reduction.
Require Import IntensionalLib.Tree_calculus.Tree_Normal.
Require Import IntensionalLib.Tree_calculus.Tree_Closed.
Require Import IntensionalLib.Tree_calculus.Substitution.
Require Import IntensionalLib.Tree_calculus.Tree_Eval.
Require Import IntensionalLib.Tree_calculus.Star.

Definition closed M := maxvar M <= 0.

Definition tree_test is0 is1 is2 :=
star_opt (App (App (App (App (App (Op Node) (Ref 0))
                   (App k_op (App k_op is0)))
              (App k_op (App k_op (App k_op (App k_op is2)))))
    (App k_op i_op))
is1).

Lemma tree_test_zero :
forall is0 is1 is2, closed is0 ->
sf_red (App (tree_test is0 is1 is2) (Op Node)) is0.
Proof.
intros; unfold tree_test.
eapply transitive_red.
eapply2 star_opt_beta.
unfold subst, k_op; simpl.
insert_Ref_out. unfold lift; rewrite ! lift_rec_null.
eval_tac.
rewrite subst_rec_closed; auto.
 Qed.

Lemma tree_test_one :
forall is0 is1 is2 t,
closed is0 -> closed is1 ->
sf_red (App (tree_test is0 is1 is2) (App (Op Node) t))
(App (App is0 (App k_op i_op)) is1).
Proof.
intros; unfold tree_test, i_op, k_op.
eapply transitive_red.
eapply2 star_opt_beta.
unfold subst; simpl.
insert_Ref_out. unfold lift; rewrite lift_rec_null.
eapply transitive_red.
 eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 s_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.
all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.
all: auto.
rewrite ! subst_rec_closed; auto.
 Qed.

Lemma tree_test_two :
forall is0 is1 is2 t u,
closed is2 ->
sf_red (App (tree_test is0 is1 is2) (App (App (Op Node) t) u)) is2.
Proof.
intros; unfold tree_test, k_op.
eapply transitive_red. eapply2 star_opt_beta.
unfold subst; simpl.
insert_Ref_out. unfold lift; rewrite ! lift_rec_null.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 f_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.
all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.
all: auto.
eapply transitive_red. eapply preserves_app_sf_red.
eapply succ_red. eapply2 k_red.
all: auto. eval_tac.
rewrite subst_rec_closed; auto.
Qed.

Definition is_leaf := tree_test k_op (App k_op i_op) (App k_op i_op).
Definition is_stem := tree_test (App k_op i_op) k_op (App k_op i_op).
Definition is_fork := tree_test (App k_op i_op) (App k_op i_op) k_op.

Lemma leaf_test :
sf_red (App is_leaf (Op Node)) k_op /\
sf_red (App is_stem (Op Node)) (App k_op i_op) /\
sf_red (App is_fork (Op Node)) (App k_op i_op).
Proof.
repeat split; unfold is_leaf, is_stem, is_fork, tree_test, i_op, k_op;
repeat eval_tac.
Qed.

Lemma stem_test : forall t,
sf_red (App is_leaf (App (Op Node) t)) (App k_op i_op) /\
sf_red (App is_stem (App (Op Node) t)) k_op /\
sf_red (App is_fork (App (Op Node) t)) (App k_op i_op).
Proof.
repeat split; unfold is_leaf, is_stem, is_fork, tree_test, i_op, k_op;
repeat eval_tac.
Qed.

Lemma fork_test : forall t u,
sf_red (App is_leaf (App (App (Op Node) t) u)) (App k_op i_op) /\
sf_red (App is_stem (App (App (Op Node) t) u)) (App k_op i_op) /\
sf_red (App is_fork (App (App (Op Node) t) u)) k_op.
Proof.
repeat split; unfold is_leaf, is_stem, is_fork, tree_test, i_op, k_op;
repeat eval_tac.
Qed.

Definition swap :=
  star_opt (star_opt (star_opt (App (App (Ref 2) (Ref 0)) (Ref 1)))).

Lemma swap_swaps: forall r t u,
sf_red(App (App (App swap r) t) u) (App (App r u) t).
Proof.
intros; unfold swap.
eapply transitive_red.
eapply star_opt_beta3.
unfold subst, lift; simpl.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
auto.
Qed.

Definition compose :=
star_opt (star_opt (star_opt (App (Ref 2) (App (Ref 1) (Ref 0))))).

Lemma compose_composes :
forall r t u, sf_red (App (App (App compose r) t) u) (App r (App t u)).
Proof.
intros; unfold compose.
eapply transitive_red.
eapply star_opt_beta3.
unfold subst, lift; simpl.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
auto.
Qed.

Definition Fop :=
star_opt (star_opt (star_opt (
App (App (App is_leaf (Ref 2)) (Ref 1))
    (App (App (App is_stem (Ref 2))
   (App (App (App (Op Node) (App (Ref 2) (Op Node))) (Ref 1)) (App swap (Ref 0))))
         (App (App (App (Op Node) (Ref 2)) (Ref 1))
             (App (App compose (Ref 0)) (Op Node)))))))
.

Lemma Fop_normal: normal Fop.
Proof.
replace Fop with (multi_star 3  (App (App (App is_leaf (Ref 2)) (Ref 1))
              (App
                 (App (App is_stem (Ref 2))
                    (App
                       (App (App (Op Node) (App (Ref 2) (Op Node))) (Ref 1))
                       (App Wave_Factor.swap (Ref 0))))
                 (App (App (App (Op Node) (Ref 2)) (Ref 1))
                    (App (App compose (Ref 0)) (Op Node)))))).
2: unfold Fop, multi_star; congruence.
match goal with
| |- normal (multi_star 3 ?M) => replace 3 with (maxvar M)
end.
2: cbv; auto.
eapply2 bind_normal_to_normal.
eapply2 bn_app.
eapply2 bn_app.
eapply2 bn_app. eapply2 bn_normal. cbv. repeat eapply2 nf_compound.
cbv; auto.  cbv; auto.
eapply2 bn_app.
eapply2 bn_app.
eapply2 bn_app.
eapply2 bn_normal. cbv. repeat eapply2 nf_compound. cbv; auto.
eapply2 bn_app.
eapply2 bn_app. cbv. eapply2 bn_normal. repeat eapply2 nf_compound.  cbv; auto. cbv; auto.
eapply2 bn_app.
eapply2 bn_app.
eapply2 bn_app.
eapply2 bn_normal; unfold compose; repeat eapply2 nf_compound. unfold_op; auto. unfold_op; auto.
fold subst_rec star_opt.
simpl .
all: unfold_op; simpl; auto.
Qed.

Lemma factor_leaf:
forall u t, sf_red (App (App (App Fop (Op Node)) u) t) u.
Proof.
intros; unfold Fop.
eapply transitive_red.
eapply2 star_opt_beta3.
unfold subst; simpl.
eval_tac. eval_tac. eval_tac. cbv.  eval_tac. eval_tac.
insert_Ref_out.
unfold lift; rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null; auto.
Qed.

Lemma factor_stem:
forall v u t, sf_red (App (App (App Fop (App (Op Node) v)) u) t)
(App (App t (Op Node)) v).
Proof.
intros; unfold Fop.
eapply transitive_red.
eapply2 star_opt_beta3.
unfold subst; simpl.
eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.  eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
 eval_tac. eval_tac. eval_tac.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null; auto.
eval_tac. eval_tac.  eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.  eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
 eval_tac. eval_tac. eval_tac.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null; auto.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null; auto.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.  eapply preserves_app_sf_red.
 eval_tac. eval_tac.
eapply succ_red. eapply2 f_red.  eval_tac.
eapply succ_red. eapply2 s_red.  auto.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite lift_rec_null; auto.
eval_tac. eval_tac.  eval_tac. eval_tac. eval_tac.
eval_tac. eval_tac.  eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red.
 eapply preserves_app_sf_red.
 eval_tac. auto.  eval_tac. auto.
Qed.