(* ***********************************************************************)
(*                                                                       *)
(*   Synchronously executed Interpreted Time Petri Nets (SITPNs)         *)
(*                                                                       *)
(*                                                                       *)
(*   Copyright Université de Montpellier, contributor(s): Vincent        *)
(*   Iampietro, David Andreu, David Delahaye (May 2020)                  *)
(*                                                                       *)
(*   This software is governed by the CeCILL-C license under French law  *)
(*   and abiding by the rules of distribution of free software.  You can *)
(*   use, modify and/ or redistribute the software under the terms of    *)
(*   the CeCILL-C license as circulated by CEA, CNRS and INRIA at the    *)
(*   following URL "http://www.cecill.info".  The fact that you are      *)
(*   presently reading this means that you have had knowledge of the     *)
(*   CeCILL-C license and that you accept its terms.                     *)
(*                                                                       *)
(* ***********************************************************************)

(* Import Sitpn core material. *)

Require Import simpl.Sitpn.
Require Import simpl.SitpnTokenPlayer.
Require Import simpl.SitpnSemantics.
Require Import simpl.SitpnTactics.
Require Import simpl.SitpnCoreLemmas.

(* Import Hilecop utils. *)

(* Import lemmas about time. *)

Require Import simpl.SitpnRisingEdgeTime.

(* Import lemmas about marking. *)

Require Import simpl.SitpnFallingEdgeFiredComplete.

(** * Completeness of [get_blocked_itvals_and_reset_orders]. *)

Section GetBlockedAndResetComplete.

  (** * Completeness lemma for [get_blocked_itvals_and_reset_orders]. *)

  Lemma get_blocked_and_reset_complete :
    forall (sitpn : Sitpn)
           (s s': SitpnState)
           (time_value : nat)
           (env : Condition -> nat -> bool),
      IsWellDefinedSitpn sitpn ->
      IsWellDefinedSitpnState sitpn s ->
      IsWellDefinedSitpnState sitpn s' ->
      SitpnSemantics sitpn s s' time_value env rising_edge ->

      forall (istate : SitpnState)
             (ditvals : list (Trans * DynamicTimeInterval))
             (transient_marking : list (Place * nat))
             (r_orders : list (Trans * bool))
             (new_ditvals : list (Trans * DynamicTimeInterval)),

        (* Hypotheses on istate. *)
        sitpn_state_eq s istate ->

        (* Hypotheses on ditvals and new_ditvals. *)
        incl ditvals (d_intervals s) ->
        Permutation (fs (new_ditvals ++ ditvals)) (fs (d_intervals s')) ->
        incl new_ditvals (d_intervals s') ->
        NoDup (fs (new_ditvals ++ ditvals)) ->

        (* Hypotheses on r_orders and ditvals. *)
        Permutation ((fs r_orders) ++ (fs ditvals)) (fs (reset s')) ->
        incl r_orders (reset s') ->
        NoDup ((fs r_orders) ++ (fs ditvals)) ->

        (* Hypotheses on transient_marking. *)
        Permutation (fs (marking s)) (fs transient_marking) ->
        (forall (p : Place) (n : nat),
            In (p, n) (marking istate) ->
            In (p, n - pre_sum sitpn p (fired istate)) transient_marking) ->

        (* Conclusion. *)
        exists (ditvals' : list (Trans * DynamicTimeInterval))
               (reset' : list (Trans * bool)),
          get_blocked_itvals_and_reset_orders
            sitpn istate ditvals transient_marking
            r_orders new_ditvals = Some (reset', ditvals')
          /\ Permutation reset' (reset s')
          /\ Permutation ditvals' (d_intervals s').
  Proof.
    intros sitpn s s' time_value env Hwell_def_sitpn
           Hwell_def_s Hwell_def_s' Hspec istate.

    induction ditvals;

      intros transient_marking r_orders new_ditvals
             Hsteq_s_istate Hincl_ditvals Hperm_fs_newd Hincl_newd
             Hnodup_fs_newd Hperm_fs_rorders Hincl_rorders Hnodup_fs_rorders
             Hperm_fsms_fstm Hdef_tm.

    (* BASE CASE, ditvals = []. *)
    - simpl; exists new_ditvals, r_orders;  repeat split.

      (* Proves Permutation r_orders (reset s').
         Strategy: use lemma [permutation_fs_permutation]. *)

      + (* Builds premises to apply [permutation_fs_permutation] *)

        (* Builds NoDup (fs r_orders) *)

        rewrite app_nil_r in Hnodup_fs_rorders.

        (* Builds NoDup (fs (d_intervals s')) *)

        assert (Hnodup_fs_rs' : NoDup (fs (reset s')))
          by (explode_well_defined_sitpn_state Hwell_def_s'; assumption).

        (* Builds Permutation (fs r_orders) (fs (reset s')) *)

        rewrite app_nil_r in Hperm_fs_rorders.

        (* Applies [permutation_fs_permutation]. *)

        apply (permutation_fs_permutation
                 r_orders (reset s') Hnodup_fs_rorders Hnodup_fs_rs'
                 Hincl_rorders Hperm_fs_rorders).

      (* Proves Permutation new_ditvals (d_intervals s').
         Strategy: use lemma [permutation_fs_permutation]. *)

      + (* Builds premises to apply [permutation_fs_permutation] *)

        (* Builds NoDup (fs new_ditvals) *)

        rewrite app_nil_r in Hnodup_fs_newd.

        (* Builds NoDup (fs (d_intervals s')) *)

        assert (Hnodup_fs_ditvals_s' : NoDup (fs (d_intervals s')))
          by (explode_well_defined_sitpn_state Hwell_def_s'; assumption).

        (* Builds Permutation (fs new_ditvals) (fs (d_intervals s')) *)

        rewrite app_nil_r in Hperm_fs_newd.

        (* Applies [permutation_fs_permutation]. *)

        apply (permutation_fs_permutation
                 new_ditvals (d_intervals s') Hnodup_fs_newd
                 Hnodup_fs_ditvals_s' Hincl_newd Hperm_fs_newd).

    (* INDUCTION CASE *)

    - destruct a; simpl.

      (* Specializes is_sensitized_no_error to skip the None case when
         rewriting the goal. *)

      assert (Hin_t_transs : In t (transs sitpn)).
      {
        specialize (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)).
        apply in_fst_split in Hincl_ditvals.
        explode_well_defined_sitpn_state Hwell_def_s.
        rewrite <- (Hwf_state_ditvals t) in Hincl_ditvals.
        apply (proj1 Hincl_ditvals).
      }

      assert (Hincl_fl_m : incl (flatten_neighbours (lneighbours sitpn t)) (fs transient_marking)).
      {
        explode_well_defined_sitpn; unfold NoUnknownPlaceInNeighbours in Hunk_pl_neigh.

        assert (Hincl_flat_lneigh : incl (flatten_neighbours (lneighbours sitpn t))
                                         (flatten_lneighbours sitpn (transs sitpn)))
          by (apply (in_transs_incl_flatten t Hwell_def_sitpn Hin_t_transs)).

        specialize (incl_tran Hincl_flat_lneigh Hunk_pl_neigh) as Hincl_fl_m.
        explode_well_defined_sitpn_state Hwell_def_s.
        rewrite Hwf_state_marking in Hincl_fl_m.
        intros p Hin_p_fl.
        rewrite <- Hperm_fsms_fstm.
        apply (Hincl_fl_m p Hin_p_fl).
      }

      specialize (is_sensitized_no_error sitpn transient_marking t Hincl_fl_m)
        as Hex_is_sens_some.

      inversion_clear Hex_is_sens_some as (b & His_sens_some).
      rewrite His_sens_some.

      (* Two cases, is_sensitized = Some true or Some false. *)

      destruct b.

      (* CASE is_sensitized = Some true. *)

      + (* Two cases: d has reached upper bound and t not fired, or conversely. *)

        case_eq (has_reached_upper_bound d && negb (in_list Nat.eq_dec (fired istate) t)).

        (* CASE has_reached_upper_bound && t ∉ fired = true *)

        -- intros Hhas_reach_and_nfired_true.

           (* Strategy: apply IHditvals, then we need the proper premises. *)

           specialize (IHditvals transient_marking
                                 (r_orders ++ [(t, false)])
                                 (new_ditvals ++ [(t, blocked)])).

           (* Builds all premises to apply IHditvals. The hardest to
              get are:

              - incl (new_ditvals ++ [(t, blocked)]) (d_intervals s')
              - incl (r_orders ++ [(t, false)]) (reset s')

              To get these, the strategy is to specialize one rule of
              the Sitpn semantics. *)

             inversion Hspec.
             clear H H0 H1 H2 H3 H4 H7 H8 H9 H10 H11.
             rename H5 into His_sens_by_tm, H6 into Hhas_and_nfired.

             assert (Hin_tbl_ditvals_s' : In (t, blocked) (d_intervals s')).
             {
               apply andb_prop in Hhas_reach_and_nfired_true.
               inversion_clear Hhas_reach_and_nfired_true as (Hhas_reach_true & Hnfired_true).

               (* Builds premises to apply the Sitpn semantics rule Hhas_and_nfired. *)

               apply (has_reached_upper_bound_correct d) in Hhas_reach_true.
               rewrite negb_true_iff in Hnfired_true.
               apply not_in_list_correct in Hnfired_true.
               specialize (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)).

               (* Rewrites ~In t (fired istate) with some hypotheses from
                  sitpn_state_eq s istate. Result is ~In t (fired s). *)

               unfold sitpn_state_eq in Hsteq_s_istate; apply proj2, proj1 in Hsteq_s_istate.
               rewrite <- Hsteq_s_istate in Hnfired_true.

               (* Applies the rule. *)
               apply (Hhas_and_nfired t d Hincl_ditvals Hhas_reach_true Hnfired_true).
             }

             assert (Hincl_newd' : incl (new_ditvals ++ [(t, blocked)]) (d_intervals s')).
             {
               intros a Hin_newd_app.
               apply in_app_or in Hin_newd_app.
               inversion_clear Hin_newd_app as [Hin_nwd | Hin_tl];
                 [ apply (Hincl_newd a Hin_nwd)
                 | inversion_clear Hin_tl as [Heq_tbl | []];
                   rewrite <- Heq_tbl; assumption ].
             }

             assert (Hin_tfalse_reset_s' : In (t, false) (reset s')).
             {
               (* Builds premises to apply Sitpn semantics rule His_sens_by_tm. *)

               assert (Hperm_pls_fstm : Permutation (places sitpn) (fs transient_marking)).
               {
                 explode_well_defined_sitpn_state Hwell_def_s.
                 unfold fs in Hperm_fsms_fstm.
                 rewrite <- Hwf_state_marking in Hperm_fsms_fstm.
                 assumption.
               }

               assert (Hdef_tm_bis : forall (p : Place) (n : nat),
                          In (p, n) (marking s) ->
                          In (p, n - pre_sum sitpn p (fired s)) transient_marking).
               {
                 intros p n Hin_mistate.
                 unfold sitpn_state_eq in Hsteq_s_istate.
                 specialize (proj1 Hsteq_s_istate) as Hperm_m_s_istate.
                 rewrite Hperm_m_s_istate in Hin_mistate.
                 specialize (Hdef_tm p n Hin_mistate).

                 assert (Hnodup_fs : NoDup (fired s))
                   by (explode_well_defined_sitpn_state Hwell_def_s; assumption).

                 assert (Hnodup_fistate : NoDup (fired istate))
                   by (unfold sitpn_state_eq in Hsteq_s_istate;
                       apply proj2, proj1 in Hsteq_s_istate;
                       rewrite <- Hsteq_s_istate; assumption).

                 assert (Hequiv_fired : forall t : Trans, In t (fired istate) <-> In t (fired s))
                   by (intros a;
                       unfold sitpn_state_eq in Hsteq_s_istate;
                       apply proj2, proj1 in Hsteq_s_istate;
                       rewrite <- Hsteq_s_istate;
                       reflexivity).

                 assert (Heq_presum : pre_sum sitpn p (fired istate) = pre_sum sitpn p (fired s))
                   by (apply (pre_sum_eq_iff_incl sitpn p (fired istate) (fired s) Hnodup_fistate Hnodup_fs Hequiv_fired)).

                 rewrite <- Heq_presum; assumption.
               }

               assert (Hneq_sitvals_none : s_intervals sitpn t <> None).
               {
                 explode_well_defined_sitpn_state Hwell_def_s'.
                 apply in_fst_split in Hin_tbl_ditvals_s'.
                 apply Hwf_state_ditvals, proj2 in Hin_tbl_ditvals_s'.
                 assumption.
               }

               assert (His_sens : IsSensitized sitpn transient_marking t).
               {
                 apply (is_sensitized_correct_perm
                          transient_marking t Hwell_def_sitpn Hperm_pls_fstm
                          Hin_t_transs His_sens_some).
               }

               apply (His_sens_by_tm
                        t transient_marking Hperm_pls_fstm Hdef_tm_bis
                        Hin_t_transs Hneq_sitvals_none His_sens).
             }

             assert (Hincl_rorders' : incl (r_orders ++ [(t, false)]) (reset s')).
             {
               intros a Hin_rorders_app.
               apply in_app_or in Hin_rorders_app.
               inversion_clear Hin_rorders_app as [Hin_rorders | Hin_tl];
                 [ apply (Hincl_rorders a Hin_rorders)
                 | inversion_clear Hin_tl as [Heq_tfalse | []];
                   rewrite <- Heq_tfalse; assumption ].
             }

             (* Rewrites fs and app in IHditvals and in the context's
                hypotheses. *)

             unfold fs in *.

             do 2
             (rewrite fst_split_app in IHditvals;
              (rewrite fst_split_app in IHditvals || auto);
              simpl in IHditvals;
              rewrite <- app_assoc in IHditvals).

             let rewrite_nodup_and_perm H :=
                 ((rewrite fst_split_app in H || auto);
                  rewrite fst_split_cons_app in H;
                  simpl in H)
             in rewrite_nodup_and_perm Hperm_fs_newd;
                  rewrite_nodup_and_perm Hnodup_fs_newd;
                  rewrite_nodup_and_perm Hperm_fs_rorders;
                  rewrite_nodup_and_perm Hnodup_fs_rorders.

             (* Then applies IHditvals. *)
             apply (IHditvals
                      Hsteq_s_istate (incl_cons_inv (t, d) ditvals (d_intervals s) Hincl_ditvals)
                      Hperm_fs_newd Hincl_newd' Hnodup_fs_newd Hperm_fs_rorders Hincl_rorders'
                      Hnodup_fs_rorders Hperm_fsms_fstm Hdef_tm).

        (* CASE has_reached_upper_bound && t ∉ fired = false *)
        -- intros Hhas_reach_and_nfired_false.

           (* Strategy: apply IHditvals, then we need the proper premises. *)

           specialize (IHditvals transient_marking
                                 (r_orders ++ [(t, false)])
                                 (new_ditvals ++ [(t, d)])).

           (* Builds all premises to apply IHditvals. The hardest to
              get are:

              - incl (new_ditvals ++ [(t, d)]) (d_intervals s')
              - incl (r_orders ++ [(t, false)]) (reset s')

              To get these, the strategy is to specialize one rule of
              the Sitpn semantics. *)

           inversion Hspec.
           clear H H0 H1 H2 H3 H4 H6 H8 H9 H10 H11.
           rename H5 into His_sens_by_tm, H7 into Hnot_has_and_nfired.

           assert (Hin_td_ditvals_s' : In (t, d) (d_intervals s')).
           {
             apply andb_false_iff in Hhas_reach_and_nfired_false.
             inversion_clear Hhas_reach_and_nfired_false as [Hhas_reach_false | Hnfired_false].

             (* Case has_reached_upper_bound = false. *)
             - apply (not_has_reached_upper_bound_correct d) in Hhas_reach_false.
               apply or_introl with (B := In t (fired s)) in Hhas_reach_false.

               (* Applies the rule. *)
               apply (Hnot_has_and_nfired t d (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)) Hhas_reach_false).

             (* Case negb (in_list) = false *)
             - rewrite negb_false_iff in Hnfired_false.
               apply in_list_correct in Hnfired_false.
               unfold sitpn_state_eq in Hsteq_s_istate; apply proj2, proj1 in Hsteq_s_istate.
               rewrite <- Hsteq_s_istate in Hnfired_false.
               apply or_intror with (A := ~HasReachedUpperBound d) in Hnfired_false.

               (* Applies the rule. *)
               apply (Hnot_has_and_nfired t d (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)) Hnfired_false).
           }

           assert (Hincl_newd' : incl (new_ditvals ++ [(t, d)]) (d_intervals s')).
           {
             intros a Hin_newd_app.
             apply in_app_or in Hin_newd_app.
             inversion_clear Hin_newd_app as [Hin_nwd | Hin_tl];
               [ apply (Hincl_newd a Hin_nwd)
               | inversion_clear Hin_tl as [Heq_td | []];
                 rewrite <- Heq_td; assumption ].
           }

           assert (Hin_tfalse_reset_s' : In (t, false) (reset s')).
           {
             (* Builds premises to apply Sitpn semantics rule His_sens_by_tm. *)

             assert (Hperm_pls_fstm : Permutation (places sitpn) (fs transient_marking)).
             {
               explode_well_defined_sitpn_state Hwell_def_s.
               unfold fs in Hperm_fsms_fstm.
               rewrite <- Hwf_state_marking in Hperm_fsms_fstm.
               assumption.
             }

             assert (Hdef_tm_bis : forall (p : Place) (n : nat),
                        In (p, n) (marking s) ->
                        In (p, n - pre_sum sitpn p (fired s)) transient_marking).
             {
               intros p n Hin_mistate.
               unfold sitpn_state_eq in Hsteq_s_istate.
               specialize (proj1 Hsteq_s_istate) as Hperm_m_s_istate.
               rewrite Hperm_m_s_istate in Hin_mistate.
               specialize (Hdef_tm p n Hin_mistate).

               assert (Hnodup_fs : NoDup (fired s))
                 by (explode_well_defined_sitpn_state Hwell_def_s; assumption).

               assert (Hnodup_fistate : NoDup (fired istate))
                 by (unfold sitpn_state_eq in Hsteq_s_istate;
                     apply proj2, proj1 in Hsteq_s_istate;
                     rewrite <- Hsteq_s_istate; assumption).

               assert (Hequiv_fired : forall t : Trans, In t (fired istate) <-> In t (fired s))
                 by (intros a;
                     unfold sitpn_state_eq in Hsteq_s_istate;
                     apply proj2, proj1 in Hsteq_s_istate;
                     rewrite <- Hsteq_s_istate;
                     reflexivity).

               assert (Heq_presum : pre_sum sitpn p (fired istate) = pre_sum sitpn p (fired s))
                 by (apply (pre_sum_eq_iff_incl sitpn p (fired istate) (fired s) Hnodup_fistate Hnodup_fs Hequiv_fired)).

               rewrite <- Heq_presum; assumption.
             }

             assert (Hneq_sitvals_none : s_intervals sitpn t <> None).
             {
               explode_well_defined_sitpn_state Hwell_def_s'.
               apply in_fst_split in Hin_td_ditvals_s'.
               apply Hwf_state_ditvals, proj2 in Hin_td_ditvals_s'.
               assumption.
             }

             assert (His_sens : IsSensitized sitpn transient_marking t).
             {
               apply (is_sensitized_correct_perm
                        transient_marking t Hwell_def_sitpn Hperm_pls_fstm
                        Hin_t_transs His_sens_some).
             }

             apply (His_sens_by_tm
                      t transient_marking Hperm_pls_fstm Hdef_tm_bis
                      Hin_t_transs Hneq_sitvals_none His_sens).
           }

           assert (Hincl_rorders' : incl (r_orders ++ [(t, false)]) (reset s')).
           {
             intros a Hin_rorders_app.
             apply in_app_or in Hin_rorders_app.
             inversion_clear Hin_rorders_app as [Hin_rorders | Hin_tl];
               [ apply (Hincl_rorders a Hin_rorders)
               | inversion_clear Hin_tl as [Heq_tfalse | []];
                 rewrite <- Heq_tfalse; assumption ].
           }

           (* Rewrites fs and app in IHditvals and in the context's
                hypotheses. *)

           unfold fs in *.

           do 2
              (rewrite fst_split_app in IHditvals;
               (rewrite fst_split_app in IHditvals || auto);
               simpl in IHditvals;
               rewrite <- app_assoc in IHditvals).

           let rewrite_nodup_and_perm H :=
               ((rewrite fst_split_app in H || auto);
                rewrite fst_split_cons_app in H;
                simpl in H)
           in rewrite_nodup_and_perm Hperm_fs_newd;
                rewrite_nodup_and_perm Hnodup_fs_newd;
                rewrite_nodup_and_perm Hperm_fs_rorders;
                rewrite_nodup_and_perm Hnodup_fs_rorders.

           (* Then applies IHditvals. *)
           apply (IHditvals
                    Hsteq_s_istate (incl_cons_inv (t, d) ditvals (d_intervals s) Hincl_ditvals)
                    Hperm_fs_newd Hincl_newd' Hnodup_fs_newd Hperm_fs_rorders Hincl_rorders'
                    Hnodup_fs_rorders Hperm_fsms_fstm Hdef_tm).

      (* CASE is_sensitized = Some false *)

      + (* Two cases: d has reached upper bound and t not fired, or conversely. *)

        case_eq (has_reached_upper_bound d && negb (in_list Nat.eq_dec (fired istate) t)).

        (* CASE has_reached_upper_bound && t ∉ fired = true *)

        -- intros Hhas_reach_and_nfired_true.

           (* Strategy: apply IHditvals, then we need the proper premises. *)

           specialize (IHditvals transient_marking
                                 (r_orders ++ [(t, true)])
                                 (new_ditvals ++ [(t, blocked)])).

           (* Builds all premises to apply IHditvals. The hardest to
              get are:

              - incl (new_ditvals ++ [(t, blocked)]) (d_intervals s')
              - incl (r_orders ++ [(t, true)]) (reset s')

              To get these, the strategy is to specialize one rule of
              the Sitpn semantics. *)

           inversion Hspec.
           clear H H0 H1 H2 H3 H5 H7 H8 H9 H10 H11.
           rename H4 into Hnot_sens_by_tm, H6 into Hhas_and_nfired.

           assert (Hin_tbl_ditvals_s' : In (t, blocked) (d_intervals s')).
           {
             apply andb_prop in Hhas_reach_and_nfired_true.
             inversion_clear Hhas_reach_and_nfired_true as (Hhas_reach_true & Hnfired_true).

             (* Builds premises to apply the Sitpn semantics rule Hhas_and_nfired. *)

             apply (has_reached_upper_bound_correct d) in Hhas_reach_true.
             rewrite negb_true_iff in Hnfired_true.
             apply not_in_list_correct in Hnfired_true.
             specialize (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)).

             (* Rewrites ~In t (fired istate) with some hypotheses from
                  sitpn_state_eq s istate. Result is ~In t (fired s). *)

             unfold sitpn_state_eq in Hsteq_s_istate; apply proj2, proj1 in Hsteq_s_istate.
             rewrite <- Hsteq_s_istate in Hnfired_true.

             (* Applies the rule. *)
             apply (Hhas_and_nfired t d Hincl_ditvals Hhas_reach_true Hnfired_true).
           }

           assert (Hincl_newd' : incl (new_ditvals ++ [(t, blocked)]) (d_intervals s')).
           {
             intros a Hin_newd_app.
             apply in_app_or in Hin_newd_app.
             inversion_clear Hin_newd_app as [Hin_nwd | Hin_tl];
               [ apply (Hincl_newd a Hin_nwd)
               | inversion_clear Hin_tl as [Heq_tbl | []];
                 rewrite <- Heq_tbl; assumption ].
           }

           assert (Hin_ttrue_reset_s' : In (t, true) (reset s')).
           {
             (* Builds premises to apply Sitpn semantics rule His_sens_by_tm. *)

             assert (Hperm_pls_fstm : Permutation (places sitpn) (fs transient_marking)).
             {
               explode_well_defined_sitpn_state Hwell_def_s.
               unfold fs in Hperm_fsms_fstm.
               rewrite <- Hwf_state_marking in Hperm_fsms_fstm.
               assumption.
             }

             assert (Hdef_tm_bis : forall (p : Place) (n : nat),
                        In (p, n) (marking s) ->
                        In (p, n - pre_sum sitpn p (fired s)) transient_marking).
             {
               intros p n Hin_mistate.
               unfold sitpn_state_eq in Hsteq_s_istate.
               specialize (proj1 Hsteq_s_istate) as Hperm_m_s_istate.
               rewrite Hperm_m_s_istate in Hin_mistate.
               specialize (Hdef_tm p n Hin_mistate).

               assert (Hnodup_fs : NoDup (fired s))
                 by (explode_well_defined_sitpn_state Hwell_def_s; assumption).

               assert (Hnodup_fistate : NoDup (fired istate))
                 by (unfold sitpn_state_eq in Hsteq_s_istate;
                     apply proj2, proj1 in Hsteq_s_istate;
                     rewrite <- Hsteq_s_istate; assumption).

               assert (Hequiv_fired : forall t : Trans, In t (fired istate) <-> In t (fired s))
                 by (intros a;
                     unfold sitpn_state_eq in Hsteq_s_istate;
                     apply proj2, proj1 in Hsteq_s_istate;
                     rewrite <- Hsteq_s_istate;
                     reflexivity).

               assert (Heq_presum : pre_sum sitpn p (fired istate) = pre_sum sitpn p (fired s))
                 by (apply (pre_sum_eq_iff_incl sitpn p (fired istate) (fired s) Hnodup_fistate Hnodup_fs Hequiv_fired)).

               rewrite <- Heq_presum; assumption.
             }

             assert (Hneq_sitvals_none : s_intervals sitpn t <> None).
             {
               explode_well_defined_sitpn_state Hwell_def_s'.
               apply in_fst_split in Hin_tbl_ditvals_s'.
               apply Hwf_state_ditvals, proj2 in Hin_tbl_ditvals_s'.
               assumption.
             }

             assert (Hnot_sens : ~IsSensitized sitpn transient_marking t).
             {
               rewrite (not_is_sensitized_iff_perm
                          transient_marking t Hwell_def_sitpn Hperm_pls_fstm
                          Hin_t_transs) in His_sens_some.
               assumption.
             }

             apply (Hnot_sens_by_tm
                      t transient_marking Hperm_pls_fstm Hdef_tm_bis
                      Hin_t_transs Hneq_sitvals_none Hnot_sens).
           }

           assert (Hincl_rorders' : incl (r_orders ++ [(t, true)]) (reset s')).
           {
             intros a Hin_rorders_app.
             apply in_app_or in Hin_rorders_app.
             inversion_clear Hin_rorders_app as [Hin_rorders | Hin_tl];
               [ apply (Hincl_rorders a Hin_rorders)
               | inversion_clear Hin_tl as [Heq_tfalse | []];
                 rewrite <- Heq_tfalse; assumption ].
           }

           (* Rewrites fs and app in IHditvals and in the context's
                hypotheses. *)

           unfold fs in *.

           do 2
              (rewrite fst_split_app in IHditvals;
               (rewrite fst_split_app in IHditvals || auto);
               simpl in IHditvals;
               rewrite <- app_assoc in IHditvals).

           let rewrite_nodup_and_perm H :=
               ((rewrite fst_split_app in H || auto);
                rewrite fst_split_cons_app in H;
                simpl in H)
           in rewrite_nodup_and_perm Hperm_fs_newd;
                rewrite_nodup_and_perm Hnodup_fs_newd;
                rewrite_nodup_and_perm Hperm_fs_rorders;
                rewrite_nodup_and_perm Hnodup_fs_rorders.

           (* Then applies IHditvals. *)
           apply (IHditvals
                    Hsteq_s_istate (incl_cons_inv (t, d) ditvals (d_intervals s) Hincl_ditvals)
                    Hperm_fs_newd Hincl_newd' Hnodup_fs_newd Hperm_fs_rorders Hincl_rorders'
                    Hnodup_fs_rorders Hperm_fsms_fstm Hdef_tm).

        (* CASE has_reached_upper_bound && t ∉ fired = false *)
        -- intros Hhas_reach_and_nfired_false.

           (* Strategy: apply IHditvals, then we need the proper premises. *)

           specialize (IHditvals transient_marking
                                 (r_orders ++ [(t, true)])
                                 (new_ditvals ++ [(t, d)])).

           (* Builds all premises to apply IHditvals. The hardest to
              get are:

              - incl (new_ditvals ++ [(t, d)]) (d_intervals s')
              - incl (r_orders ++ [(t, true)]) (reset s')

              To get these, the strategy is to specialize one rule of
              the Sitpn semantics. *)

           inversion Hspec.
           clear H H0 H1 H2 H3 H5 H6 H8 H9 H10 H11.
           rename H4 into Hnot_sens_by_tm, H7 into Hnot_has_and_nfired.

           assert (Hin_td_ditvals_s' : In (t, d) (d_intervals s')).
           {
             apply andb_false_iff in Hhas_reach_and_nfired_false.
             inversion_clear Hhas_reach_and_nfired_false as [Hhas_reach_false | Hnfired_false].

             (* Case has_reached_upper_bound = false. *)
             - apply (not_has_reached_upper_bound_correct d) in Hhas_reach_false.
               apply or_introl with (B := In t (fired s)) in Hhas_reach_false.

               (* Applies the rule. *)
               apply (Hnot_has_and_nfired t d (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)) Hhas_reach_false).

             (* Case negb (in_list) = false *)
             - rewrite negb_false_iff in Hnfired_false.
               apply in_list_correct in Hnfired_false.
               unfold sitpn_state_eq in Hsteq_s_istate; apply proj2, proj1 in Hsteq_s_istate.
               rewrite <- Hsteq_s_istate in Hnfired_false.
               apply or_intror with (A := ~HasReachedUpperBound d) in Hnfired_false.

               (* Applies the rule. *)
               apply (Hnot_has_and_nfired t d (Hincl_ditvals (t, d) (in_eq (t, d) ditvals)) Hnfired_false).
           }

           assert (Hincl_newd' : incl (new_ditvals ++ [(t, d)]) (d_intervals s')).
           {
             intros a Hin_newd_app.
             apply in_app_or in Hin_newd_app.
             inversion_clear Hin_newd_app as [Hin_nwd | Hin_tl];
               [ apply (Hincl_newd a Hin_nwd)
               | inversion_clear Hin_tl as [Heq_td | []];
                 rewrite <- Heq_td; assumption ].
           }

           assert (Hin_ttrue_reset_s' : In (t, true) (reset s')).
           {
             (* Builds premises to apply Sitpn semantics rule His_sens_by_tm. *)

             assert (Hperm_pls_fstm : Permutation (places sitpn) (fs transient_marking)).
             {
               explode_well_defined_sitpn_state Hwell_def_s.
               unfold fs in Hperm_fsms_fstm.
               rewrite <- Hwf_state_marking in Hperm_fsms_fstm.
               assumption.
             }

             assert (Hdef_tm_bis : forall (p : Place) (n : nat),
                        In (p, n) (marking s) ->
                        In (p, n - pre_sum sitpn p (fired s)) transient_marking).
             {
               intros p n Hin_mistate.
               unfold sitpn_state_eq in Hsteq_s_istate.
               specialize (proj1 Hsteq_s_istate) as Hperm_m_s_istate.
               rewrite Hperm_m_s_istate in Hin_mistate.
               specialize (Hdef_tm p n Hin_mistate).

               assert (Hnodup_fs : NoDup (fired s))
                 by (explode_well_defined_sitpn_state Hwell_def_s; assumption).

               assert (Hnodup_fistate : NoDup (fired istate))
                 by (unfold sitpn_state_eq in Hsteq_s_istate;
                     apply proj2, proj1 in Hsteq_s_istate;
                     rewrite <- Hsteq_s_istate; assumption).

               assert (Hequiv_fired : forall t : Trans, In t (fired istate) <-> In t (fired s))
                 by (intros a;
                     unfold sitpn_state_eq in Hsteq_s_istate;
                     apply proj2, proj1 in Hsteq_s_istate;
                     rewrite <- Hsteq_s_istate;
                     reflexivity).

               assert (Heq_presum : pre_sum sitpn p (fired istate) = pre_sum sitpn p (fired s))
                 by (apply (pre_sum_eq_iff_incl sitpn p (fired istate) (fired s) Hnodup_fistate Hnodup_fs Hequiv_fired)).

               rewrite <- Heq_presum; assumption.
             }

             assert (Hneq_sitvals_none : s_intervals sitpn t <> None).
             {
               explode_well_defined_sitpn_state Hwell_def_s'.
               apply in_fst_split in Hin_td_ditvals_s'.
               apply Hwf_state_ditvals, proj2 in Hin_td_ditvals_s'.
               assumption.
             }

             assert (Hnot_sens : ~IsSensitized sitpn transient_marking t).
             {
               rewrite (not_is_sensitized_iff_perm
                          transient_marking t Hwell_def_sitpn Hperm_pls_fstm
                          Hin_t_transs) in His_sens_some.
               assumption.
             }

             apply (Hnot_sens_by_tm
                      t transient_marking Hperm_pls_fstm Hdef_tm_bis
                      Hin_t_transs Hneq_sitvals_none Hnot_sens).
           }

           assert (Hincl_rorders' : incl (r_orders ++ [(t, true)]) (reset s')).
           {
             intros a Hin_rorders_app.
             apply in_app_or in Hin_rorders_app.
             inversion_clear Hin_rorders_app as [Hin_rorders | Hin_tl];
               [ apply (Hincl_rorders a Hin_rorders)
               | inversion_clear Hin_tl as [Heq_tfalse | []];
                 rewrite <- Heq_tfalse; assumption ].
           }

           (* Rewrites fs and app in IHditvals and in the context's
                hypotheses. *)

           unfold fs in *.

           do 2
              (rewrite fst_split_app in IHditvals;
               (rewrite fst_split_app in IHditvals || auto);
               simpl in IHditvals;
               rewrite <- app_assoc in IHditvals).

           let rewrite_nodup_and_perm H :=
               ((rewrite fst_split_app in H || auto);
                rewrite fst_split_cons_app in H;
                simpl in H)
           in rewrite_nodup_and_perm Hperm_fs_newd;
                rewrite_nodup_and_perm Hnodup_fs_newd;
                rewrite_nodup_and_perm Hperm_fs_rorders;
                rewrite_nodup_and_perm Hnodup_fs_rorders.

           (* Then applies IHditvals. *)
           apply (IHditvals
                    Hsteq_s_istate (incl_cons_inv (t, d) ditvals (d_intervals s) Hincl_ditvals)
                    Hperm_fs_newd Hincl_newd' Hnodup_fs_newd Hperm_fs_rorders Hincl_rorders'
                    Hnodup_fs_rorders Hperm_fsms_fstm Hdef_tm).
  Qed.

End GetBlockedAndResetComplete.


Require Import AutoSep Bags.

Set Implicit Arguments.

(** * A stronger [starL_weaken] *)

Section starL_weaken_mem.
  Variable A : Type.
  Variables P P' : A -> HProp.

  Theorem starL_weaken_mem : forall ls,
    List.Forall (fun x => P x ===> P' x) ls
    -> starL P ls ===> starL P' ls.
    induction 1; simpl; intuition.
    sepLemma.
    apply Himp_star_frame; auto.
  Qed.
End starL_weaken_mem.

(** * Generic set functionality *)

Module Type S.
  Parameter A : Type.
  Parameter eq_dec : forall x y : A, {x = y} + {x <> y}.
End S.

Module Make(M : S).
  Import M.

  Definition set := A -> Prop.

  Definition mem (x : A) (s : set) := s x.
  Infix "%in" := mem (at level 70, no associativity).

  Definition empty : set := fun _ => False.

  Definition equiv (s1 s2 : set) := forall x, s1 x <-> s2 x.
  Infix "%=" := equiv (at level 70, no associativity).

  Definition incl (s1 s2 : set) : Prop := forall x, s1 x -> s2 x.
  Infix "%<=" := incl (at level 70, no associativity).

  Definition add (s : set) (x : A) : set := fun x' => x' = x \/ s x'.
  Infix "%+" := add (at level 50, left associativity).

  Definition del (s : set) (x : A) : set := fun x' => x' <> x /\ s x'.
  Infix "%-" := del (at level 50, left associativity).

  Ltac sets := subst;
    repeat match goal with
             | [ H : _ %= _ |- _ ] => generalize dependent H
             | [ H : _ %<= _ |- _ ] => generalize dependent H
             | [ H : _ %in _ |- _ ] => generalize dependent H
             | [ H : ~ _ %in _ |- _ ] => generalize dependent H
             | [ H : _ %in _ -> False |- _ ] => generalize dependent H
             | [ H : _ \is _ |- _ ] => generalize dependent H
             | [ H : @eq W _ _ |- _ ] => generalize dependent H
             | [ H : ~(@eq W _ _) |- _ ] => generalize dependent H
           end; clear;
    unfold equiv, empty, incl, mem, add, del, propToWord, IF_then_else; intuition idtac;
      repeat (match goal with
                | [ H : (_, _) = (_, _) |- _ ] => injection H; clear H; intros; subst
                | [ |- context[if ?E then _ else _] ] => destruct E; subst
                | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; subst
              end; intuition idtac);
      try match goal with
            | [ |- _ \/ _ ] => right; intuition idtac
          end;
      repeat match goal with
               | [ x : A, H : forall p : A, _ |- _ ] => specialize (H x)
             end;
      try subst; intuition (try (discriminate || omega)).

  Hint Extern 5 (_ %= _) => sets.
  Hint Extern 5 (_ %<= _) => sets.
  Hint Extern 5 (_ %in _) => sets.
  Hint Extern 5 (~ _ %in _) => sets.
  Hint Extern 5 (_ \is _) => sets.

  Theorem equiv_symm : forall b1 b2,
    b1 %= b2
    -> b2 %= b1.
    sets.
  Qed.

  Theorem equiv_trans : forall b1 b2 b3,
    b1 %= b2
    -> b2 %= b3
    -> b1 %= b3.
    sets.
  Qed.

  Lemma incl_refl : forall b,
    b %<= b.
    sets.
  Qed.

  Lemma incl_trans : forall b1 b2 b3,
    b1 %<= b2
    -> b2 %<= b3
    -> b1 %<= b3.
    sets.
  Qed.

  Lemma incl_mem : forall x b1 b2,
    x %in b1
    -> b1 %<= b2
    -> x %in b2.
    sets.
  Qed.

  Lemma exists_starL_fwd : forall A (P : A -> _) Q,
    (Ex x, P x) * Q ===> Ex x, P x * Q.
    sepLemma.
  Qed.

  Lemma exists_starR_bwd : forall P A (Q : A -> _),
    Ex x, P * Q x ===> P * (Ex x, Q x).
    sepLemma.
  Qed.

  Definition setify (ls : list A) : set :=
    fold_left add ls empty.

  Section starS.
    Variable G : list Type.
    Definition predS := A -> hpropB G.
    Variable P : predS.

    Open Scope Sep_scope.

    Definition starS (s : set) : hpropB G :=
      Ex ls, [| s %= setify ls |] * [| NoDup ls |] * starL P ls.
  End starS.

  Theorem starS_substH_fwd : forall T (P : predS (T :: nil)) b v,
    substH (starS P b) v ===> starS (fun x => substH (P x) v) b.
    unfold starS; intros; autorewrite with sepFormula.
    apply Himp'_ex; intro; apply Himp_ex_c; eexists.
    autorewrite with sepFormula.
    apply Himp_star_frame.
    apply Himp_refl.
    rewrite starL_substH.
    apply Himp_refl.
  Qed.

  Theorem starS_substH_bwd : forall T (P : predS (T :: nil)) b v,
    starS (fun x => substH (P x) v) b ===> substH (starS P b) v.
    unfold starS; intros; autorewrite with sepFormula.
    apply Himp'_ex; intro; apply Himp_ex_c; eexists.
    autorewrite with sepFormula.
    apply Himp_star_frame.
    apply Himp_refl.
    rewrite starL_substH.
    apply Himp_refl.
  Qed.

  Hint Constructors NoDup.

  Section starS_closed.
    Variable P : predS nil.

    Ltac to_himp := repeat intro.
    Ltac from_himp := match goal with
                        | [ |- interp ?specs (?p ?x ?y ---> ?q ?x ?y) ] =>
                          generalize dependent y; generalize dependent x; generalize dependent specs;
                            change (p ===> q)
                      end.

    Theorem starS_empty_bwd : Emp ===> starS P empty.
      to_himp; apply existsR with nil; from_himp; sepLemma.
    Qed.

    Lemma setify_cong : forall ls b1 b2,
      b1 %= b2
      -> fold_left add ls b1 %= fold_left add ls b2.
      induction ls; simpl; intuition.
    Qed.

    Lemma add_something : forall v ls b,
      fold_left add ls (b %+ v) %= fold_left add ls b %+ v.
      induction ls; simpl; intuition.
      eapply equiv_trans; [ | apply IHls ].
      apply setify_cong; auto.
    Qed.

    Lemma setify_include' : forall v ls b b',
      In v ls
      -> b %= fold_left add ls b'
      -> v %in b.
      induction ls; simpl; intuition (subst; eauto).
      assert (b %= fold_left add ls b' %+ v) by (eapply equiv_trans; [ eassumption | apply add_something ]); auto.
    Qed.

    Lemma setify_include : forall v ls b,
      In v ls
      -> b %= setify ls
      -> v %in b.
      intros; eapply setify_include'; eauto.
    Qed.

    Lemma setify_omit : forall v ls b,
      ~v %in b
      -> b %= setify ls
      -> ~In v ls.
      intuition.
      specialize (setify_include _ _ H1 H0); assumption.
    Qed.

    Hint Immediate setify_omit.

    Theorem starS_add_bwd : forall b v, ~v %in b -> starS P b * P v ===> starS P (b %+ v).
      intros; eapply Himp_trans; [ apply exists_starL_fwd | ]; cbv beta.
      to_himp; apply existsL; intro ls; apply existsR with (v :: ls); from_himp.
      simpl; generalize (starL P ls); generalize (P v); sepLemma.
      unfold setify in *; simpl.
      apply equiv_symm; eapply equiv_trans; [ apply add_something | ]; auto.
      eauto.
    Qed.

    Fixpoint nuke (p : A) (ls : list A) : list A :=
      match ls with
        | nil => nil
        | p' :: ls => if eq_dec p p' then ls else p' :: nuke p ls
      end.

    Lemma starL_del_fwd : forall v ls, In v ls
      -> starL P ls ===> P v * starL P (nuke v ls).
      induction ls; unfold setify in *; simpl in *; intuition subst.
      destruct (eq_dec v v); apply Himp_refl || tauto.
      destruct (eq_dec v a); subst; try apply Himp_refl.
      simpl.
      eapply Himp_trans.
      apply Himp_star_frame; [ apply Himp_refl | apply H ].
      generalize (starL P (nuke v ls)); generalize (P a); generalize (P v); sepLemma.
    Qed.

    Lemma In_nuke : forall v x ls,
      In x (nuke v ls)
      -> In x ls.
      induction ls; simpl; intuition;
        match goal with
          | [ _ : context[if ?E then _ else _] |- _ ] => destruct E; subst; simpl in *; intuition
        end.
    Qed.

    Hint Immediate In_nuke.

    Lemma NoDup_nuke : forall v ls,
      NoDup ls
      -> NoDup (nuke v ls).
      induction 1; simpl; intuition;
        match goal with
          | [ |- context[if ?E then _ else _] ] => destruct E; subst
        end; eauto.
    Qed.

    Hint Immediate NoDup_nuke.

    Lemma setify_cases : forall v ls b,
      v %in fold_left add ls b
      -> In v ls \/ v %in b.
      induction ls; simpl; intuition.
      apply IHls in H; intuition sets.
    Qed.

    Lemma setify_In : forall v ls,
      v %in setify ls
      -> In v ls.
      intros; apply setify_cases in H; intuition.
    Qed.

    Lemma setify_In' : forall v ls b,
      v %in b
      -> b %= setify ls
      -> In v ls.
      intros; apply setify_In; sets.
    Qed.

    Hint Immediate setify_In'.

    Lemma setify_nuke' : forall v ls, NoDup ls
      -> forall b b', In v ls
      -> ~v %in b'
      -> b %= fold_left add ls b'
      -> b %- v %= fold_left add (nuke v ls) b'.
      induction 1; simpl; intuition subst;
        match goal with
          | [ |- context[if ?E then _ else _] ] => destruct E; subst; intuition
        end.
      assert (b %= fold_left add l b' %+ v) by (eapply equiv_trans; [ eassumption | apply add_something ]); auto.

      Lemma add_to_del : forall b b' v,
        ~v %in b'
        -> b %= b' %+ v
        -> b %- v %= b'.
        sets.
      Qed.

      apply add_to_del; auto.
      intro.
      apply setify_cases in H4; destruct H4; intuition.

      apply IHNoDup in H3; auto.
      intros.
      assert (v %in b' \/ v = x) by sets.
      tauto.
    Qed.

    Lemma setify_nuke : forall v ls b,
      NoDup ls
      -> In v ls
      -> b %= setify ls
      -> b %- v %= setify (nuke v ls).
      intros; apply setify_nuke'; auto.
    Qed.

    Theorem starS_del_fwd : forall b v, v %in b
      -> starS P b ===> P v * starS P (b %- v).
      intros; eapply Himp_trans; [ | apply exists_starR_bwd ]; cbv beta.
      to_himp; apply existsL; intro ls; apply existsR with (nuke v ls).
      specialize (starL_del_fwd v ls);
        generalize (starL P ls); generalize (P v); generalize (starL P (nuke v ls)).
      intros; from_himp.
      sepLemma.
      apply setify_nuke; eauto.
      transitivity (h0 * h)%Sep; eauto.
      sepLemma.
    Qed.

    Lemma fun_fun_fun : forall A P Q R,
      P * (Ex ls : A, Q ls * R ls)
      ===> (Ex ls : A, Q ls * (P * R ls)).
      sepLemma.
    Qed.

    Theorem starS_del_bwd : forall b v, v %in b
      -> P v * starS P (b %- v) ===> starS P b.
      unfold starS; intros.
      eapply Himp_trans; [ apply fun_fun_fun | ]; cbv beta.
      apply Himp'_ex; intro ls.
      apply Himp_ex_c; exists (v :: ls).
      simpl.
      apply Himp_star_frame; [ | apply Himp_refl ].
      apply Himp_star_pure_c; intro.
      apply Himp_star_pure_cc.
      unfold setify in *; simpl.
      eapply equiv_trans; [ | apply equiv_symm; apply add_something ].

      Lemma del_to_add : forall b b' v,
        v %in b
        -> b %- v %= b'
        -> b %= b' %+ v.
        intros.
        assert (b %- v %+ v %= b' %+ v) by sets.
        clear H0.
        apply equiv_trans with (b %- v %+ v); auto.
        clear H1.
        unfold mem, equiv, del, add in *.
        intros.
        destruct (eq_dec v x); subst; intuition.
      Qed.

      apply del_to_add; auto.

      sepLemma.
      constructor; auto.
      intro.
      eapply setify_include in H2; eauto.
      sets.
    Qed.

    Variable P' : predS nil.

    Theorem starS_weaken : forall b,
      (forall x, x %in b -> P x ===> P' x)
      -> starS P b ===> starS P' b.
      unfold starS; intros.
      apply Himp'_ex; intro; apply Himp_ex_c; eexists.
      eapply Himp_trans; [ apply Himp_star_assoc | ].
      apply Himp_star_pure_c; intro.
      apply Himp_star_frame.
      instantiate (1 := x); sepLemma.
      apply starL_weaken_mem; auto.
      apply Forall_forall; intros.
      apply H.
      eapply setify_include; eauto.
    Qed.

    Section starS_weak.
      Hypothesis HP' : forall x, P x ===>* P' x.

      Theorem starS_weaken_weak : forall b, starS P b ===>* starS P' b.
        unfold HimpWeak in *; propxFo.
        do 4 esplit; eauto.
        split.
        eauto 10.
        apply simplify_fwd.
        eapply starL_weaken_weak; eauto.
      Qed.
    End starS_weak.
  End starS_closed.

End Make.


Require Import Hask.Prelude.
Require Import Hask.Control.Monad.
Require Import Hask.Data.Functor.Contravariant.
Require Import Hask.Data.Functor.Identity.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.
Set Primitive Projections.
Unset Transparent Obligations.

Definition Lens s t a b := forall f, Functor f -> (a -> f b) -> s -> f t.
Definition Lens' s a := Lens s s a a.

Definition Getter s a :=
  forall f, Functor f -> Contravariant f -> (a -> f a) -> s -> f s.

Definition Getting r s a := (a -> Const r a) -> s -> Const r s.

Notation "x &+ f" := (f x) (at level 41, only parsing).

Definition set `(l : Lens s t a b) (x : b) : s -> t :=
  runIdentityF \o l _ _ (fun _ => Id _ x).
Notation "l .~ x" := (set l x) (at level 40).

Definition over `(l : Lens s t a b) (f : a -> b) : s -> t :=
  runIdentityF \o l _ _ (fun x => Id _ (f x)).
Notation "l %~ f" := (over l f) (at level 40).

Definition view `(f : Getting a s a) : s -> a := f id.
Notation "x ^_ l" := (view l x) (at level 40).

Definition stepdownl' `(l : Lens' s a) : Getting a s a := l _ _.
Coercion stepdownl' : Lens' >-> Getting.

Definition stepdowng `(l : Getter s a) : Getting a s a := l _ _ _.
Coercion stepdowng : Getter >-> Getting.

Notation "f \o+ g" := (fun x y => f x y \o g x y) (at level 41, only parsing).

Definition _1 {a b : Type} : Lens' (a * b) a :=
  fun _ _ f s => match s with (x, y) => fmap (fun z => (z, y)) (f x) end.
Definition _2 {a b : Type} : Lens' (a * b) b :=
  fun _ _ f s => match s with (x, y) => fmap (fun z => (x, z)) (f y) end.

Definition _ex1 {a : Type} {P : a -> Prop} : Getter { x : a | P x } a :=
  fun _ _ _ f s => fmap (const s) (f (proj1_sig s)).

Require Import Hask.Control.Monad.Trans.State.

Definition use `(l : Getting a s a) `{Monad m} : StateT s m a :=
  view l <$> getT.

Definition plusStateT `(l : Lens' s nat) (n : nat) `{Monad m} :
  StateT s m unit := modifyT (l %~ plus n).

Notation "l += n" := (plusStateT l n) (at level 41).

Definition modifyStateT `(l : Lens' s a) (x : a) `{Monad m} :
  StateT s m unit := modifyT (l .~ x).

Notation "l .= x" := (modifyStateT l x) (at level 41).

Definition applyStateT `(l : Lens' s a) (f : a -> a) `{Monad m} :
  StateT s m unit := modifyT (l %~ f).

Notation "l %= f" := (applyStateT l f) (at level 41).

Module LensLaws.

Class LensLaws `(l : Lens' s a) := {
  lens_view_set : forall (x : s) (y : a), view l (set l y x) = y;
  lens_set_view : forall (x : s), set l (view l x) x = x;
  lens_set_set  : forall (x : s) (y z : a), set l z (set l y x) = set l z x
}.

#[export]
Program Instance Lens__1 {a b} : LensLaws (s:=a * b) _1.
#[export]
Program Instance Lens__2 {a b} : LensLaws (s:=a * b) _2.

Example lens_ex1 : view _1 (10, 20) = 10.
Proof. reflexivity. Qed.

Example lens_ex2 : view _2 (10, 20) = 20.
Proof. reflexivity. Qed.

Example lens_ex3 : (10, 20) ^_ _2 = 20.
Proof. reflexivity. Qed.

Example lens_ex4 : (1, (2, (3, 4))) ^_ stepdownl' (_2 \o+ _2 \o+ _2) = 4.
Proof. reflexivity. Qed.

Example lens_ex5 : ((10, 20) &+ _1 .~ 500) = (500, 20).
Proof. reflexivity. Qed.

Example lens_ex6 : ((10, 20) &+ _1 %~ plus 1) = (11, 20).
Proof. reflexivity. Qed.

End LensLaws.


From iris.heap_lang Require Import notation.

From SkipList.lib Require Import zrange.
From SkipList.atomic Require Import weakestpre proofmode lock.
From SkipList.jelly_fish Require Import code inv.

Module FindSpec (Params: SKIP_LIST_PARAMS).
  Import Params.
  Module Invariant := SkipListInv Params.
  Export Invariant.

  Section proofs.
    Context `{!heapGS Σ, !skipG Σ}.
    Local Open Scope Z.

    Theorem find_spec (k: Z) (head curr: node_rep) (Γ: lazy_gname)
      (γ: option lazy_gname) (lvl: Z) :
      node_key curr < k < INT_MAX →
      (⌜ curr = head ⌝ ∨ own Γ.(auth_gname) (◯ {[curr]})) -∗
      <<< ∀∀ S, lazy_list head S Γ γ lvl >>>
        find (rep_to_node curr) #k #lvl @ ∅
      <<< ∃∃ pred succ,
        lazy_list head S Γ γ lvl
        ∗
        ⌜ k ≠ node_key succ → k ∉ (set_map node_key S : gset Z) ⌝,
      RET ((rep_to_node pred), (rep_to_node succ)) >>>
      {{{
        (⌜ pred = head ⌝ ∨ own Γ.(auth_gname) (◯ {[pred]}))
        ∗
        (⌜ succ = tail ⌝ ∨ own Γ.(auth_gname) (◯ {[succ]}))
        ∗
        ⌜ node_key pred < k ≤ node_key succ ⌝
      }}}.
    Proof.
      iIntros "%Hk Hcurr %Φ"; iRevert (curr Hk) "Hcurr".
      iLöb as "IH"; iIntros (curr Hk) "#Hcurr AU".
      rewrite difference_empty_L.
      wp_lam. wp_let. wp_let. wp_lam. wp_pures.

      wp_bind (Load #(_)). iMod "AU" as (S) "[Hlazy Hclose]".
      iDestruct (singleton_frag_in with "Hcurr Hlazy") as %Hcurr.
      iDestruct (node_has_next with "Hcurr Hlazy")
        as (s succ) "(Hnext & #Hs & #Hsucc & %Hdisj & Hlazy)".
      destruct (decide (k ≤ node_key succ)) as [|Hcase].
      + wp_load. iDestruct ("Hlazy" with "Hnext") as "Hlazy".
        iDestruct "Hclose" as "[_ Hclose]".
        iDestruct ("Hclose" $! curr succ with "[-]") as ">AP".
        {
          iDestruct (singleton_frag_in with "Hsucc Hlazy") as %Hsucc.
          rewrite elem_of_union elem_of_singleton in Hsucc.
          iFrame "Hlazy"; iPureIntro. intros Hneq Hin%Hdisj.
          apply Hin. rewrite zrange_spec; lia.
        }
        iMod (atomic_post_commit with "AP") as "HΦ".
        iModIntro. wp_load; wp_let; wp_lam; wp_pures.
        case_bool_decide; last lia; wp_if.
        wp_pure. iApply "HΦ".
        iFrame "#". iPureIntro; lia.
      + wp_load. iDestruct ("Hlazy" with "Hnext") as "Hlazy".
        iDestruct "Hclose" as "[Hclose _]".
        iDestruct ("Hclose" with "Hlazy") as ">AU".
        iModIntro; wp_load; wp_let; wp_lam; wp_pures.
        case_bool_decide; first lia; wp_if.

        iDestruct "Hsucc" as "[->|Hsucc]"; first (rewrite /node_key/= in Hcase; lia).
        iApply ("IH" with "[%] [$] AU"); lia.
    Qed.

    Theorem findLock_spec (k: Z) (head curr: node_rep) (Γ: lazy_gname)
      (γ: option lazy_gname) (lvl: Z) :
      node_key curr < k < INT_MAX →
      (⌜ curr = head ⌝ ∨ own Γ.(auth_gname) (◯ {[curr]})) -∗
      <<< ∀∀ S, lazy_list head S Γ γ lvl >>>
        findLock (rep_to_node curr) #k #lvl @ ∅
      <<< ∃∃ pred succ,
        lazy_list head S Γ γ lvl
        ∗
        ⌜ k ≠ node_key succ → k ∉ (set_map node_key S : gset Z) ⌝,
      RET ((rep_to_node pred), (rep_to_node succ)) >>>
      {{{
        (⌜ pred = head ⌝ ∨ own Γ.(auth_gname) (◯ {[pred]}))
        ∗
        (⌜ succ = tail ⌝ ∨ own Γ.(auth_gname) (◯ {[succ]}))
        ∗
        ⌜ node_key pred < k ≤ node_key succ ⌝
        ∗
        ∃ (s: loc),
          (node_next pred +ₗ lvl) ↦{#1 / 2} #s
          ∗
          s ↦□ rep_to_node succ
          ∗
          locked_val lvl s
          ∗
          locked #(node_lock pred +ₗ lvl)
      }}}.
    Proof.
      iIntros "%Hk Hcurr %Φ"; iRevert (curr Hk) "Hcurr".
      iLöb as "IH"; iIntros (curr Hk) "#Hcurr AU".
      rewrite difference_empty_L.
      wp_lam. wp_let. wp_let.

      awp_apply (find_spec with "Hcurr"); first done.
      iApply (aacc_aupd_eq with "AU"); try done.
      iIntros (S) "Hlazy"; iAaccIntro with "Hlazy".
      { do 2 (iIntros; iModIntro; iFrame). }
      iIntros (pred succ') "[Hlazy _]".
      iModIntro. iExists S. iFrame "Hlazy". iIntros "Hlazy".
      iLeft. iFrame "Hlazy". clear dependent S. iIntros "AU".
      iModIntro. iIntros "(#Hpred & _ & [%Hk' _])".
      iModIntro. wp_pures; wp_lam; wp_pures.

      awp_apply acquire_spec.
      iApply (aacc_aupd_sub with "[] AU"); try done.
      { iIntros "!> %S H"; iDestruct (node_has_lock with "Hpred H") as "$". }
      iIntros (S) "Hlazy".
      iDestruct (node_has_lock with "Hpred Hlazy") as "[Hlock Hlazy]".
      iAaccIntro with "Hlock".
      { iIntros "H"; iDestruct ("Hlazy" with "H") as "Hlazy"; iModIntro; iFrame; by iIntros. }
      iIntros "Hlock". iModIntro. iFrame "Hlock".
      iIntros "H"; iDestruct ("Hlazy" with "H") as "Hlazy".
      iLeft. iFrame "Hlazy". clear dependent S. iIntros "AU".
      iModIntro. iIntros "[Hlocked Hin_lock]".
      iModIntro. wp_pures; wp_lam; wp_pures.

      wp_bind (Load #(_)). iMod "AU" as (S) "[Hlazy Hclose]".
      iDestruct (singleton_frag_in with "Hpred Hlazy") as %Hpred.
      iDestruct (node_has_next with "Hpred Hlazy")
        as (s succ) "(Hnext & #Hs & #Hsucc & %Hdisj & Hlazy)".
      destruct (decide (k ≤ node_key succ)) as [|Hcase].
      + iDestruct "Hin_lock" as (?) "[Hnext' Hval]".
        iDestruct (mapsto_agree with "Hnext Hnext'") as %Hs;
          symmetry in Hs; inversion Hs; subst.

        wp_load. iDestruct ("Hlazy" with "Hnext") as "Hlazy".
        iDestruct "Hclose" as "[_ Hclose]".
        iDestruct ("Hclose" $! pred succ with "[Hlazy]") as ">AP".
        {
          iDestruct (singleton_frag_in with "Hsucc Hlazy") as %Hsucc.
          rewrite elem_of_union elem_of_singleton in Hsucc.
          iFrame "Hlazy"; iPureIntro. intros Hneq Hin%Hdisj.
          apply Hin. rewrite zrange_spec; lia.
        }
        iMod (atomic_post_commit with "AP") as "HΦ".
        iModIntro. wp_load; wp_let; wp_lam; wp_pures.
        case_bool_decide; last lia; wp_if.
        wp_pure. iApply "HΦ".
        iFrame "# ∗". iSplit; first (iPureIntro; lia).
        iExists s. iFrame "# ∗".
      + wp_load. iDestruct ("Hlazy" with "Hnext") as "Hlazy".
        iDestruct "Hclose" as "[Hclose _]"; iDestruct ("Hclose" with "Hlazy") as ">AU".
        iModIntro. wp_load; wp_let; wp_lam; wp_pures.
        case_bool_decide; first lia; wp_if.

        clear dependent S.
        awp_apply (release_spec with "Hlocked Hin_lock").
        iApply (aacc_aupd_sub with "[] AU"); try done.
        { iIntros "!> %S H"; iDestruct (node_has_lock with "Hpred H") as "$". }
        iIntros (S) "Hlazy".
        iDestruct (node_has_lock with "Hpred Hlazy") as "(Hlock & Hlazy)".
        iAaccIntro with "Hlock".
        { iIntros "H"; iDestruct ("Hlazy" with "H") as "Hlazy"; iModIntro; iFrame; by iIntros. }
        iIntros "Hlock". iModIntro. iFrame "Hlock".
        iIntros "Hlock"; iDestruct ("Hlazy" with "Hlock") as "Hlazy".
        iLeft. iFrame "Hlazy". clear dependent S. iIntros "AU".
        iModIntro. iIntros "_".
        iModIntro. wp_pures.

        iDestruct "Hsucc" as "[->|Hsucc]"; first (rewrite /node_key/= in Hcase; lia).
        iApply ("IH" with "[%] [$] AU"); lia.
    Qed.
  End proofs.
End FindSpec.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols Worlds.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(* Operational semantics of the network *)

Section NetworkSemantics.

Variable w : world.
Variable this: nid.

Notation getl := (getLocal).
Notation gets := (getStatelet).
Notation getp := (@getProtocol w).

(* Getters for transitions *)

Definition get_coh l := @coh (getp l).
Definition get_st l := @snd_trans (getp l).
Definition get_rt l := @rcv_trans (getp l).

Lemma getsE l s : l \in dom s -> find l s = Some (gets s l).
Proof.
move=>D. rewrite /gets; case f: (find l s)=>[v|]=>//.
by move: f; move/find_none/negbTE; rewrite D.
Qed.

Lemma coh_s l s: Coh w s -> coh (getp l) (gets s l).
Proof. by case=>_ _ _ /(_ l). Qed.

Lemma Coh_dom l s : l \in dom s -> Coh w s ->
                     dom (dstate (gets s l)) =i nodes (getp l) (gets s l).
Proof. by move=>D; case:w=>c h [] W V K E /(_ l); apply:cohDom. Qed.

(* A predicate making all hooks apply to the send-transition with a
   tag st of a protocol with label l.  *)
Definition all_hooks_fire (h : hooks) l st s n (msg : seq nat) to :=
  (* For any hook associated with client protocol l and send-tag st *)
  forall z lc hk, Some hk = find ((z, lc), (l, st)) h ->
  lc \in dom s -> l \in dom s ->
  let: core_local   := getl n (gets s lc) in
  let: client_local := getl n (gets s l)  in
  hk core_local client_local msg to.

(* Semantics of the network in the presence of some world *)
(* Defining small-step semantics of the network *)
Inductive network_step (s1 s2 : state) : Prop :=
  (* Do nothing *)
  Idle of s1 \In Coh w /\ s1 = s2

  (* Send message *)
| SendMsg (* Pick a world, send transition and a recipient *)
          l st (_ : st \In @get_st l) to msg b
          (pf: this \in (nodes (getp l) (gets s1 l)))
          (pf' : l \in dom s1) (C: Coh w s1)

          (* It's safe to send *)
          (S : send_safe st this to (gets s1 l) msg)

          (* All hooks are applicable *)
          (pf_hooks : all_hooks_fire (geth w) l (t_snd st) s1 this msg to)

          (* b is a result of executing the transition *)
          (spf : Some b = send_step S) of

          (* Generate the message and the new local state *)
          let: d :=  gets s1 l in

          (* Update the soup and local state *)
          let: f' := upd this b (dstate d) in
          let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg)
                                              this to true)).1 in
          s2 = upd l (DStatelet f' s') s1

| ReceiveMsg l rt (_ : rt \In @get_rt l) i from
             (* Pick a world, receive transition and a message *)
             (pf: this \in (nodes (getp l)) (gets s1 l))
             (pf': l \in dom s1) (C: Coh w s1)
             (msg : TaggedMessage)
             (pf': tag msg = t_rcv rt) of
             let: d := (gets s1 l) in
             let: f := dstate d in
             let: s := dsoup d  in

             [/\ find i s = Some (Msg msg from this true),
              msg_wf rt (coh_s l C) this from msg &
              (* The semantics doesn't execute unsafe receive-transitions *)
              let loc' := receive_step rt from msg (coh_s l C) pf in
              let: f' := upd this loc' f in
              let: s'' := consume_msg s i in
              s2 = upd l (DStatelet f' s'') s1].

(* The first important result: network stepping preserves overall coherence.

   Intuitively, this follows from the fact that the transitions
   preserve coherence.  *)

Lemma step_coh s1 s2: network_step s1 s2 ->
                      Coh w s1 /\ Coh w s2.
Proof.
case=>[[H1 <-] | l st _ to a loc' pf D C S Ph Spf ->/= |
       l rt _ i from pf D C H1 msg [H3 H4->/=]]//; split=>//.
- case: (C)=>W V K E H; split=>//; first by rewrite validU/= V.
  + move=>z; rewrite domU/= !inE V.
    by case b:  (z == l)=>//; move/eqP: b=>?; subst; rewrite E D.
  move=>k; case b: (k == l); rewrite /gets findU b/=; last by apply: H.
  rewrite V/=; move/eqP: b=>Z; subst k=>/=.
  case: st a S Ph Spf => /= t_snd ssafe G1 G2 sstep Y G3 a S Ph Spf.
  have X: exists b pf, sstep this to (gets s1 l) a pf = Some b by exists loc', S.
  move/Y: X=>X; move: (G1 _ _ _ _ X) (G2 _ _ _ _ X)=>{G1 G2}G1 G2; apply: G3.
  rewrite /gets in Spf; rewrite Spf; move: (coh_s l C)=>G1'.
  by rewrite -(pf_irr X S).
case: (C)=>W V K E H; split=>//; first by rewrite validU/= V.
- move=>z; rewrite domU/= !inE V.
  by case b:  (z == l)=>//; move/eqP: b=>?; subst; rewrite E D.
move=>k; case b: (k == l); rewrite /gets findU b/=; last by apply: H.
move: (coh_s l (And5 W V K E H))=>G1.
rewrite V; move/eqP: b=>Z; subst k=>/=.
have pf' : this \in dom (dstate (gets s1 l))
  by move: (pf); rewrite -(Coh_dom D C).
case: rt H1 H3 msg H4=>/= r_rcvwf mwf rstep G msg T F M.
rewrite -(pf_irr (H l) (coh_s l C)) in M.
move: (G (gets s1 l) from this i (H l) pf msg pf' T M F); rewrite /gets.
by move: (H l)=>G1'; rewrite -(pf_irr G1 G1').
Qed.

(* Stepping preserves the protocol structure *)
Lemma step_preserves_labels s1 s2 :
  network_step s1 s2 -> dom s1 =i dom s2.
Proof.
by move/step_coh=>[[_ _ _ E1 _][_ _ _ E2 _]]z; rewrite -E1 -E2.
Qed.

(* Stepping only changes the local state of "this" node,
   in any of the protocols. *)

Lemma step_is_local s1 s2 l: network_step s1 s2 ->
  forall z, z != this ->
  find z (dstate (gets s1 l)) = find z (dstate (gets s2 l)).
Proof.
move=>S z N; case: S; first by case=>_ Z; subst s2.
- move=>k st ? to a b pf D C S Ph Spf Z; subst s2; case B: (l == k);
          rewrite /gets findU B //= (cohS C)/=.
  by move/negbTE: N; rewrite findU=>->/=; move/eqP: B=>->.
move=>k rt ? i from H1 H2 C msg T/= [H3 H4]Z; subst s2.
case B: (l == k); rewrite /gets findU B //= (cohS C)/=.
by move/negbTE: N; rewrite findU=>->/=; move/eqP: B=>->.
Qed.

(* Lemma step_other_label s1 s2 l: network_step s1 s2 -> *)
(*   forall z l', l' != l -> *)
(*   find z (dstate (gets s1 l')) = find z (dstate (gets s2 l')). *)
(* Proof. *)
(* move=>S z l' N; case: S; first by case=>_ Z; subst s2. *)
(* (* Send-transition *) *)
(* move=>k st ? to a b pf D C S Ph Spf Z; subst s2. *)
(* case B: (l' == k); rewrite /gets !findU B ?(cohS C)//=. *)
(* move/eqP: B=>B; subst l'. *)
(* case: dom_find D=>//d -> E _. rewrite findU. *)
(* Search _ (dom_find_spec). *)
(* (* Receive-transition *) *)
(* Qed. *)

Lemma stepV1 s1 s2: network_step s1 s2 -> valid s1.
Proof. by case/step_coh=>/cohS. Qed.

Lemma stepV2 s1 s2: network_step s1 s2 -> valid s2.
Proof. by case/step_coh=>_ /cohS. Qed.

(*
   Network steps do not allocate/deallocate nodes
   (although this might change soon)
 *)
Lemma step_preserves_node_ids s1 s2 l:
  l \in dom s1 -> network_step s1 s2 ->
  dom (dstate (gets s1 l)) =i dom (dstate (gets s2 l)).
Proof.
move=>D S; case: (S); first by case=>C<-.
- move=> l' st H to msg b H1 H2 C _ _ _ Z; subst s2.
  rewrite /gets findU; case B: (l == l')=>//=; rewrite (stepV1 S)/==>n.
  move/eqP: B=>B; subst l'; rewrite domU/= !inE; case B: (n == this)=>//.
  move/eqP:B=>B; subst n; rewrite -(Coh_dom D C) in H1; rewrite H1.
  by case: C=>_ _ _ _/(_ l)/cohVl->.
move=>l' rt _ m from H1 D' C msg E[F]W/=Z; subst s2.
rewrite /gets findU; case B: (l == l')=>//=; rewrite (stepV1 S)/==>n.
move/eqP: B=>B; subst l'; rewrite domU/= !inE; case B: (n == this)=>//.
move/eqP:B=>B; subst n; clear S; rewrite -(Coh_dom D C) in H1; rewrite H1.
by case: (C)=>_ _ _ _/(_ l)/cohVl->.
Qed.

End NetworkSemantics.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.SimpleParsers.

Notation H := (TwoOnesChunk.header + TwoOnesBucket.header).
Notation A := (Sum.sum TwoOnesChunk.aut TwoOnesBucket.aut).
Notation conf := (P4automaton.configuration (P4A.interp A)).

Definition r_states : {r : Reachability.state_pairs A & Reachability.reachable_states_wit TwoOnesChunk.Start TwoOnesBucket.Start r}.
  econstructor.
  unfold Reachability.reachable_states_wit.
  solve_fp_wit.
Defined.

Declare ML Module "mirrorsolve".

(*
RegisterEnvCtors
  (TwoOnesChunk.Bits, FirstOrderConfRelSimplified.Bits 2)
  (TwoOnesBucket.Bits, FirstOrderConfRelSimplified.Bits 2)
  (TwoOnesBucket.Val, FirstOrderConfRelSimplified.Bits 1).
*)

Lemma prebisim_babyip:
  forall q1 q2,
    interp_conf_rel' {| cr_st := {|
                        cs_st1 := {|
                          st_state := inl (inl (TwoOnesChunk.Start));
                          st_buf_len := 0;
                        |};
                        cs_st2 := {|
                          st_state := inl (inr (TwoOnesBucket.Start));
                          st_buf_len := 0;
                        |};
                      |};
                      cr_ctx := BCEmp;
                      cr_rel := btrue;
                   |} q1 q2 ->
  pre_bisimulation A
                   (projT1 r_states)
                   (wp (a := A))
                   []
                   (mk_init _ _ _ _ A 10 TwoOnesChunk.Start TwoOnesBucket.Start)
                   q1 q2.
Proof.
  idtac "running small bucket bisimulation".

  intros.
  set (rel0 := (mk_init _ _ _ _ A 10 TwoOnesChunk.Start TwoOnesBucket.Start)).
  vm_compute in rel0.
  subst rel0.

  time "build phase" repeat (time "single step" run_bisim).
  time "close phase" close_bisim.
Time Admitted.


Require Import Hask.Prelude.
Require Import Hask.Control.Monad.
Require Import Hask.Control.Monad.Trans.Class.
Require Import Hask.Control.Monad.Morph.
Require Import Hask.Control.Impl.
Require Import Hask.Control.Compose.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Definition ReaderT (X : Type) (M : Type -> Type) (Y : Type) : Type :=
  X -> M Y.

Definition runReaderT {E M A} (r : ReaderT E M A) := r.

#[export]
Program Instance ReaderT_Functor `{Functor m} {E} : Functor (ReaderT E m) :=
  @Compose_Functor _ Impl_Functor m _.

#[export]
Program Instance ReaderT_Applicative `{Applicative m} {E} :
  Applicative (ReaderT E m) :=
  @Compose_Applicative _ m Impl_Applicative _.

#[export]
Program Instance ReaderT_Monad `{Monad m} {E} : Monad (ReaderT E m) :=
  @Compose_Monad _ Impl_Monad m _ Impl_Monad_Distributes.

#[export]
Instance ReaderT_MonadTrans {E} : MonadTrans (ReaderT E) :=
{ lift := fun _ _ _ _ => fun v _ => v
}.

#[export]
Program Instance ReaderT_MFunctor {E} : MFunctor (ReaderT E) :=
{ hoist := fun _ _ _ _ _ nat => fun v1 v2 => nat _ (v1 v2)
}.

Module ReaderTLaws.

Import MonadLaws.
Import ComposeMonadLaws.
Import ImplMonadLaws.

#[export]
Program Instance ReaderT_FunctorLaws `{FunctorLaws m} {E} :
  FunctorLaws (ReaderT E m) :=
  @Compose_FunctorLaws _ Impl_Functor Impl_FunctorLaws m _ _.

#[export]
Program Instance ReaderT_ApplicativeLaws `{ApplicativeLaws m} {E} :
  ApplicativeLaws (ReaderT E m) :=
  @Compose_ApplicativeLaws _ _ Impl_ApplicativeLaws m _ _.

#[export]
Program Instance ReaderT_MonadLaws `{MonadLaws m} {E} :
  MonadLaws (ReaderT E m) :=
  @Compose_MonadLaws _ m Impl_Monad _ _ Impl_Monad_DistributesLaws.

End ReaderTLaws.

Class MonadReader (r : Type) (m : Type -> Type) `{Monad m} := {
  ask    : m r;
  local  : forall a, (r -> r) -> m a -> m a;
  reader : forall a, (r -> a) -> m a
}.

#[export]
Program Instance ReaderT_MonadReader {E} `{Monad m} :
  MonadReader E (ReaderT E m) := {
  ask    := pure;
  local  := fun _ f m => fun v => m (f v);
  reader := fun _ f => fun v => pure (f v)
}.


Require Import List.
Import ListNotations.

Require Import StructTact.StructTactics.
Require Import InfSeqExt.infseq.

Require Import Chord.Chord.

Require Import Chord.LabeledLemmas.
Require Import Chord.ChannelLemmas.
Require Import Chord.HandlerLemmas.
Require Import Chord.LabeledMeasures.
Require Import Chord.SystemLemmas.
Require Import Chord.SystemReachable.

Require Import Chord.LiveNodesStayLive.
Require Import Chord.ValidPointersInvariant.
Require Import Chord.NodesHaveState.
Require Import Classical.

Require Import mathcomp.ssreflect.ssreflect.

Definition no_msgs_to_live_from (h : addr) (occ : occurrence) :=
  forall dst, live_node (occ_gst occ) dst -> channel (occ_gst occ) h dst = [].

Definition no_msgs_to_live_from_dead_nodes (occ : occurrence) :=
  forall h, In h (failed_nodes (occ_gst occ)) -> no_msgs_to_live_from h occ.

Definition msg_from_length (h : addr) (dst : addr) (occ : occurrence) : nat :=
  length (channel (occ_gst occ) h dst).

Lemma no_msgs_from_dead_nodes_elim :
  forall occ, no_msgs_to_live_from_dead_nodes occ ->
    (forall src, In src (failed_nodes (occ_gst occ)) ->
     forall dst, live_node (occ_gst occ) dst ->
     channel (occ_gst occ) src dst = []).
Proof.
  unfold no_msgs_to_live_from_dead_nodes, no_msgs_to_live_from.
  auto.
Qed.

Lemma always_monotonic_complex :
  forall T (J P Q : infseq T -> Prop),
    (forall s, J s -> P s -> Q s) ->
    (forall x s, J (Cons x s) -> J s) ->
    forall s,
      J s ->
      always P s ->
      always Q s.
Proof.
  intros T J P Q PQ Jinvar.  cofix cf. intros (x, s) HJ HP.
  generalize (@always_Cons _ x s P HP); simpl; intros (a1, a2).
  constructor; simpl; eauto.
Qed.

Set Bullet Behavior "Strict Subproofs".

Lemma hd_now :
  forall T (ex : infseq T) (P : T -> Prop),
    P (hd ex) ->
    now P ex.
Proof.
  intros.
  destruct ex. simpl in *. auto.
Qed.

Lemma Forall_continuously_commute:
  forall (T X : Type) (ex : infseq T) (L : list X) (P : X ->  T -> Prop),
    Forall (fun x => continuously (now (P x)) ex) L ->
    continuously (now (fun t => Forall (fun x => P x t) L)) ex.
Proof.
  induction L.
  - intros. simpl in *.
    unfold continuously. apply E0.
    apply always_inv;
      intros; apply hd_now;
      eauto using Forall_nil.
  - intros. simpl.
    inv_prop Forall.
    eapply continuously_monotonic with
        (P := and_tl (now (fun t => Forall (fun x => P x t) L))
                     (now (P a))).
    + intros. unfold and_tl in *. intuition.
      repeat find_apply_lem_hyp now_hd.
      apply hd_now. auto.
    + apply continuously_and_tl; auto.
Qed.

Lemma ForallPairs_nil :
  forall X (Q : X -> X -> Prop),
    ForallPairs Q [].
Proof.
  intros.
  unfold ForallPairs. simpl. intuition.
Qed.

Lemma ForallPairs_cons_intro :
  forall X (Q : X -> X -> Prop) L x,
    ForallPairs Q L ->
    Q x x ->
    Forall (fun y => Q y x) L ->
    Forall (fun y => Q x y) L ->
    ForallPairs Q (x :: L).
Proof.
  intros.
  unfold ForallPairs. intros.
  simpl in *.
  intuition; subst; intuition eauto;
    find_eapply_lem_hyp Forall_forall; eauto;
      simpl in *; auto.
Qed.

Lemma ForallPairs_cons_elim :
  forall X (Q : X -> X -> Prop) L x,
    ForallPairs Q (x :: L) ->
    Q x x /\
    Forall (fun y => Q y x) L /\
    Forall (fun y => Q x y) L /\
    ForallPairs Q L.
Proof.
  intros.
  unfold ForallPairs in *. simpl in *.
  intuition eauto;
    apply Forall_forall; eauto.
Qed.

Lemma ForallPairs_continuously_commute :
  forall T X (ex : infseq T) L (Q : X -> X -> T -> Prop),
    (forall x s, Q x x s) ->
    (ForallPairs (fun x y => continuously (now (Q x y)) ex) L) ->
    continuously (now (fun t => ForallPairs (fun x y => Q x y t) L)) ex.
Proof.
  induction L.
  - intros. simpl in *.
    unfold continuously. apply E0.
    apply always_inv; simpl in *;
      intros; apply hd_now; eauto using ForallPairs_nil.
  - intros. simpl.
    find_apply_lem_hyp ForallPairs_cons_elim. intuition.
    eapply continuously_monotonic with
        (P := and_tl (now (fun t => ForallPairs (fun x y => Q x y t) L))
                     (and_tl
                        (now (fun t => Forall (fun y => Q y a t) L))
                        (now (fun t => Forall (fun y => Q a y t) L)))).
    + intros. unfold and_tl in *. intuition.
      repeat find_apply_lem_hyp now_hd.
      apply hd_now.
      eauto using  ForallPairs_cons_intro.
    + apply continuously_and_tl; eauto.
      apply continuously_and_tl;
        eauto using Forall_continuously_commute.
Qed.

(* Stand back, I'm going to try classical logic *)
Lemma continuously_imp :
  forall T (P : Prop) (Q : T -> Prop) ex,
    (P ->  continuously (now Q) ex) ->
    continuously (now (fun x => P -> Q x)) ex.
Proof.
  unfold continuously. intros.
  destruct (classic P).
  - intuition.
    eapply eventually_monotonic_simple; [|eauto]; eauto.
    intros.
    eapply always_monotonic; [|eauto]; eauto.
    intros.
    eapply now_monotonic; [|eauto]; eauto.
  - apply E0. apply always_inv; intros; apply hd_now; intuition.
Qed.

Lemma dead_nodes_go_quiet :
  forall ex,
    reachable_st (occ_gst (hd ex)) ->
    weak_local_fairness ex ->
    lb_execution ex ->
    continuously (now no_msgs_to_live_from_dead_nodes) ex.
Proof.
  intros. unfold continuously.
  unfold no_msgs_to_live_from_dead_nodes, no_msgs_to_live_from.
  remember (occ_gst (hd ex)) as gst.
  remember (fun occ h dst => ~ In dst (failed_nodes gst) ->
                          In h (failed_nodes gst) ->
                          channel (occ_gst occ) h dst = []) as R.
  remember (fun occ =>
              ForallPairs (R occ) (nodes gst)) as PP.
  remember (fun ex => lb_execution ex /\
                   nodes (occ_gst (hd ex)) = nodes gst /\
                   failed_nodes (occ_gst (hd ex)) = failed_nodes gst) as JJ.
  assert (forall s x, JJ (Cons x s) -> JJ s) as JJ_invar.
  {
    subst.
    intros.
    intuition; inv_prop lb_execution; auto; simpl in *;
      try solve [erewrite <- labeled_step_dynamic_preserves_failed_nodes; [|eauto]; eauto];
      try solve [erewrite <- labeled_step_dynamic_preserves_nodes; [|eauto]; eauto].
  }
  assert (JJ ex) by (subst; intuition).
  eapply eventually_monotonic with (J := JJ) (P := (always (now PP)));
    eauto.
  - intros.
    eapply always_monotonic_complex with
        (J := JJ) (P := (now PP)); eauto.
    intros. subst. intuition.
    destruct s0. simpl in *.
    intros.
    eapply H6; unfold live_node in *; intuition; repeat find_rewrite;
      eauto using in_failed_in_nodes.
  - subst. clear JJ_invar.
    intuition.
    eapply ForallPairs_continuously_commute; [intuition|].
    unfold ForallPairs. intros.
    apply continuously_imp.
    intros.
    apply continuously_imp.
    intros.
    eapply dead_node_channel_empties_out'; eauto.
  (* measure argument on number of msgs from h with nonincreasing obvious,
     eventual drop due to the fact that any given message in the network is
     eventually delivered *)
Qed.


From Coq Require Import List.
Import List.ListNotations.
Open Scope list_scope.
From Coq Require Import Setoid.
From Coq Require Import Morphisms.
From Coq Require Import NPeano.
From Coq Require Import Omega.
From Coq Require Import Program.Tactics.

From Velus Require Import Common.
From Velus Require Import Environment.
From Velus Require Import Operators.
From Velus Require Import IndexedStreams.
From Velus Require Import CoindStreams.
From Velus Require Import CoindToIndexed IndexedToCoind.

Module Type COINDINDEXED
       (Import Op    : OPERATORS)
       (Import OpAux : OPERATORS_AUX Op)
       (Import CStr  : COINDSTREAMS Op OpAux)
       (Import IStr  : INDEXEDSTREAMS Op OpAux).

  Module Export CIStr := CoindToIndexedFun Op OpAux CStr IStr.
  Module Export ICStr := IndexedToCoindFun Op OpAux IStr CStr.

  Fact tr_stream_eqst {A} : forall (x : Stream A),
      ICStr.tr_stream (tr_Stream x) ≡ x.
  Proof.
    unfold ICStr.tr_stream, ICStr.tr_stream_from, tr_Stream.
    intros x.
    apply ntheq_eqst; intros n.
    rewrite ICStr.init_from_nth, Nat.add_0_r.
    reflexivity.
  Qed.

  Fact tr_history_equiv: forall H,
      Env.Equiv (@EqSt value) (ICStr.tr_history (CIStr.tr_history H)) H.
  Proof.
    intros H.
    unfold CIStr.tr_history, ICStr.tr_history, ICStr.tr_history_from.
    constructor; intros.
    - rewrite Env.Props.P.F.mapi_in_iff, Env.Props.P.F.map_in_iff. reflexivity.
    - unfold Env.MapsTo in H0. rewrite Env.gmapi in H0.
      apply option_map_inv_Some in H0 as [v [Hfind Hinit]]; subst.
      apply ntheq_eqst. intros n.
      rewrite ICStr.init_from_nth, Nat.add_0_r, Env.Props.P.F.map_o, H1; simpl; auto.
  Qed.

  Lemma sem_clock_equiv : forall H b ck bs,
      CStr.sem_clock H b ck bs <->
      IStr.sem_clock (tr_Stream b) (CIStr.tr_history H) ck (tr_Stream bs).
  Proof.
    intros; split.
    - apply CIStr.sem_clock_impl.
    - intro Hsem.
      apply ICStr.sem_clock_impl in Hsem.
      repeat rewrite tr_stream_eqst in Hsem. rewrite tr_history_equiv in Hsem.
      assumption.
  Qed.

End COINDINDEXED.

Module CoindIndexedFun
       (Op      : OPERATORS)
       (OpAux   : OPERATORS_AUX          Op)
       (CStr    : COINDSTREAMS           Op OpAux)
       (IStr    : INDEXEDSTREAMS         Op OpAux)
<: COINDINDEXED Op OpAux CStr IStr.
  Include COINDINDEXED Op OpAux CStr IStr.
End CoindIndexedFun.


Require Export CFGdef CFGTac.

Section cfg.
  Context `{C : redCFG}.

  Notation "p '-a>b' q" := (a_edge p q) (at level 55).
  Notation "p '-a>' q" := (p -a>b q = true) (at level 55).
  Notation "p '-->b' q" := (edge p q) (at level 55).
  Notation "p '-->' q" := (p -->b q = true) (at level 55, right associativity).

  (** * Basic loop facts **)

  Lemma loop_contains_loop_head (qh q : Lab)
    : loop_contains qh q -> loop_head qh.
  Proof.
    intro Q. unfold loop_head, loop_contains in *. destruct Q as [p [_ [Q _]]].
    eexists; eauto.
  Qed.

  Lemma loop_contains_self h : loop_head h -> loop_contains h h.
  Proof.
    intros Hl. unfold loop_contains.
    - unfold loop_head in Hl. destruct Hl.
      eapply loop_head_dom in H as Hdom.
      eapply back_edge_incl in H as Hreach. specialize (a_reachability x) as Hreach'.
      destructH.
      eapply subgraph_path' in Hreach' as Hreach'';eauto using a_edge_incl.
      eapply Hdom in Hreach''. eapply path_from_elem in Hreach''; eauto.
      destructH; eauto.
      eapply path_NoDup' in Hreach''0;eauto.
      destructH. exists x, π0. firstorder;eauto.
      + eapply subgraph_path';eauto using a_edge_incl.
      + eapply NoDup_rev in Hreach''3.
        remember (rev π0) as l.
        destruct l;cbn in *;eauto.
        assert (π0 = rev l ++ [e]).
        { rewrite rev_rev_eq. rewrite rev_rcons. rewrite rev_involutive. eauto. }
        rewrite H1 in Hreach''2. eapply path_back in Hreach''2. subst.
        inversion Hreach''3. subst. assumption.
  Qed.

  (** ** Facts about dominance and loops **)

  Lemma dom_loop h
    : forall q: Lab, loop_contains h q -> Dom edge__P root h q.
  Proof.
    intros q Hq. unfold loop_contains,CPath in *. intros π Hπ.
    destructH.
    eapply nin_tl_iff in Hq3;eauto.
    destruct Hq3.
    - eapply path_app' in Hq2. 2: eapply Hπ.
      eapply loop_head_dom in Hq2. 2:eauto. eapply in_app_or in Hq2.
      destruct Hq2;[contradiction|]. eapply tl_incl;auto.
    - eapply path_contains_front in Hπ. enough (h = q);[subst;eauto|].
      destr_r' π0;cbn in *;subst.
      + inversion Hq2.
      + rewrite rev_rcons in H. cbn in H. inversion H. subst. path_simpl'  Hq2. reflexivity.
  Qed.

  Lemma dom_dom_acyclic r p q
    : Dom edge__P r p q -> Dom a_edge__P r p q.
  Proof.
    intros. unfold Dom in *. intros. apply H. eapply subgraph_path'; eauto using a_edge_incl.
  Qed.

  Instance loop_contains_Antisymmetric : Antisymmetric Lab eq loop_contains.
  Proof.
    unfold Antisymmetric.
    intros.
    specialize (a_reachability x) as Hx.
    specialize (a_reachability y) as Hy.
    destructH. destructH.
    eapply dom_loop in H. eapply dom_loop in H0.
    eapply dom_dom_acyclic in H. eapply dom_dom_acyclic in H0.
    eapply H in Hy as Hy'. eapply H0 in Hx as Hx'.
    eapply path_from_elem in Hy;eauto.
    eapply path_from_elem in Hx;eauto.
    do 2 destructH.
    eapply path_path_acyclic';eauto using a_edge_acyclic.
  Qed.

  Lemma loop_contains_ledge_path
        (p qh : Lab)
        (Hledge : p ↪ qh)
        (q : Lab)
        (π : list Lab)
        (Hpath : Path edge__P q p π)
        (Hnin : qh ∉ tl (rev π))
        (x : Lab)
        (Hin : x ∈ π)
    : loop_contains qh x.
  Proof.
    unfold loop_contains.
    exists p. specialize (@path_from_elem _ edge__P _ q p x) as Hx. exploit Hx. destructH.
    exists ϕ. repeat (split;eauto). contradict Hnin. clear - Hx1 Hnin.
    induction Hx1; cbn in *;[auto|]. rewrite rev_rcons. cbn. eapply IHHx1 in Hnin.
    eapply tl_incl;auto.
  Qed.

  (** ** Transitivity of loop_contains **)

  Lemma loop_contains_trans h h' p
        (Hloop : loop_contains h h')
        (Hloop' : loop_contains h' p)
    : loop_contains h p.
  Proof.
    copy Hloop Hloop_save.
    unfold loop_contains in Hloop,Hloop'.
    decide (h = h');[subst;eauto|].
    destructH' Hloop'. destructH' Hloop.
    exists p1. specialize (path_app Hloop'2 (back_edge_incl Hloop'0) Hloop2) as Hϕ.
    exists (π0 ++ π);split;eauto;split;eauto. intro N.
    cbn in *. rewrite rev_app_distr in N.
    destr_r' π;subst;cbn in *. 1: inversion Hloop'2.
    rewrite rev_rcons in N. cbn in N.
    eapply in_app_or in N. destruct N.
    - eapply loop_contains_ledge_path in Hloop'3. 2,3: eauto.
      + eapply loop_contains_Antisymmetric in Hloop_save. eapply Hloop_save in Hloop'3. contradiction.
      + eapply In_rcons. right. eapply in_rev. auto.
    - destr_r' π0;subst;cbn in *;[contradiction|].
      rewrite rev_rcons in H. destruct H;subst.
      + path_simpl' Hloop2. contradiction.
      + rewrite rev_rcons in Hloop3. cbn in Hloop3. contradiction.
  Qed.

  Lemma loop_reachs_member (h q : Lab)
    : loop_contains h q -> h -a>* q.
  Proof.
    intros Hloop. cbn.
    specialize (a_reachability q) as Hπ. destructH.
    eapply dom_loop in Hloop. eapply dom_dom_acyclic in Hloop.
    eapply Hloop in Hπ as Hin.
    eapply path_from_elem in Hπ;eauto. destructH.
    eexists;eauto.
  Qed.

  Lemma non_entry_head_back_edge p h
        (Hedge : edge__P p h)
        (Hloop : loop_contains h p)
    : p ↪ h.
  Proof.
    decide (p ↪ h);[assumption|exfalso].
    simpl_dec' n.
    destruct n;[contradiction|].
    simpl_dec' H.
    eapply loop_reachs_member in Hloop. destruct Hloop.
    eapply a_edge_acyclic;eauto.
  Qed.
  (*
  Lemma edge_head_same_loop p h h'
        (Hedge : edge p h = true)
        (Hhead : loop_head h)
        (Hloop : loop_contains h' p)
    : loop_contains h' h.
  Proof.
    eapply no_exit_head in Hhead;[contradiction|].
   *)

  Lemma path_prefix_path' p q r π ϕ
    : Path edge__P p q π -> Prefix (r :: ϕ) π -> Path edge__P p r (r :: ϕ).
  Proof.
    eapply path_prefix_path.
    intros. unfold dec. decide (x --> y); firstorder.
  Qed.

  Lemma root_loop_root h
    : loop_contains h root -> h = root.
  Proof.
    intros H.
    eapply dom_loop in H.
    assert (Path edge__P root root [root]) as Hpath;[econstructor|].
    eapply H in Hpath. destruct Hpath;[subst;auto|contradiction].
  Qed.

  Lemma loop_contains_either h1 h2 p
        (Hloo : loop_contains h1 p)
        (Hlop : loop_contains h2 p)
    : loop_contains h1 h2 \/ loop_contains h2 h1.
  Proof.
    specialize (a_reachability p) as Hr. destructH.
    eapply dom_loop in Hloo as Hdom1. eapply dom_dom_acyclic in Hdom1. eapply Hdom1 in Hr as Hr1.
    eapply dom_loop in Hlop as Hdom2. eapply dom_dom_acyclic in Hdom2. eapply Hdom2 in Hr as Hr2.
    eapply path_from_elem in Hr1;eauto.
    eapply path_from_elem in Hr2;eauto.
    do 2 destructH.
    decide (h1 = p);[subst;right;auto|].
    decide (h2 = p);[subst;left ;auto|].
    decide (h1 = h2);[subst;left;eauto using loop_contains_self,loop_contains_loop_head|].
    eapply postfix_order_destruct in Hr4;eauto.
    destruct Hr4.
    - left. unfold loop_contains in *. do 2 destructH.
      exists p1. eapply path_app' in Hloo2 as Happ;eauto. exists (π1 ++ tl ϕ).
      repeat (split;eauto). 2:eauto using subgraph_path',a_edge_incl.
      enough (h1 ∉ tl ϕ).
      + contradict Hloo3. eapply tl_incl in Hloo3. eapply in_rev in Hloo3.
        eapply in_app_or in Hloo3. destruct Hloo3;[|contradiction].
        destr_r' π1;subst;[contradiction|]. rewrite rev_rcons. cbn. rewrite <-in_rev.
        eapply In_rcons in H1. destruct H1;[|auto]. subst x.
        clear - Hloo2 n.
        exfalso. contradict n. revert dependent p1.
        induction l;cbn in *;intros;inversion Hloo2;subst;auto.
        * inversion H3.
        * congruence'.
        * eapply IHl;eauto.
      + destr_r' ϕ0;subst. 1: inversion Hr2.
        destr_r' ϕ;subst. 1: inversion Hr0.
        eapply path_back in Hr2 as Hr2'.
        eapply path_back in Hr0 as Hr0'. subst x x0.
        eapply acyclic_path_NoDup in Hr2. eapply NoDup_rev in Hr2.
        inversion H;subst.
        * eapply rev_rev_eq in H2;repeat rewrite rev_rcons in H2. inversion H2;subst. contradiction.
        * eapply rev_rev_eq in H0;repeat rewrite rev_rcons in H0. inversion H0;subst.
          eapply rev_rev_eq in H4. subst l'.
          intro N. eapply tl_incl in N. eapply postfix_incl in N;[|eauto].
          rewrite rev_rcons in Hr2. inversion Hr2;subst. eapply in_rev in N; contradiction.
    - right. unfold loop_contains in *. do 2 destructH.
      exists p0. eapply path_app' in Hlop2 as Happ;eauto. 2: clear Hr0;eauto using subgraph_path',a_edge_incl.
      exists (π0 ++ tl ϕ0).
      repeat (split;eauto).
      enough (h2 ∉ tl ϕ0).
      + contradict Hlop3. eapply tl_incl in Hlop3. eapply in_rev in Hlop3.
        eapply in_app_or in Hlop3. destruct Hlop3;[|contradiction].
        destr_r' π0;subst. 1: inversion Hlop2. rewrite rev_rcons. cbn. rewrite <-in_rev.
        eapply In_rcons in H1. destruct H1;[|auto]. subst x.
        clear - Hlop2 n0.
        exfalso. contradict n0. revert dependent p0.
        induction l;cbn in *;intros;inversion Hlop2;subst;auto.
        * inversion H3.
        * congruence'.
        * eapply IHl;eauto.
      + destr_r' ϕ0;subst. 1:inversion Hr2.
        destr_r' ϕ;subst. 1: inversion Hr0.
        eapply path_back in Hr2 as Hr2'.
        eapply path_back in Hr0 as Hr0'. subst x x0.
        eapply acyclic_path_NoDup in Hr0. eapply NoDup_rev in Hr0.
        inversion H;subst.
        * eapply rev_rev_eq in H2;repeat rewrite rev_rcons in H2. inversion H2;subst. contradiction.
        * eapply rev_rev_eq in H0;repeat rewrite rev_rcons in H0. inversion H0;subst.
          eapply rev_rev_eq in H4. subst l'.
          intro N. eapply tl_incl in N. eapply postfix_incl in N;[|eauto].
          rewrite rev_rcons in Hr0. inversion Hr0;subst. eapply in_rev in N; contradiction.
  Qed.

  Lemma dom_path p q
    : Dom edge__P root p q -> p -->* q.
  Proof.
    intros Hdom.
    specialize reachability as [π Hπ]. specialize (Hdom π Hπ).
    eapply path_from_elem in Hπ; eauto using Lab_dec. firstorder.
  Qed.

  Lemma back_edge_no_a_edge p q
    : p ↪ q -> ~ a_edge__P p q.
  Proof.
    intros Hbedge Haedge.
    specialize (a_reachability p) as Hreach.
    destructH.
    eapply loop_head_dom in Hbedge.
    eapply dom_dom_acyclic in Hbedge.
    specialize (Hbedge _ Hreach).
    eapply PathCons in Haedge;eauto.
    eapply acyclic_path_NoDup in Haedge.
    inversion Haedge. subst.
    contradiction.
  Qed.

  Lemma loop_contains_not_dom h q
    : loop_contains h q -> h <> q -> exists p, p ↪ h /\ ~ Dom edge__P q h p.
  Proof.
    intros Hloop Hneq. unfold loop_contains in Hloop. destructH.
    unfold Dom; eexists; firstorder; eauto.
    - apply back_edge_incl;eauto.
    - eapply back_edge_no_a_edge. auto.
    - eapply nin_tl_iff in Hloop3;eauto. destruct Hloop3.
      + eauto.
      + contradict Hneq. destr_r' π;subst. 1:inversion Hloop2.
        rewrite rev_rcons in H. cbn in *. inversion H. subst. path_simpl' Hloop2. reflexivity.
  Qed.

  Lemma not_and_iff (A B : Prop) : decidable A -> (~ (A /\ B) <-> ~ A \/ ~ B).
  Proof.
    firstorder.
  Qed.

  Lemma in_tl_in {A : Type} (a : A) (l : list A) : a ∈ tl l -> a ∈ l.
  Proof.
    destruct l; cbn in *; eauto.
  Qed.

  (* FIXME: move *)
  Lemma hd_rev_tl_rev_cons (A : Type) (l : list A) (a : A)
    : hd a (rev (tl (rev (a :: l)))) = a.
  Proof.
    clear.
    rewrite rev_cons. destr_r' l;subst;cbn;auto.
    rewrite rev_rcons. cbn.  rewrite rev_rcons. cbn. auto.
  Qed.

  (** * Path and Dominance facts **)

  Lemma app_tl_switch (A : Type) (a b : A) (π ϕ : list A)
        (Heq : hd a (rev π) = hd b ϕ)
        (Hπ : π <> nil)
        (Hϕ : ϕ <> nil)
    : π ++ tl ϕ = (rev (tl (rev π))) ++ ϕ.
  Proof.
    destr_r' π;[congruence|].
    destruct ϕ;[congruence|].
    clear Hπ Hϕ. subst π. rewrite rev_rcons in Heq. cbn in Heq. subst.
    rewrite rev_rcons. cbn. rewrite rev_involutive.
    rewrite <-app_assoc. reflexivity.
  Qed.

  Lemma dom_loop_contains h p q
    : loop_contains h q -> ~ loop_contains h p -> Dom edge__P p h q.
  Proof.
    intros Hloop Hnloop π Hπ.
    copy Hloop Hloop'. copy Hnloop Hnloop'.
    unfold loop_contains in Hnloop. do 3 simpl_dec' Hnloop.
    assert (forall x ϕ, x ↪ h -> Path edge__P p x ϕ -> h ∈ tl (rev ϕ)) as Q.
    { clear - Hnloop.
      intros. specialize (Hnloop x ϕ). firstorder.
      decide (h ∈ tl (rev ϕ));[auto|contradiction].
    }
    clear Hnloop.
    unfold loop_contains in Hloop. destructH.
    eapply path_app' in Hloop2 as Happ;eauto.
    erewrite app_tl_switch in Happ.
    2: { eapply path_back' in Hloop2. eapply path_front' in Hπ. rewrite <-Hπ. rewrite <-Hloop2. auto. }
    2: intro;subst;inversion Hloop2.
    2: intro;subst;inversion Hπ.
    specialize (Q _ _ Hloop0 Happ).
    destr_r' π;subst;[inversion Hπ|subst].
    rewrite app_assoc in Q. rewrite rev_rcons in Q. cbn in Q.
    eapply in_rev in Q. eapply in_app_or in Q. destruct Q as [Q|Q];[eapply in_rev in Q;contradiction|].
    eapply In_rcons;auto.
    Unshelve. all:auto.
  Qed.

  Lemma loop_contains_path h q π
    : CPath h q π -> loop_contains h q -> NoDup π -> forall p, p ∈ π -> loop_contains h p.
  Proof.
    intros Hπ Hin Hnd p Hp.
    decide (p = h) as [Hph|Hph].
    - rewrite Hph. eapply loop_contains_self. eapply loop_contains_loop_head; eauto.
    - destruct (loop_contains_dec h p) as [N|N]; [eauto|exfalso].
      eapply path_from_elem in Hp; eauto. destructH.
      eapply dom_loop_contains in N; eauto; cycle 1.
      eapply postfix_incl in Hp1 as Hp1'; eauto.
      dependent induction Hp1.
      + eapply Hph. eapply path_back_eq;eauto.
      + clear IHHp1. unfold Dom in N.
        eapply postfix_incl in Hp1. eapply Hp1 in N; eauto.
        unfold CPath in Hπ. path_simpl' Hπ.
        eapply NoDup_nin_rcons in Hnd. contradiction.
  Qed.

  Lemma loop_contains_splinter h1 h2 p π
        (Hloop1 : loop_contains h1 h2)
        (Hloop2 : loop_contains h2 p)
        (Hpath : Path edge__P root p π)
    : h2 ≻* h1 | π.
  Proof.
    eapply dom_loop in Hloop2. eapply Hloop2 in Hpath as Hin.
    eapply path_to_elem in Hin;eauto. destructH.
    eapply splinter_prefix;eauto.
    inversion Hin0;subst h2 a.
    - eapply dom_loop in Hloop1. eapply Hloop1 in Hin0. rewrite <-H1 in Hin0. inversion Hin0;subst;[|contradiction].
      econstructor. econstructor. econstructor. econstructor.
    - cbn in *. econstructor. eapply dom_loop in Hloop1. eapply Hloop1 in Hin0. rewrite <-H3 in Hin0.
      eapply splinter_single. cbn in *; eauto.
  Qed.

  (** * Predecessors **)

  Definition preds `{redCFG Lab edge} p : list Lab
    := filter (decPred_bool (fun q => edge q p)) (elem Lab).

  Lemma preds_in_same_loop h p q
        (Hl : loop_contains h p)
        (Hneq : h <> p)
        (Hedge : q --> p)
    : loop_contains h q.
  Proof.
    unfold loop_contains in Hl.
    destructH.
    specialize (path_rcons (r:=q) Hl2) as Hl2'. exploit Hl2'.
    exists p0, (π ++ [q]). repeat (split;eauto).
    rewrite rev_rcons. cbn. eapply nin_tl_iff in Hl3;auto.
    destruct Hl3 as [Hl3|Hl3];[contradict Hl3;eapply in_rev;auto|].
    destr_r' π;subst;[inversion Hl2|]. rewrite rev_rcons in *. cbn in Hl3. path_simpl' Hl2.
    inversion Hl3. contradiction.
  Qed.

  (** * Facts about acyclic paths and exits **)

  Lemma exit_a_edge h p q
        (Hexit : exit_edge h p q)
    : a_edge p q = true.
  Proof.
    destruct (a_edge p q) eqn:E;[auto|exfalso].
    eapply no_exit_head;eauto.
    unfold exit_edge in Hexit. destructH.
    exists p. unfold back_edge. unfold_edge_op. split; auto.
    unfold a_edge__P,is_true2,is_true.
    intro N. congruence.
  Qed.

  Lemma loop_reachs_exit h p q
        (Hexit : exit_edge h p q)
    : h -a>* q.
  Proof.
    copy Hexit Hexit'.
    destruct Hexit.
    eapply loop_reachs_member in H.
    destruct H.
    exists (q :: x).
    econstructor;eauto.
    eapply exit_a_edge;eauto.
  Qed.

  Lemma acyclic_path_stays_in_loop (h p q : Lab) π
        (Hpath : Path a_edge__P p q π)
        (Hp : loop_contains h p)
        (Hq : loop_contains h q)
    : forall x, x ∈ π -> loop_contains h x.
  Proof.

    enough (h ∉ tl (rev π)) as Hnin.
    - intros.
      eapply subgraph_path' in Hpath;eauto.
      eapply (path_from_elem) in Hpath as Hϕ;eauto. destructH.
      unfold loop_contains in Hq.
      destructH.
      exists p0, (π0 ++ tl ϕ); split_conj; auto.
      + eapply path_app';eauto.
      + destr_r' π;subst. 1: inversion Hpath.
        rename l into π.
        destr_r' π0;subst. 1: inversion Hq2.
        rename l into π0.
        destr_r' ϕ;subst. 1: inversion Hϕ0.
        rename l into ϕ.
        rewrite rev_app_distr.
        rewrite rev_rcons in *.
        cbn in *. rewrite <-in_rev in Hq3,Hnin.
        path_simpl' Hpath. path_simpl' Hq2. path_simpl' Hϕ0.
        destruct ϕ;cbn;[rewrite <-in_rev;auto|].
        rewrite rev_rcons. cbn.
        intro N. eapply in_app_or in N. destruct N as [N|[N|N]].
        * eapply postfix_rcons_rcons in Hϕ1. eapply postfix_incl in Hϕ1.
          eapply Hnin. eapply Hϕ1. right. rewrite in_rev. auto.
        * cbn in Hϕ0. path_simpl' Hϕ0. subst.
          eapply postfix_rcons_rcons in Hϕ1.
          eapply Hnin. eapply postfix_incl;eauto.
        * rewrite <-in_rev in N. contradiction.
    - intro N.
      specialize (a_reachability p) as [ϕ Hϕ].
      eapply dom_loop in Hp.
      eapply dom_dom_acyclic in Hp.
      eapply Hp in Hϕ as Hin.
      eapply path_app' in Hpath as Hpath';eauto.
      eapply acyclic_path_NoDup in Hpath' as Hnd.
      enough (π ++ tl ϕ = rev (tl (rev π)) ++ ϕ).
      + rewrite H in Hnd.
        eapply NoDup_app;eauto.
        rewrite <-in_rev. auto.
      + clear - Hpath Hϕ.
        destr_r' π;subst. 1: inversion Hpath. rewrite rev_rcons. cbn.
        rewrite rev_involutive.
        eapply path_back in Hpath. subst x.
        destruct ϕ;cbn in *.
        * inversion Hϕ; subst.
        * inversion Hϕ; subst;auto. rewrite <-app_assoc. cbn. reflexivity.
          rewrite <-app_cons_assoc. auto.
  Qed.

  Lemma acyclic_parallel_exit_path h p q π
        (Hπ : Path a_edge__P h q π)
        (Hexit : exit_edge h p q)
    : forall x, x ∈ tl π -> loop_contains h x.
  Proof.
    destruct π;cbn in *;[contradiction|].
    assert (e = q) by (inversion Hπ;cbn in *;subst;auto);subst.
    inversion Hπ;subst. 1: intros;contradiction.
    intros.
    eapply acyclic_path_stays_in_loop;eauto.
    - eapply loop_contains_self;unfold exit_edge in Hexit; destructH ;
        eauto using loop_contains_loop_head.
    - eapply exit_pred_loop;eauto.
      eapply a_edge_incl;eauto.
  Qed.

  Lemma loop_contains_ledge qh ql
    : ql ↪ qh -> loop_contains qh ql.
  Proof.
    intros. exists ql, ([ql]). split_conj;[auto|constructor|cbn]. exact (fun x => x).
  Qed.

  Lemma exit_edge_pred_exiting h p q
        (Hexit : exit_edge h p q)
        (p' : Lab)
        (Hedge : edge p' q = true)
    : exit_edge h p' q.
  Proof.
    copy Hexit Hexit'.
    unfold exit_edge; unfold exit_edge in Hexit. destructH.
    split_conj;eauto.
    eapply exit_pred_loop;eauto.
  Qed.

  Lemma root_no_acyclic_pred p
    : a_edge p root <> true.
  Proof.
    specialize (a_reachability p) as [π Hπ].
    intro. eapply a_edge_acyclic;eauto.
  Qed.

  Lemma exit_edge_acyclic h qe e
        (Hexit : exit_edge h qe e)
    : a_edge qe e = true.
  Proof.
    copy Hexit Hexit'.
    unfold exit_edge in Hexit.
    destructH.
    destruct (a_edge qe e) eqn:E;[auto|exfalso].
    eapply no_exit_head;eauto.
    eexists; unfold back_edge; unfold_edge_op.
    split;eauto.
    intro. congruence.
  Qed.

  Lemma exit_edge_unique_diff_head h qe e
        (Hexit : exit_edge h qe e)
        h'
        (Hloop : loop_contains h' h)
        (Hnloop : ~ loop_contains h' e)
    : h' = h.
  Proof.
    specialize (a_reachability e) as [π Hπ].
    inversion Hπ;subst e a.
    - exfalso. subst π.
      eapply exit_edge_acyclic in Hexit. exfalso. eapply root_no_acyclic_pred;eauto.
    - eapply a_edge_incl in H0. eapply exit_pred_loop in H0 as H2;eauto.
      eapply single_exit with (p:=b) (q:=c).
      + split;[|split];eauto.
        eapply loop_contains_trans;eauto.
      + split;[|split];eauto.
        contradict Hnloop. eapply loop_contains_trans;eauto.
  Qed.

  Lemma exit_edge_in_loop  (h1 h2 p2 e2 : Lab)
        (Hexit' : exit_edge h2 p2 e2)
        (Hloop : loop_contains h1 h2)
        (Hneq : h1 <> h2)
    : loop_contains h1 e2.
  Proof.
    decide (loop_contains h1 e2);[auto|].
    copy Hexit' Hexit''.
    unfold exit_edge in Hexit'. destructH.
    assert (exit_edge h1 p2 e2).
    {
      unfold exit_edge. split_conj;cycle 1.
      + eauto.
      + eauto.
      + eauto using loop_contains_trans.
    }
    eapply single_exit in Hexit'';eauto. contradiction.
  Qed.

  Lemma entry_through_header h p q
        (Hnin : ~ loop_contains h p)
        (Hin : loop_contains h q)
        (Hedge : p --> q)
    : q = h.
  Proof.
    eapply dom_loop_contains in Hin as Hin';eauto.
    assert (Path edge__P p q (q :: [p])) as Hpath.
    1: econstructor;eauto;econstructor.
    eapply Hin' in Hpath. destruct Hpath;auto.
    inversion H;[|contradiction]. subst.
    exfalso.
    apply Hnin. eapply loop_contains_self. eauto using loop_contains_loop_head.
  Qed.

  Lemma in_path_ex_prefix_not_in p q π x
        (Hπ : CPath p q π)
        (Hin : x ∈ π)
        : exists ϕ, Prefix (x :: ϕ) π /\ x ∉ ϕ.
  Proof.
    revert dependent q.
    induction π.
    - inv Hin.
    - intros.
      replace a with q in *.
      + decide (x ∈ π).
        * destruct π; [ inv i |].
          destruct (IHπ i e) as [ϕ [Hpre Hnin]].
          -- inv Hπ. enough (b = e).
             ++ subst. eassumption.
             ++ eauto using path_front.
          -- exists ϕ. split; [| eassumption ].
             econstructor. eassumption.
        * inv Hin.
          -- exists π. split; [ econstructor | eassumption ].
          -- contradiction.
      + eauto using path_front.
  Qed.

End cfg.