Require Import Setoid.
Require Import Morphisms.
Require Classical_Prop.

Require Import Tactical.Propositional.
Require Import Tactical.Misc.
From Classes Require Import Classes.

Set Implicit Arguments.
Generalizable All Variables.
(* for compatibility with coq master *)
Set Warnings "-undeclared-scope".

Section TransitionRelations.

  Inductive Return (B T: Type) : Type :=
  | Val (b: B) (t: T)
  | Err.

  Arguments Val {_ _}.
  Arguments Err {_ _}.

  Definition relation A B T := A -> Return B T -> Prop.

  (** Several operations on relations *)
  Definition and_then {A B C} {T1 T2}
             (r1: relation A B T1)
             (r2: T1 -> relation B C T2) :
    relation A C T2 :=
    fun x mz =>
      match mz with
      | Val z o2 => exists o1 y, r1 x (Val y o1) /\ (r2 o1) y (Val z o2)
      | Err => r1 x Err \/ exists o1 y, r1 x (Val y o1) /\ (r2 o1) y Err
      end.

  Notation "p1 ;; p2" := (and_then p1 (fun _ => p2))
                           (at level 55, p2 at next level, right associativity).
  Notation "x <- p1 ; p2" := (and_then p1 (fun x => p2))
                               (at level 54, right associativity).

  Definition pure A T (o0:T) : relation A A T :=
    fun x y => Val x o0 = y.

  Definition identity {A} {T} : relation A A T :=
    fun x y => exists t, Val x t = y.

  Definition any {A B} {T} : relation A B T :=
    fun x y => True.

  Definition none {A B} {T} : relation A B T :=
    fun x y => False.

  Definition reads {A} {T} (f: A -> T) : relation A A T :=
    fun x y => Val x (f x) = y.

  Definition puts {A} (f: A -> A) : relation A A unit :=
    fun x y => y = Val (f x) tt.

  Definition error {A B T} : relation A B T :=
    fun _ r => r = Err.

  Definition fst_lift {A1 A2 B T} (r: relation A1 A2 T) : relation (A1 * B) (A2 * B) T :=
    fun '(a, b) y =>
      match y with
      | Err => r a Err
      | Val (a', b') t => r a (Val a' t) /\ b = b'
      end.

  Definition snd_lift {A1 A2 B T} (r: relation A1 A2 T) : relation (B * A1) (B * A2) T :=
    fun '(b, a) y =>
      match y with
      | Err => r a Err
      | Val (b', a') t => r a (Val a' t) /\ b = b'
      end.

  Definition zoom A C (proj: A -> C) (inj: C -> A -> A) T (r: relation C C T) : relation A A T :=
    fun s y =>
      match y with
      | Err => r (proj s) Err
      | Val s' t => r (proj s) (Val (proj s') t) /\ s' = inj (proj s') s
      end.

  Definition readSome {A T} (f: A -> option T) : relation A A T :=
    fun s r => match f s with
            | Some v => r = Val s v
            | None => r = Err
            end.

  Definition readNone {A T} (f: A -> option T) : relation A A unit :=
    fun s r => match f s with
            | Some _ => r = Err
            | None => r = Val s tt
            end.

  Inductive such_that {A T} (f: A -> T -> Prop) : relation A A T :=
  | such_that_holds : forall s v, f s v -> such_that f s (Val s v).

  Definition predicate A := A -> Prop.
  (* TODO: should failure of a test be error? *)
  Definition test {A} (P: predicate A) : relation A A unit :=
    fun x y => P x /\ Val x tt = y.

  Definition rel_or A B T (r1 r2: relation A B T) : relation A B T :=
    fun x y => r1 x y \/ r2 x y.
  (*
  Definition rel_or A B T (r1 r2: relation A B T) : relation A B T :=
    fun x y =>
      match y with
      | Val b o => (r1 x (Val b o) /\ ~ (r2 x Err)) \/
                     (r2 x (Val b o) /\ ~ (r1 x Err))
      | Err => r1 x Err \/ r2 x Err
      end.
   *)

  Infix "+" := rel_or.

  Inductive seq_star A `(r: relation A A T) : relation A A T :=
  | seq_star_refl : forall x o,
      seq_star r x (Val x o)
  | seq_star_one_more_valid : forall x y z o1,
      r x (Val y o1) ->
      seq_star r y z ->
      seq_star r x z
  | seq_star_one_more_err : forall x,
      r x Err ->
      seq_star r x Err
  .

  (* at-least-once iteration *)
  Inductive seq_plus A `(r: relation A A T) : relation A A T :=
  | seq_plus_once : forall x y,
      r x y ->
      seq_plus r x y
  | seq_plus_one_more_valid : forall x y z o1,
      r x (Val y o1) ->
      seq_plus r y z ->
      seq_plus r x z.

  Inductive bind_star A `(r: T -> relation A A T) : T -> relation A A T :=
  | bind_star_pure : forall (o:T) x,
      bind_star r o x (Val x o)
  | bind_star_one_more_valid : forall (o1:T) x y z o2,
      r o1 x (Val y o2) ->
      bind_star r o2 y z ->
      bind_star r o1 x z
  | bind_star_one_more_err : forall (o1:T) x,
      r o1 x Err ->
      bind_star r o1 x Err
  .

  Inductive bind_star_r A `(r: T -> relation A A T) : T -> relation A A T :=
  | bind_star_r_pure : forall (o:T) x,
      bind_star_r r o x (Val x o)
                  (*
  | bind_star_r_err_refl : forall (o1:T) x,
      r o1 x Err ->
      bind_star_r r o1 x Err
                   *)
  | bind_star_r_one_more_valid : forall (o1:T) x y z o2,
      bind_star_r r o1 x (Val y o2) ->
      r o2 y z ->
      bind_star_r r o1 x z
  | bind_star_r_one_more_err : forall (o1 o2:T) x y,
      bind_star_r r o1 x (Val y o2) ->
      r o2 y Err ->
      bind_star_r r o1 x Err
  .

  (** Notions of equivalence and implication *)

  Definition rimpl {A B} {T} (r1 r2: relation A B T) :=
    forall x y, r1 x y -> r2 x Err \/ r2 x y.

  Global Instance rimpl_preorder A B T : PreOrder (rimpl (A:=A) (B:=B) (T:=T)).
  split.
  - intros x y.  firstorder.
  - intros x y z H1 H2 ? ? ?.
    destruct (H1 x0 y0); intuition.
    destruct (H2 x0 Err); intuition.
  Qed.

  Definition requiv {A B} {T} (r1 r2: relation A B T) :=
    rimpl r1 r2 /\ rimpl r2 r1.

  Global Instance requiv_equivalence A B T : Equivalence (requiv (A:=A) (B:=B) (T:=T)).
  Proof.
    split.
    - intros ?; split; reflexivity.
    - intros ?? (?&?); split; eauto.
    - intros ??? (?&?) (?&?); split.
      * etransitivity; eauto.
      * etransitivity; eauto.
  Qed.

  Infix "--->" := rimpl (at level 60, no associativity).
  Infix "<--->" := requiv (at level 60, no associativity).

  Global Instance rimpl_requiv_sub A B T : subrelation (requiv (A:=A) (B:=B) (T:=T)) rimpl :=
    ltac:(firstorder).

  Global Instance rimpl_proper_basics_flip A B T (r: relation A B T) :
    Proper
      (Basics.flip rimpl ==> Basics.flip Basics.impl) (rimpl r).
  Proof.
    unfold Basics.flip, Basics.impl.
    intros ?? ??. etransitivity; eauto.
  Qed.

  Lemma rimpl_elim A B T (r1 r2: relation A B T) a b:
    r1 a b ->
    r1 ---> r2 ->
    r2 a Err \/ r2 a b.
  Proof. firstorder. Qed.

  Lemma requiv_no_err_elim A B T (r1 r2: relation A B T) a b:
    r1 a b ->
    r1 <---> r2 ->
    ~ (r1 a Err) ->
    r2 a b.
  Proof.
    intros Hr1 (Hlr&Hrl) Hno_err. eapply Hlr in Hr1.
    destruct Hr1 as [Herr|?]; eauto.
    apply Hrl in Herr. intuition.
  Qed.

  Lemma requiv_no_err_elim' A B T (r1 r2: relation A B T) a b:
    r1 a b ->
    r1 <---> r2 ->
    ~ (r2 a Err) ->
    r2 a b.
  Proof.
    intros Hr1 (Hlr&Hrl) Hno_err. eapply Hlr in Hr1.
    destruct Hr1 as [Herr|?]; eauto. intuition.
  Qed.

  Lemma requiv_err_elim A B T (r1 r2: relation A B T) a:
    r1 a Err ->
    r1 <---> r2 ->
    r2 a Err.
  Proof.
    intros Hr1 (Hlr&Hrl). eapply Hlr in Hr1; intuition.
  Qed.

  Theorem rimpl_to_requiv A B T (r1 r2: relation A B T) :
    r1 ---> r2 ->
    r2 ---> r1 ->
    r1 <---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem requiv_to_rimpl1 A B T (r1 r2: relation A B T) :
    r1 <---> r2 ->
    r1 ---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem requiv_to_rimpl2 A B T (r1 r2: relation A B T) :
    r1 <---> r2 ->
    r2 ---> r1.
  Proof.
    firstorder.
  Qed.

  Theorem requiv_to_rimpls A B T (r1 r2: relation A B T) :
    r1 <---> r2 ->
    r1 ---> r2 /\ r2 ---> r1.
  Proof.
    firstorder.
  Qed.

  Hint Immediate rimpl_to_requiv requiv_to_rimpl1 requiv_to_rimpl2 : core.

  (* we define an ordering over relations ---> in a natural way for relations,
  but the definition is equivalent to starting with equivalence [<--->] and
  defining [r1 <= r2 := r1 + r2 <---> r2] *)
  Theorem rimpl_or A B T (r1 r2: relation A B T) :
    r1 ---> r2 ->
    r1 + r2 <---> r2.
  Proof.
    firstorder.
  Qed.

  Theorem rel_or_to_rimpl A B T (r1 r2: relation A B T) :
    r1 + r2 <---> r2 ->
    r1 ---> r2.
  Proof.
    firstorder.
  Qed.

  (** Various equivalence and implication proofs *)
  Hint Unfold Proper respectful pointwise_relation : t.
  Hint Unfold Basics.flip Basics.impl : t.
  Hint Unfold and_then rel_or pure any identity reads : t.

  Ltac add_hypothesis' pf :=
    let P := type of pf in
    lazymatch P with
    | ?P' \/ ?Q' =>
      lazymatch goal with
      | [ H: P' \/ Q' |- _ ] => fail "already known"
      | [ H: Q' \/ P' |- _ ] => fail "already known"
      | [ H: P' |- _ ] => fail "already known"
      | [ H: Q' |- _ ] => fail "already known"
      | _ => pose proof pf
      end
    | ?P' =>
      lazymatch goal with
      | [ H: P' |- _ ] => fail "already known"
      | _ => pose proof pf
      end
    end.

  Ltac t :=
    autounfold with t;
    repeat match goal with
           | |- _ <---> _ => split
           | |- _ ---> _ => unfold "--->"
                                   (*
           | [ H: ?r <---> _ |- _ ] => add_hypothesis (proj1 H)
           | [ H: _ <---> ?r |- _ ] => add_hypothesis (proj2 H)
           | [ H: ?r ---> _ |- _] =>
             match type of r with
             | relation ?A ?B ?T =>
               match goal with
               | [ x: A, y: Return B T |- _ ] => add_hypothesis' (H x y); add_hypothesis' (H x Err)
               | [ x: A, y: B, o: T |- _ ] => add_hypothesis' (H x (Val y o));
                                              add_hypothesis' (H x Err)
               end
             end
                                    *)
           | [ H: ?r <---> _,
                  H': ?r ?x ?y |- _ ] =>
             add_hypothesis (proj1 H x y H')
           | [ H: _ <---> ?r,
                  H': ?r ?x ?y |- _ ] =>
             add_hypothesis (proj2 H x y H')
           | [ H: ?r ---> _,
                  H': ?r ?x ?y |- _ ] =>
             add_hypothesis (H x y H')
           | [ u: unit |- _ ] => destruct u
           | [ |- exists (_:unit), _ ] => exists tt
           | _ => progress propositional
           | _ => solve [ eauto 10 ]
           | [ H: _ \/ _  |- _ ] => destruct H
           | [ H : none _ _ |- _] => destruct H
           | [ H : Val _ _ = Val _ _ |- _] => inversion H; subst; clear H
           | [ H : Val _ _  = Err |- _] => inversion H
           | [ H : Err = Val _ _ |- _] => inversion H
        end.

  Ltac destruct_return :=
    match goal with
    | [ y : Return _ _  |- _ ] => destruct y
    end.

  (* first some respectful/congruence rules *)
  Global Instance or_respects_equiv A B T :
    Proper (requiv ==> requiv ==> requiv) (rel_or (A:=A) (B:=B) (T:=T)).
  Proof. t. Qed.

  Global Instance or_respects_impl A B T :
    Proper (rimpl ==> rimpl ==> rimpl) (rel_or (A:=A) (B:=B) (T:=T)).
  Proof. t. Qed.

  Theorem and_then_monotonic A B C T1 T2
          (r1 r1': relation A B T1) (r2 r2': T1 -> relation B C T2) :
    r1 ---> r1' ->
    (forall x, r2 x ---> r2' x) ->
    and_then r1 r2 ---> and_then r1' r2'.
  Proof.
    t. destruct_return.
    - destruct H1 as (o1&y&?&?). edestruct (H0 o1); t.
    - destruct H1 as [|(o1&y&?&?)]. t.
      edestruct (H0 o1); t.
  Qed.

  Global Instance and_then_respectful A B C T1 T2 :
    Proper (rimpl ==> pointwise_relation _ rimpl ==> rimpl) (and_then (A:=A) (B:=B) (C:=C) (T1:=T1) (T2:=T2)).
  Proof.
    unfold Proper, "==>"; intros.
    apply and_then_monotonic; auto.
  Qed.

  Lemma and_then_err_cancel A B C T1 T2 a
        (r1: relation A B T1)
        (r2 r2': T1 -> relation B C T2) :
    and_then r1 r2 a Err ->
    (forall x b, r2 x b Err -> r2' x b Err) ->
    and_then r1 r2' a Err.
  Proof.
    intros Hand_then1 Himpl.
    destruct Hand_then1; t.
  Qed.

  Theorem and_then_equiv_cong A B C T1 T2
          (r1 r1': relation A B T1)
          (r2 r2': T1 -> relation B C T2) :
    r1 <---> r1' ->
    (forall x, r2 x <---> r2' x) ->
    and_then r1 r2 <---> and_then r1' r2'.
  Proof.
    intros. split; apply and_then_monotonic; eauto.
  Qed.

  Theorem and_then_cong_l A B C T1 T2
          (r1 r1': relation A B T1)
          (r2: T1 -> relation B C T2) :
    r1 <---> r1' ->
    and_then r1 r2 <---> and_then r1' r2.
  Proof.
    intros. split; apply and_then_monotonic; eauto; intros; reflexivity.
  Qed.

  Theorem and_then_cong_r A B C T1 T2
          (r1: relation A B T1)
          (r2 r2': T1 -> relation B C T2) :
    (forall x, r2 x <---> r2' x) ->
    and_then r1 r2 <---> and_then r1 r2'.
  Proof.
    intros. split; apply and_then_monotonic; eauto; intros; reflexivity.
  Qed.

  Theorem bind_identity1 A B T1 T2 (r: relation A B T2) :
    (_ <- identity (T:=T1); r) ---> r.
  Proof.
    t. destruct_return; t; intuition congruence.
  Qed.

  Theorem bind_identity A B T1 T2 (r: relation A B T2) (_:Default T1) :
    (_ <- identity (T:=T1); r) <---> r.
  Proof.
    unshelve (t; destruct_return; t; intuition congruence); eauto.
  Qed.

  Theorem reads_identity A T (f: A -> T) :
    reads f ---> identity.
  Proof.
    t.
  Qed.

  Global Instance and_then_respectful_equiv A B C T1 T2 :
    Proper (requiv ==> pointwise_relation _ requiv ==> requiv) (and_then (A:=A) (B:=B) (C:=C) (T1:=T1) (T2:=T2)).
  Proof.
    unfold Proper, "==>"; intros.
    apply and_then_equiv_cong; auto.
  Qed.

  Hint Constructors seq_star : core.

  Global Instance seq_star_respectful A T :
    Proper (rimpl ==> rimpl) (seq_star (A:=A) (T:=T)).
  Proof.
    t. (induction H0; intuition eauto); t.
  Qed.

  Global Instance seq_star_equiv_respectful A T :
    Proper (requiv ==> requiv) (seq_star (A:=A) (T:=T)).
  Proof.
    t.
    eapply seq_star_respectful; eauto.
    eapply seq_star_respectful; eauto.
  Qed.

  Hint Constructors bind_star : core.

  Global Instance bind_star_respectful A T :
    Proper (pointwise_relation _ rimpl ==> eq ==> rimpl) (bind_star (A:=A) (T:=T)).
  Proof.
    t.
    induction H0; (eauto; specialize (H o1); intuition eauto); t.
  Qed.

  Global Instance bind_star_equiv_respectful A T :
    Proper (pointwise_relation _ requiv ==> eq ==> requiv) (bind_star (A:=A) (T:=T)).
  Proof.
    t.
    - induction H0; eauto;
      specialize (H o1);
      (apply requiv_to_rimpls in H; propositional; intuition eauto); t.
    - induction H0; eauto;
      specialize (H o1);
      (apply requiv_to_rimpls in H; propositional; intuition eauto); t.
  Qed.

  Theorem and_then_monotonic_r A B C T1 T2
          (r1 r2: relation A B T1) (rx: T1 -> relation B C T2) :
    r1 ---> r2 ->
    and_then r1 rx ---> and_then r2 rx.
  Proof.
    intros.
    rewrite H; reflexivity.
  Qed.

  Theorem rel_or_symmetric A B T (r1 r2: relation A B T) :
    r1 + r2 <---> r2 + r1.
  Proof.
    t.
  Qed.

  Theorem rel_or_assoc A B T (r1 r2 r3: relation A B T) :
    r1 + (r2 + r3) <---> r1 + r2 + r3.
  Proof.
    t.
  Qed.

  Theorem rel_or_idem A B T (r: relation A B T) :
    r + r <---> r.
  Proof.
    t.
  Qed.

  Theorem rel_or_monotonic A B T (r1 r2: relation A B T) r :
    r1 ---> r2 ->
    r1 + r ---> r2 + r.
  Proof.
    t.
  Qed.

  Theorem rel_or_introl A B T (r1 r2: relation A B T) :
    r1 ---> r1 + r2.
  Proof.
    t.
  Qed.

  Theorem rel_or_intror A B T (r1 r2: relation A B T) :
    r2 ---> r1 + r2.
  Proof.
    t.
  Qed.

  Theorem rel_or_elim A B T (r1 r2: relation A B T) r :
    r1 ---> r ->
    r2 ---> r ->
    r1 + r2 ---> r.
  Proof.
    t.
  Qed.

  Theorem rel_or_elim_rx A B T (r1 r2: relation A B T)
          C T' (rx: T -> relation B C T') r :
    and_then r1 rx ---> r ->
    and_then r2 rx ---> r ->
    and_then (r1 + r2) rx ---> r.
  Proof.
    t. destruct_return; t.
  Qed.

  Theorem bind_left_id A B T1 T2 (v:T1) (r: T1 -> relation A B T2) :
    and_then (pure v) r <---> r v.
  Proof.
    t; destruct_return; t; intuition congruence.
  Qed.

  Theorem bind_right_id A B T (r: relation A B T) :
    and_then r (@pure B T) <---> r.
  Proof.
    t; destruct_return; t; intuition congruence.
  Qed.

  (* pure tt is also the right identity for relations at output type T *)
  Theorem bind_right_id_unit A B (r: relation A B unit) :
    and_then r (fun _ => pure tt) <---> r.
  Proof.
    t; destruct_return; t; intuition congruence.
  Qed.

  Theorem bind_assoc
          A B C D
          T1 T2 T3
          (r1: relation A B T1)
          (r2: T1 -> relation B C T2)
          (r3: T2 -> relation C D T3) :
    and_then (and_then r1 r2) r3 <--->
             and_then r1 (fun v => and_then (r2 v) r3).
  Proof.
    repeat (t; destruct_return; t).
  Qed.

  Theorem to_any A B T (r: relation A B T) :
    r ---> any.
  Proof.
    t.
  Qed.

  Theorem identity_to_any A :
    pure tt ---> any (A:=A).
  Proof.
    t.
  Qed.

  Theorem any_idem A B C T1 T2 :
    any (B:=B) (T:=T1);; any --->
        any (A:=A) (B:=C) (T:=T2).
  Proof.
    t.
  Qed.

  Theorem from_none A B T (r: relation A B T):
    none ---> r.
  Proof.
    t.
  Qed.

  Theorem none_idem A B C T1 T2:
    none (B:=B) (T:=T1);; none --->
        none (A:=A) (B:=C) (T:=T2).
  Proof.
    t. destruct_return; t.
  Qed.

  Theorem none_absorb_l A B C T1 T2 p:
    x <- none (B:=B) (T:=T1); p x --->
        none (A:=A) (B:=C) (T:=T2).
  Proof.
    t. destruct_return; t.
  Qed.

  Theorem none_absorb_l_equiv A B C T1 T2 p:
    x <- none (B:=B) (T:=T1); p x <--->
        none (A:=A) (B:=C) (T:=T2).
  Proof.
    t. destruct_return; t.
  Qed.

  (* This is not true anymore, because p can error *)
  (*
  Theorem none_absorb_r A B C T1 T2 (p: relation A B T1):
    p;; none ---> none (A:=A) (B:=C) (T:=T2).
  Proof.
    t. destruct_return; t.
  Qed.
   *)

  (*
  Theorem none_absorb_r_equiv A B C T1 T2 (p: relation A B T1):
    p;; none <---> none (A:=A) (B:=C) (T:=T2).
  Proof.
    t. destruct_return; t.
  Qed.
   *)

  Theorem none_plus_r A B T1 (p: relation A B T1):
    (p + none) <---> p.
  Proof.
    t.
  Qed.

  Theorem none_plus_l A B T1 (p: relation A B T1):
    (none + p) <---> p.
  Proof.
    t.
  Qed.

  Theorem seq_star_to_bind_star : forall A (r: relation A A unit),
      seq_star r <---> bind_star (fun _ => r) tt.
  Proof.
    t.
    - induction H; t.
    - induction H; t.
  Qed.

  Lemma bind_star_fun_ext A T (r r': T -> relation A A T) (init: T) :
    (forall x, r x <---> r' x) ->
    bind_star r init <---> bind_star r' init.
  Proof.
    t.
    - induction H0; eauto;
      edestruct (H o1); intuition; t.
    - induction H0; eauto;
      edestruct (H o1); intuition; t.
  Qed.

  Theorem bind_star_unit A (r: unit -> relation A A unit) u :
      bind_star r u <---> seq_star (r tt).
  Proof.
    intros.
    destruct u.
    rewrite seq_star_to_bind_star.
    apply bind_star_fun_ext; intros.
    destruct x; reflexivity.
  Qed.

  Theorem bind_star_expand A T (r: T -> relation A A T) (v:T) :
    pure v + and_then (r v) (bind_star r) <---> bind_star r v.
  Proof.
    t; destruct_return; t;
    induction H; eauto;
    t; destruct_return; t.
  Qed.

  Global Instance rimpl_equiv_proper A B T (r: relation A B T) :
    Proper (requiv ==> Basics.flip Basics.impl) (rimpl r).
  Proof.
    intros ?? (?&?) ?. etransitivity; eauto.
  Qed.

  Global Instance rimpl_equiv_applied_proper A B T :
    Proper (requiv ==> requiv ==> iff) (rimpl (A:=A) (B:=B) (T:=T)).
  Proof.
    intros ?? (?&?) ?? (?&?).
    split; intros; repeat (etransitivity; eauto).
  Qed.

  Definition rimpl_refl A B T (r: relation A B T) : r ---> r := ltac:(reflexivity).
  Definition requiv_refl A B T (r: relation A B T) : r <---> r := ltac:(reflexivity).

  Hint Resolve rimpl_refl requiv_refl : core.

  Theorem bind_dist_r A B C T1 T2 (r1 r2: relation A B T1) (r3: T1 -> relation B C T2) :
    and_then (r1 + r2) r3 <---> (and_then r1 r3) + (and_then r2 r3).
  Proof.
    t; destruct_return; t.
  Qed.

  Theorem bind_dist_l A B C T1 T2 (r1: relation A B T1) (r2 r3: T1 -> relation B C T2) :
    and_then r1 (fun v => r2 v + r3 v) <---> and_then r1 r2 + and_then r1 r3.
  Proof.
    t; destruct_return; t.
  Qed.

  Theorem star_ind A T (r x: relation A A T) :
    identity ---> x ->
    r;; x ---> x ->
    seq_star r ---> x.
  Proof.
    intros H1 H2 a y.
    induction 1.
    - eapply H1. econstructor; eauto.
    - t.
      * left. edestruct (H2 x0 Err); eauto.
        simpl; intuition eauto.
      * eapply H2. destruct z.
        ** econstructor; eauto.
        ** right. intuition eauto.
    - eapply H2; left; eauto.
  Qed.

  Theorem star_expand A T (r: relation A A T) :
    seq_star r <---> identity + (r;; seq_star r).
  Proof.
    apply rimpl_to_requiv.
    - apply star_ind; t; destruct_return; t.
    - t; destruct_return; t.
  Qed.

  Theorem seq_star1 A T (r: relation A A T) :
    r;; seq_star r ---> seq_star r.
  Proof.
    t; destruct_return; t.
  Qed.

  Theorem seq_star_fold A T (r r': relation A A T) :
    r' ---> r ->
    r';; seq_star r ---> seq_star r.
  Proof.
    t; destruct_return; t.
  Qed.

  Theorem seq_star_none A T (r: relation A A T) :
    identity ---> seq_star r.
  Proof.
    t.
  Qed.

  Theorem seq_star_one A T (r: relation A A T) :
    r ---> seq_star r.
  Proof.
    t; destruct_return; t.
  Qed.

  Hint Constructors seq_plus : core.

  Theorem plus_one `(r: relation A A T) :
    r ---> seq_plus r.
  Proof.
    t.
  Qed.

  Theorem plus_expand A T (r: relation A A T) :
    seq_plus r <---> r + (r;; seq_plus r).
  Proof.
    t; destruct_return; t; induction H; eauto; t.
  Qed.

  (*
  Inductive seq_plus_r `(r: relation A A T) : relation A A T :=
  | seq_plus_r_once : forall x y o,
      r x y o ->
      seq_plus_r r x y o
  | seq_plus_r_one_more : forall x y z o1 o2,
      seq_plus_r r x y o1 ->
      r y z o2 ->
      seq_plus_r r x z o2.

  Hint Constructors seq_plus_r.

  Theorem seq_plus_lr `(r: relation A A T) :
    seq_plus r <---> seq_plus_r r.
  Proof.
    t.
    - induction H; eauto.
      clear H0.
      induction IHseq_plus; eauto.
    - induction H; eauto.
      clear H.
      induction IHseq_plus_r; eauto.
  Qed.

  Theorem plus_expand_r A T (r: relation A A T) :
    seq_plus r <---> r + (seq_plus r;; r).
  Proof.
    rewrite seq_plus_lr.
    t.
    induction H; eauto.
  Qed.
   *)

  Global Instance and_then_pointwise A B C T1 T2 (r: relation A B T1) :
    Proper (pointwise_relation _ (Basics.flip rimpl) ==> Basics.flip (rimpl (B:=C) (T:=T2)))
           (and_then r).
  Proof.
    t. destruct_return; t;
    specialize (H o1); t.
  Qed.

  Theorem star_duplicate A T (r: relation A A T) :
    seq_star r <---> seq_star r;; seq_star r.
  Proof.
    t.
    - induction H.
      * unshelve (eauto); eauto.
      * unshelve (destruct_return; t); eauto.
      * do 2 left. eapply seq_star_one_more_err; eauto.
    - destruct_return; t.
      * remember (Val y o1) as z eqn:Heq. revert y o1 H0 Heq. revert H.
        induction 1; intros.
        ** inversion Heq; subst. intuition.
        ** subst. edestruct IHseq_star; eauto.
        ** congruence.
      * remember (Val y o1) as z eqn:Heq. revert y o1 H0 Heq. revert H.
        induction 1; intros.
        ** inversion Heq; subst. intuition.
        ** subst. edestruct IHseq_star; eauto.
        ** congruence.
  Qed.

  Theorem star_one A T (r: relation A A T) :
    r ---> seq_star r.
  Proof.
    t. destruct_return; t.
  Qed.

  Lemma star_monotonic A T (r1 r2: relation A A T) :
    r1 ---> r2 ->
    seq_star r1 ---> seq_star r2.
  Proof.
    intros.
    rewrite H; reflexivity.
  Qed.

  Lemma star_congruent A T (r1 r2: relation A A T) :
    r1 <---> r2 ->
    seq_star r1 <---> seq_star r2.
  Proof.
    intros.
    rewrite H; reflexivity.
  Qed.

  Lemma bind_star_congruent A T (r1 r2: T -> relation A A T) (v:T) :
    (forall v, r1 v <---> r2 v) ->
    bind_star r1 v <---> bind_star r2 v.
  Proof.
    intros.
    apply bind_star_equiv_respectful; auto.
  Qed.

  Theorem star_expand_r A (r: relation A A unit) :
    seq_star r <---> identity + (seq_star r;; r).
  Proof.
    apply rimpl_to_requiv.
    - unshelve (apply star_ind; t;
        destruct_return; t;
      inversion H0; subst; t;
      congruence); exact tt.
    - apply rel_or_elim.
      * t.
      * rewrite star_duplicate at 2.
        apply and_then_monotonic; eauto.
        intros []. apply star_one.
  Qed.

  Ltac cong :=
    let solver := try reflexivity; try solve [ t ] in
    match goal with
    | |- and_then _ _ ---> and_then _ _ =>
      apply and_then_monotonic; intros;
      solver
    | |- seq_star _ ---> seq_star _ =>
      apply star_monotonic;
      solver
    end.

  Theorem bind_unit' B C T (q: unit -> relation B C T) v:
    q v <---> q tt.
  Proof.
    t.
  Qed.

  Theorem bind_unit A B C T (p: relation A B unit) (q: unit -> relation B C T) :
    and_then p q <---> p;; q tt.
  Proof.
    setoid_rewrite <-bind_unit'; reflexivity.
  Qed.

  Theorem denesting A T (r1 r2: relation A A T) (_:Default T):
    seq_star (r1 + r2) <--->
             seq_star r1;; (seq_star (r2;; seq_star r1)).
  Proof.
    apply rimpl_to_requiv.
    - unshelve (apply star_ind; t; destruct_return; t; intuition t); eauto.
    - setoid_rewrite star_duplicate at 4; cong.
      cong.

      apply star_ind; try solve [ t ].
      setoid_rewrite star_duplicate at 3; cong.

      setoid_rewrite star_duplicate at 2; cong.
      * setoid_rewrite <-star_one. apply rel_or_intror.
      * cong.
  Qed.

  Theorem bind_sliding A T1 (p: relation A A T1) (q: T1 -> relation A A unit) :
    seq_star (and_then p q);; p <--->
             v <- p; bind_star (fun v0 => q v0;; p) v.
  Proof.
    apply rimpl_to_requiv.
    - t. destruct_return.
      * destruct H as ([]&y&Hstar&Hy).
        remember (Val y tt) as ret eqn:Heq. gen y Heq.
        induction Hstar; subst; t.
        ** specialize (IHHstar _ ltac:(eauto) ltac:(eauto)); t.
           left. right.
           do 2 eexists; split; eauto.
           eapply bind_star_one_more_err. eauto.
      * t.
        ** set (ret := @Err A unit). replace (@Err A unit) with ret in H at 1; eauto.
           remember ret as ret' eqn:Heq. unfold ret in Heq.
           induction H.
           *** congruence.
           *** t; left; right; do 2 eexists; split; eauto; t.
           *** t.
        ** remember (Val y tt) as ret eqn:Heq. gen y Heq.
        induction H; subst; t.
        *** specialize (IHseq_star _ ltac:(eauto) ltac:(eauto)); t.
           **** left. right.
           do 2 eexists; split; eauto.
           eapply bind_star_one_more_err. eauto.
           **** left. right.
           do 2 eexists; split; eauto.
           eapply bind_star_one_more_err. eauto.
    - t. destruct_return.
      * t.
        gen x.
        unshelve (induction H0; t); try exact tt.
        specialize (IHbind_star _ ltac:(eauto)); t.
      * unshelve t; try exact tt.
        **
        gen x.
        unshelve (induction H0; t); try exact tt.
        unshelve (specialize (IHbind_star _ ltac:(eauto)); t); try exact tt.
  Qed.

  Theorem seq_sliding A T1 (p: relation A A T1) (q: relation A A unit) :
    seq_star (p;; q);; p --->
             p;; seq_star (q;; p).
  Proof.
    - t. destruct_return.
      * destruct H as ([]&y&Hstar&Hy).
        remember (Val y tt) as ret eqn:Heq. gen y Heq.
        induction Hstar; subst; t.
        specialize (IHHstar _ ltac:(eauto) ltac:(eauto)); t.
        left. right.
        do 2 eexists; split; eauto.
        eapply seq_star_one_more_err. eauto.
      * t.
        ** set (ret := @Err A unit). replace (@Err A unit) with ret in H at 1; eauto.
           remember ret as ret' eqn:Heq. unfold ret in Heq.
           induction H.
           *** congruence.
           *** t; left; right; do 2 eexists; split; eauto; t.
           *** t.
        ** remember (Val y tt) as ret eqn:Heq. gen y Heq.
           induction H; subst; t.
           specialize (IHseq_star _ ltac:(eauto) ltac:(eauto)); t.
           *** left. right.
           do 2 eexists; split; eauto.
           eapply seq_star_one_more_err. eauto.
           *** left. right.
           do 2 eexists; split; eauto.
           eapply seq_star_one_more_err. eauto.
  Qed.

  Theorem seq_unit_sliding A (p: relation A A unit) (q: relation A A unit) :
    p;; seq_star (q;; p) --->
     seq_star (p;; q);; p.
  Proof.
    setoid_rewrite seq_star_to_bind_star at 1.
    setoid_rewrite bind_sliding.
    eapply bind_unit.
  Qed.

  Theorem seq_unit_sliding_equiv A (p: relation A A unit) (q: relation A A unit) :
     seq_star (p;; q);; p <--->
              p;; seq_star (q;; p).
  Proof.
    apply rimpl_to_requiv; auto using seq_sliding, seq_unit_sliding.
  Qed.

  Inductive seq_star_r A `(r: relation A A T) : relation A A T :=
  | seq_star_r_refl : forall x o,
      seq_star_r r x (Val x o)
  (* This might seem redundant because of _one_more_err, but it is not if T is uninhabited *)
  | seq_star_r_err_refl : forall x,
      r x Err ->
      seq_star_r r x Err
  | seq_star_r_one_more_valid : forall x y z o1 o2,
      seq_star_r r x (Val y o1) ->
      r y (Val z o2) ->
      seq_star_r r x (Val z o2)
  | seq_star_r_one_more_err : forall x y o1,
      seq_star_r r x (Val y o1) ->
      r y Err ->
      seq_star_r r x Err.

  Hint Constructors seq_star_r : core.

  Lemma seq_star_r_one_more_valid_left {A T} (r: relation A A T) x y z o1 o2:
    r x (Val y o1) ->
    seq_star_r r y (Val z o2) ->
    exists o3, seq_star_r r x (Val z o3).
  Proof.
    intros Hr Hseq. remember (Val z o2) as ret eqn: Heq. revert x z o1 o2 Hr Heq.
    induction Hseq; intros.
    - unshelve t; eauto.
    - unshelve t; eauto.
    - t. edestruct IHHseq; eauto.
    - t.
  Qed.

  Lemma seq_star_trans A `(r: relation A A T) (x y: A) (o: T) z:
    seq_star r x (Val y o) ->
    seq_star r y z ->
    seq_star r x z.
  Proof.
    intros Hstar.
    remember (Val y o) as ret eqn:Heq. revert y o Heq.
    induction Hstar; t.
  Qed.

  Lemma seq_star_rl_valid A `(r: relation A A T) x b o1 o2:
    seq_star_r r x (Val b o1) ->
    seq_star r x (Val b o2).
  Proof.
    intros Hstar.
    remember (Val b o1) as ret eqn:Heq.
    revert b o1 Heq. induction Hstar; t.
    specialize (IHHstar y o1 ltac:(eauto)); t.
    clear Hstar.
    remember (Val y o2) as ret eqn:Heq.
    revert o2 Heq.
    induction IHHstar; t.
  Qed.

  Hint Resolve seq_star_r_one_more_valid_left : core.

  Theorem seq_star_lr A `(r: relation A A T) :
    seq_star r <---> seq_star_r r;; identity.
  Proof.
    t.
    - induction H.
      * unshelve t; eauto.
      * t.
        ** unshelve (induction H1; propositional; eauto; t; destruct_return; t); eauto.
        ** destruct_return; t.
           *** edestruct (@seq_star_r_one_more_valid_left A _ r); eauto; t.
           *** remember Err as ret eqn:Heq.
               gen Heq. unshelve (induction H1; intros; t); eauto.
               left. left.
               edestruct (@seq_star_r_one_more_valid_left A _ r); eauto; t.
      * left. left. econstructor. unshelve t; eauto.
    - destruct_return; t.
      * right. eapply seq_star_rl_valid; eauto.
      * left.
        inversion H; subst.
        ** eapply seq_star_one_more_err; eauto.
        ** unshelve (eapply seq_star_trans; [| eapply seq_star_one_more_err; eauto]); eauto.
           eapply seq_star_rl_valid; eauto.
  Qed.

  Hint Constructors bind_star_r : core.

  Lemma bind_star_r_one_more_valid_left {A T} (r: T -> relation A A T) x y z o1 o2 o3:
    r o1 x (Val y o2) ->
    bind_star_r r o2 y (Val z o3) ->
    bind_star_r r o1 x (Val z o3).
  Proof.
    intros Hr Hseq. remember (Val z o2) as ret eqn: Heq. revert x o1 Hr Heq.
    induction Hseq; intros; unshelve t; eauto.
  Qed.

  Lemma bind_star_trans A `(r: T -> relation A A T) (x y: A) (o1 o2: T) z:
    bind_star r o1 x (Val y o2) ->
    bind_star r o2 y z ->
    bind_star r o1 x z.
  Proof.
    intros Hstar.
    remember (Val y o2) as ret eqn:Heq. revert y o2 Heq.
    induction Hstar; t.
  Qed.

  Lemma bind_star_rl_valid A `(r: T -> relation A A T) x b o1 o2:
    bind_star_r r o1 x (Val b o2) ->
    bind_star r o1 x (Val b o2).
  Proof.
    intros Hstar.
    remember (Val b o2) as ret eqn:Heq.
    revert b o2 Heq. induction Hstar; t.
    specialize (IHHstar y o2 ltac:(eauto)); t.
    clear Hstar.
    remember (Val y o2) as ret eqn:Heq.
    revert o2 Heq H.
    induction IHHstar; t.
  Qed.

  Lemma bind_star_lr_valid A `(r: T -> relation A A T) x b o1 o2:
    bind_star r o1 x (Val b o2) ->
    bind_star_r r o1 x (Val b o2).
  Proof.
    intros Hstar.
    remember (Val b o2) as ret eqn:Heq.
    revert b o2 Heq. induction Hstar; t.
    specialize (IHHstar _ _ ltac:(eauto)); t.
    clear Hstar.
    remember (Val y o2) as ret eqn:Heq.
    subst.
    induction IHHstar; t.
  Qed.

  Hint Resolve bind_star_r_one_more_valid_left : core.

  Theorem bind_star_lr A `(r: T -> relation A A T) (v:T) :
    bind_star r v <---> bind_star_r r v.
  Proof.
    t.
    - induction H.
      * unshelve t; eauto.
      * t.
        ** unshelve (induction H1; propositional; eauto; t; destruct_return; t); eauto.
        ** destruct_return; t; unshelve (induction H1; intros; t); eauto.
      * t.
    - destruct_return; t.
      * right. eapply bind_star_rl_valid; eauto.
      * left.
        inversion H; subst;
        unshelve (eapply bind_star_trans; [| eapply bind_star_one_more_err; eauto]);
        eauto using bind_star_rl_valid.
  Qed.

  Theorem bind_star_expand_r_valid `(r: T -> relation A A T) (v:T) x b o :
    (rel_or (pure v) (and_then (bind_star r v) r) x (Val b o)) <-> bind_star r v x (Val b o).
  Proof.
    split.
    - intros. apply bind_star_rl_valid.
      destruct H; t.
      * inversion H; subst. econstructor.
      * inversion H; subst. t.
        eapply bind_star_r_one_more_valid.
        { eapply bind_star_lr_valid; eauto. }
        { eauto. }
    - intros [?|?|?]%bind_star_lr_valid.
      * left; econstructor.
      * right. destruct_return.
        ** do 2 eexists; split.
           *** eapply bind_star_rl_valid; eauto.
           *** eauto.
        ** right. do 2 eexists; split.
           *** eapply bind_star_rl_valid; eauto.
           *** eauto.
      * right.
        ** right. do 2 eexists; split.
           *** eapply bind_star_rl_valid; eauto.
           *** eauto.
  Qed.

  Theorem bind_star_expand_r `(r: T -> relation A A T) (v:T) :
    pure v + and_then (bind_star r v) r <---> bind_star r v.
  Proof.
    rewrite bind_star_lr.
    t; destruct_return; t;
    induction H; eauto;
    t; destruct_return; t.
  Qed.

  Theorem bind_star_expand_r_err `(r: T -> relation A A T) (v:T) x:
    (rel_or (pure v) (and_then (bind_star r v) r) x Err) <-> bind_star r v x Err.
  Proof.
    split; intros; (eapply requiv_err_elim; [ eassumption |]);
    rewrite bind_star_expand_r; eauto.
  Qed.

  Theorem seq_star_ind_l A B T1 (q x: relation A B T1) T2 (p: relation A A T2) :
    q + and_then p (fun _ => x) ---> x ->
    and_then (seq_star p) (fun _ => q) ---> x.
  Proof.
    t; destruct_return; t.
    * remember (Val y o1) as ret eqn:Heq.
      revert y b o1 Heq H1. induction H0; intros; t.
      edestruct IHseq_star; t.
      edestruct (H x0 Err); t.
    * remember Err as ret eqn:Heq.
      revert Heq. induction H0; t.
    * remember (Val y o1) as ret eqn:Heq.
      revert y o1 Heq H1. induction H0; intros; t.
      edestruct IHseq_star; t.
  Qed.

  Theorem pure_no_err A T (a: A) (v: T): pure v a Err -> False.
  Proof. inversion 1. Qed.

  Theorem bind_with_no_err A B C T S (p: relation A B T) (r: T -> relation B C S) a:
    (forall b t, r t b Err -> False) ->
    and_then p r a Err ->
    p a Err.
  Proof.
    intros Hno_err. inversion 1; auto.
    exfalso; t.
  Qed.

  (* some basic properties of tests *)
  Hint Unfold test : t.

  Theorem test_to_id A (P: predicate A) :
    test P ---> identity.
  Proof.
    t.
  Qed.

  Definition pred_and A (P1 P2: predicate A) : predicate A :=
    fun x => P1 x /\ P2 x.

  Hint Unfold pred_and : t.

  Theorem test_and A (P1 P2: predicate A) :
    test P1;; test P2 <---> test (pred_and P1 P2).
  Proof.
    t; destruct_return; t.
  Qed.

  Theorem test_idem A (P: predicate A) :
    test P;; test P <---> test P.
  Proof.
    t; destruct_return; t.
  Qed.

  Theorem test_identity A :
    identity (A:=A) <---> test (fun _ => True).
  Proof.
    t; destruct_return; t.
  Qed.

  Lemma unit_identity A :
    identity (A:=A) <---> pure tt.
  Proof.
    t; destruct_return; t.
  Qed.

End TransitionRelations.

Module RelationNotations.
  (* Declare Scope relation_scope. *)
  Delimit Scope relation_scope with rel.
  Open Scope relation_scope.
  Notation "r1 ---> r2" := (rimpl r1 r2)
                             (at level 60, no associativity,
                              format "'[hv' r1  '/' ---> '/'  r2 ']'")
                           : relation_scope.
  Notation "r1 <---> r2" := (requiv r1 r2)
                              (at level 60, no associativity,
                               format "'[hv' r1  '/' <---> '/'  r2 ']'")
                            : relation_scope.
  Infix "+" := rel_or : relation_scope.

  Notation "p1 ;; p2" := (and_then p1 (fun _ => p2))
  (at level 100, p2 at level 200, only parsing, right associativity)
  : relation_scope.
  (* TODO: experiment more with printing boxes *)
  Notation "x <- p1 ; p2" := (and_then p1 (fun x => p2))
                              (at level 20, p1 at level 100, p2 at level 200, right associativity,
                               format "'[' x  <-  '[v    ' p1 ']' ; ']'  '/' p2")
                             : relation_scope.
  Notation "'let!' x <- p1 ; p2" := (and_then p1 (fun x => p2))
                              (at level 20, x pattern, p1 at level 100, p2 at level 200, right associativity,
                               format "'[' 'let!'  x  <-  '[v    ' p1 ']' ; ']'  '/' p2")
                             : relation_scope.
  Ltac destruct_return :=
    match goal with
    | [ y : Return _ _  |- _ ] => destruct y
    end.

End RelationNotations.


Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Bedrock.Tactics.
Require Import Bedrock.Reflection.

Lemma skipn_length_gt : forall T (ls : list T) n,
  length ls <= n ->
  skipn n ls = nil.
Proof.
  induction ls; destruct n; simpl; intuition; auto. exfalso; omega.
Qed.

Lemma skipn_length_all : forall T U (F : T -> U) ls ls',
  map F ls = ls' ->
  skipn (length ls) ls' = nil.
Proof.
  intros. eapply skipn_length_gt. rewrite <- H. rewrite map_length. omega.
Qed.

Lemma rw_skipn_app : forall T (ls ls' : list T) n,
  length ls = n ->
  skipn n (ls ++ ls') = ls'.
Proof.
  clear. induction ls; destruct n; simpl in *; intros; auto; congruence.
Qed.
Lemma length_equal_map_rev : forall T U (F : T -> U) ls ls',
  map F ls' = rev ls ->
  length ls = length ls'.
Proof.
  clear. intros. rewrite <- rev_length. rewrite <- H. rewrite map_length. auto.
Qed.
Hint Resolve length_equal_map_rev : list_length.
Lemma eq_proves_gt : forall a b,
  a = b -> a <= b.
Proof.
  clear. intros; omega.
Qed.
Lemma map_length_hint : forall T U (F : T -> U) a b,
  map F a = b -> length b = length a.
Proof.
  clear. intros. subst. rewrite map_length. auto.
Qed.
Hint Resolve eq_proves_gt map_length_hint skipn_length_gt : list_length.

Hint Resolve skipn_length_all : list_length.
Hint Rewrite skipn_length_all using (eauto with list_length) : list_length.

Lemma nth_error_None_length : forall (T : Type) (ls : list T) (n : nat),
  nth_error ls n = None -> length ls <= n.
Proof.
  induction ls; destruct n; simpl; intros; think; try omega. inversion H.
  eapply IHls in H. omega.
Qed.

Lemma map_nth_error_full : forall T U (F : T -> U) ls n,
  nth_error (map F ls) n = match nth_error ls n with
                             | None => None
                             | Some v => Some (F v)
                           end.
Proof.
  induction ls; destruct n; simpl; intros; think; auto.
Qed.

Lemma app_len_2 : forall T (a b c d : list T),
  a ++ b = c ++ d ->
  length b = length d ->
  a = c /\ b = d.
Proof.
  clear. induction a; destruct c; simpl; intuition; subst; auto;
  simpl in *; try rewrite app_length in H0;
    try solve [ try generalize dependent (length d); intros; exfalso; omega ].
  inversion H. subst. f_equal. eapply IHa in H3; eauto. intuition.
  inversion H. eapply IHa in H3; intuition.
Qed.

Lemma not_sure : forall T U (F : T -> U) vars X,
  map F vars = X ->
  map F nil = skipn (length vars) X.
Proof.
  induction vars; intros; simpl in *; intros; auto. destruct X; auto.  eapply IHvars.
  inversion H. auto.
Qed.
Lemma map_skipn_all_map : forall T U (F : T -> U) ls,
  map F nil = skipn (length ls) (map F ls).
Proof.
  clear. induction ls; auto.
Qed.
Lemma map_skipn_all_map_is_nil : forall T U (F : T -> U) ls ls',
  map F ls' = skipn (length ls) (map F ls) ->
  ls' = nil.
Proof.
  clear; intros. rewrite <- map_skipn_all_map in H. destruct ls'; simpl in *; congruence.
Qed.


(* Copyright (c) 2008, Harvard University
 * All rights reserved.
 *
 * Author: Avi Shinnar
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

Require Import Ynot.
Require Import FiniteMap.
Set Implicit Arguments.

(***************************************************************************)
(* The following is an argument to the hash-table functor and provides the *)
(* key comparison, key hash, and initial table size needed to build the    *)
(* hash-table.                                                             *)
(***************************************************************************)
Module Type HASH_ASSOCIATION.
  Variable key_t : Set.
  Variable value_t : key_t -> Set.
  Variable key_eq_dec : forall (k1 k2:key_t), {k1 = k2} + {k1 <> k2}.
  Notation "k1 =! k2" := (key_eq_dec k1 k2) (at level 70, right associativity).
  Variable hash : key_t -> nat.
  Variable table_size : nat.
  Variable table_size_gt_zero : table_size > 0.
End HASH_ASSOCIATION.

Module HashTableModel(A : HASH_ASSOCIATION).
  Import A.
  Module AL := AssocList(A).
  Export AL.
  Require Import Euclid Peano_dec Minus.
  Require Import Array.
  (* We compose the modulo function from the Peano_dec library with the key hash
     * to get something that's guaranteed to be in range. *)
  Program Definition hash(k:A.key_t) : nat := modulo A.table_size A.table_size_gt_zero (A.hash k).

    Ltac simpl_sig := repeat
      match goal with
        | [|- context [(proj1_sig ?x)]] => destruct x; simpl
        | [H:context [(proj1_sig ?x)] |- _] => destruct x; simpl in H
        | [H:exists x, _ |- _] => destruct H
      end; intuition.

    Lemma hash_below(k:A.key_t) : hash k < A.table_size.
    Proof. unfold hash; intros; simpl_sig. Qed.

    (* given a list of key value pairs, return only those where the hash of the key equals i *)
    Fixpoint filter_hash (i:nat) (l:alist_t) {struct l} : alist_t :=
      match l with
      | nil => nil
      | (k,, v)::l' =>
        if eq_nat_dec (hash k) i then
          (k,,v):: (filter_hash i l')
        else
          filter_hash i l'
      end.

    Lemma sub_succ(x y:nat) : S x <= y -> S (y - S x) = y - x.
    Proof. intros ; omega. Qed.

    Hint Rewrite sub_succ using solve[auto] : AssocListModel.
    Hint Rewrite <- minus_n_n : AssocListModel.

    (* TODO: split up simpler into model and hash table parts
     * the model should not need to import Array *)
    Ltac simpler := subst;
      repeat (progress ((repeat
        match goal with
          | [|- context [?n - ?n]] => rewrite <- minus_n_n
          | [|- context [_ + 0]] => rewrite <- plus_n_O
          | [H:context [_ + 0] |- _] => rewrite <- plus_n_O in H
          | [|- context [_ - 0]] => rewrite <- minus_n_O
          | [H:context [_ - 0] |- _] => rewrite <- minus_n_O in H
(*          | [|- context [?x - ?x]] => rewrite <- minus_n_n
          | [|- context [S (A.table_size - S ?x)]] => rewrite sub_succ; [idtac | solve[auto]] *)
          | [H:array_length ?x = _ |- context [array_length ?x]] => rewrite H
          | [ |- context[if eq_nat_dec ?e1 ?e2 then _ else _] ] =>
            destruct (eq_nat_dec e1 e2) ; try congruence ; try solve [assert False; intuition]; try subst
        end); AL.simpler)).
    Ltac t := repeat (progress (simpler; simpl in *; autorewrite with AssocListModel; auto; intuition)).

    (* some facts about filter_hash *)
    Lemma filter_hash_lookup k l : lookup k (filter_hash (hash k) l) = lookup k l.
    Proof. induction l; t. Qed.

    Lemma filter_hash_lookup_none x i l :  lookup x l = None -> lookup x (filter_hash i l) = None.
    Proof. induction l; t. Qed.

    Lemma filter_hash_perm i l l' : Permutation l l' -> Permutation (filter_hash i l) (filter_hash i l').
    Proof. induction 1; t; eauto. Qed.
    Hint Resolve filter_hash_lookup filter_hash_lookup_none.

    Lemma filter_hash_distinct i l : distinct l -> distinct (filter_hash i l).
    Proof. induction l; t. Qed.
    Hint Resolve filter_hash_perm filter_hash_distinct.

    Lemma remove_filter_eq (k:A.key_t)(l:alist_t) :
      remove k (filter_hash (hash k) l) = filter_hash (hash k) (remove k l).
    Proof. induction l; t. Qed.

    Lemma remove_filter_neq (k:A.key_t)(i:nat)(l:alist_t) :
      (hash k <> i) -> filter_hash i (remove k l) = filter_hash i l.
    Proof. induction l ; t. Qed.
    Hint Rewrite filter_hash_lookup remove_filter_eq : AssocListModel.

    Lemma insert_filter_eq k v (l:alist_t) :
      insert v (filter_hash (hash k) l) = (k,,v)::filter_hash (hash k) (remove k l).
    Proof. unfold insert; t. Qed.
    Hint Rewrite insert_filter_eq : AssocListModel.
    Hint Rewrite remove_filter_neq using solve[omega|congruence|t]: AssocListModel.

  End HashTableModel.

(*************************************************************************************)
(* The hash-table implementation is a functor, parameterized by a HASH_ASSOCIATION,  *)
(* and a finite map implementation F over the keys and values from HASH_ASSOCIATION. *)
(* We use F to implement the buckets.                                                *)
(*************************************************************************************)
Module HashTable(HA : HASH_ASSOCIATION)
                (F : FINITE_MAP with Module A := HA) : FINITE_MAP with Module A := HA.

  Open Local Scope hprop_scope.
  Require Export Array.
  Require Import Peano_dec.

  Module HL := HashTableModel(HA).

  Module AT <: FINITE_MAP_AT with Module A:=HA.
    Module A := HA.
    Module AL := F.AL.
    Import A AL HL.
    Definition fmap_t : Set := array. (* of F.fmap_t's *)

    (* The ith bucket of a hash-table is well-formed with respect to the association list
     * l, if it points to an F.fmap_t that represents l filtered by i. *)

    Definition wf_bucket (f:fmap_t) (l:alist_t) (i:nat) : hprop :=
      (Exists r :@ F.AT.fmap_t,
        (p :~~ array_plus f i in p --> r) * F.AT.rep r (filter_hash i l)).

    (* A hash-table represents list l if each of the buckets is well-formed with respect
     * to l.  Note that we also have to keep around the fact that the array_length of the
     * array is equal to HA.table_size so that we can free the array. *)
    Definition rep (f:fmap_t) (l:alist_t) : hprop :=
      [array_length f = HA.table_size] * {@ (wf_bucket f l i) | i <- 0 + HA.table_size}.

  End AT.

  Module T:=FINITE_MAP_T(HA)(AT).

  Module A := HA.
  Module AL := F.AL.
  Import AL AT HL.

  Open Local Scope stsepi_scope.
  Open Local Scope hprop_scope.

  Ltac s := T.unfm_t; intros.

  (* The following is used to initialize an array with empty F.fmap_t's *)
  Definition init_pre(f:array)(n:nat) :=
    {@ p :~~ array_plus f i in (Exists A :@ Set, Exists v :@ A, p --> v) | i <- (HA.table_size - n) + n }.

  Definition init_post (f:array)(n:nat)(_:unit) := {@ wf_bucket f nil_al i | i <- (HA.table_size - n) + n}.
  Definition init_table_spec (f:array)(n:nat) := (n <= HA.table_size) -> STsep (init_pre f n) (init_post f n).

  Definition free_pre (f:array)(l:[alist_t])(n:nat) := l ~~ {@ wf_bucket f l i | i <- (HA.table_size - n) + n}.
  Definition free_post (f:array)(n:nat) (_:unit) := {@ p :~~ array_plus f i in p -->? | i <- (HA.table_size - n) + n}.
  Definition free_spec (f:array)(l:[alist_t])(n:nat) := (n <= HA.table_size) -> STsep (free_pre f l n) (free_post f n).

  (* This should be generalized for all finite maps. *)
  Lemma add_dis (v:F.AT.fmap_t) (l:F.AL.alist_t) P Q :
    (distinct l -> (F.AT.rep v l * P ==> Q)) ->
    (F.AT.rep v l * P ==> Q).
  Proof. intros. apply (add_fact (@F.distinct _ _ ) H). Qed.

  Ltac add_dis :=
    repeat(search_prem ltac:(idtac; (match goal with
                                       [|- F.AT.rep ?v ?l * ?P ==> ?Q] =>
                                       match goal with
                                         | [H:distinct l |- _] => fail 1
                                         | _ => apply add_dis; intros
                                       end
                                     end))).

  Ltac unf := unfold init_pre, init_post, free_pre, free_post, rep, wf_bucket, ptsto_any.
  Ltac t := unf; simpl; simpler; sep fail ltac:(subst; unfold_local; simpler);
    simpler; autorewrite with AssocListModel; sep fail auto.

  Definition init_table: forall (f:array)(n:nat), init_table_spec f n.
  intro.
  refine(
    fix init(n:nat) : init_table_spec f n :=
          IfZero n
          Then fun _ => {{Return tt}}
          Else fun _ => m <- F.new <@> _
                      ; upd_array f (HA.table_size - S n) m
                        <@> (init_pre f n * F.AT.rep m nil_al)
                 ;; {{init n _ <@> wf_bucket f nil_al (HA.table_size - S n)}})
  ; t. Qed.
(*  ; [| | | | t' | | | t' |]; t'. Qed. *)

  (* We allocate an array and then initialize it with empty F.fmap_t's *)
  Definition new : T.new. s.
  refine (  t <- new_array HA.table_size
         ; @init_table t HA.table_size _ <@>  _
         ;; {{Return t}})
  ; t. Qed.

  (* the following runs through the array and calls F.free on each of the buckets. *)
  Definition free_table(f:array)(l:[alist_t]) : forall (n:nat), free_spec f l n.
  refine (fix free_tab(n:nat) : free_spec f l n :=
          match n as n' return free_spec f l n'
          with
          | 0 => fun H => {{Return tt}}
          | S i => fun H => let j := HA.table_size - S i in
                              let p := array_plus f j in
              fm <- sub_array f j
                       (fun fm => l ~~ F.AT.rep fm (filter_hash j l) *
                        iter_sep (wf_bucket f l) (HA.table_size - i) i)
            ; F.free fm (l ~~~ filter_hash j l)
                <@> ((p ~~ p --> fm) * free_pre f l i)
           ;; {{free_tab i _ <@> _}}
          end)
  ; clear free_tab; t.
Defined.

  (* Run through the array, call F.free on all of the maps, and then call array_free *)
  Definition free : T.free. s.
  refine (@free_table x l HA.table_size _
              <@> [array_length x = HA.table_size]
      ;; free_array x)
; t. Defined.

Lemma iter_imp_f(P1 P2:nat->hprop)(len start:nat) Q R :
  (forall i, i >= start -> i < len + start -> P1 i ==> P2 i) ->
  Q ==> R ->
  iter_sep P1 start len * Q ==> iter_sep P2 start len * R.
Proof.
 Hint Resolve iter_imp. intros. apply himp_split; auto.
Qed.

Ltac iter_imp :=
  search_conc
  ltac:(idtac; match goal with
          [|- ?Q1 ==> iter_sep ?P ?s ?len * ?R1] =>
          search_prem
          ltac:(idtac; match goal with
                  [|- iter_sep ?P1 s len * ?Q2 ==> ?R2] => apply iter_imp_f
                end)
        end).

  Lemma perm : T.perm.
  Proof. Hint Resolve F.perm. s; t; iter_imp; t; add_dis; t. Qed.
  Hint Resolve hash_below.

  Lemma himp_trans_frame P Q F1 R : P ==> Q -> Q * F1 ==> R -> P * F1 ==> R.
  Proof. intros. eapply himp_trans. 2: eauto. sep fail auto. Qed.

  Ltac trans_imp :=
  search_prem ltac:(idtac;
    match goal with
      [H:?P ==> ?Q |- ?P * ?F1 ==> ?R] => apply (@himp_trans_frame P Q F1 R H)
    end).

  Lemma iter_sep_inj (len s:nat) P Q  : len > 0 -> {@ Q i * [P] | i <- s + len} ==> {@ Q i | i <- s + len} * [P].
  Proof. induction len; t. assert False; intuition. iter_imp; t. Qed.

  Lemma iter_sep_star_conc : forall (len s:nat) P Q, {@ P i * Q i  | i <- s + len}
    ==> {@ P i | i <- s + len} * {@ Q i | i <- s + len} .
  Proof. induction len; t. apply himp_comm_conc. auto. Qed.

  Lemma iter_sep_star_prem : forall (len s:nat) P Q, {@ P i | i <- s + len} * {@ Q i | i <- s + len}
    ==> {@ P i * Q i  | i <- s + len}.
  Proof. induction len; t. apply himp_comm_prem. auto. Qed.

  Lemma iter_sep_any : forall (len s:nat) P, {@ P i * ??  | i <- s + len} ==> {@ P i | i <- s + len} * ??.
  Proof. intros. apply himp_empty_prem'.
    Hint Resolve himp_any_conc.
  apply (@himp_trans_frame _ _ __ ({@P i | i <- (s) + len} * ??)
    ((iter_sep_star_conc len s P (fun _ => ??)))). sep fail auto.
  Qed.

  Lemma iter_sep_empty : forall (len s:nat), {@ __  | i <- s + len} ==> __.
  Proof. induction len; t. Qed.

  Lemma iter_sep_inj_empty : forall (len s:nat) P, {@ [P i]  | i <- s + len} ==> __.
  Proof. induction len; t. Qed.

  Lemma inj_and_conc P Q R : P ==> [Q] -> P ==> [R] -> P ==> [Q /\ R].
  Proof. firstorder. Qed.

  Lemma distinct_from_parts l :{@ [distinct (filter_hash i l)] | i <- (0) + HA.table_size} ==> [distinct l].
  Proof. intros. induction l. t.
    assert (A0:iter_sep (fun _ : nat => [True]) 0 HA.table_size ==> iter_sep (fun _ : nat => __) 0 HA.table_size).
    iter_imp; t. trans_imp. t. apply iter_sep_empty.
    destruct a. simpl.
    split_index. apply (hash_below x).
    simpler.
    assert (A1:{@[distinct
      (if eq_nat_dec (hash x) i
        then (x,, v) :: filter_hash i l
        else filter_hash i l)] | i <- (0) + hash x} ==>
    {@[distinct
      (filter_hash i l)] | i <- (0) + hash x}). iter_imp; t.
    assert(A2:{@[distinct
      (if eq_nat_dec (hash x) i
        then (x,, v) :: filter_hash i l
        else filter_hash i l)] | i <- (S (hash x)) +
    HA.table_size - hash x - 1} ==>
    {@[distinct
      (filter_hash i l)]  | i <- (S (hash x)) +
    HA.table_size - hash x - 1}). iter_imp; t.
    repeat trans_imp; clear A1 A2.
    apply inj_and_conc. rewrite filter_hash_lookup. sep fail auto.
    apply himp_empty_conc'. apply himp_split; apply iter_sep_inj_empty.
    eapply himp_trans; [idtac|apply IHl].
    apply himp_empty_conc'. eapply sp_index_conc; t.
  Qed.

  Lemma distinct_from_parts_any l :{@ [distinct (filter_hash i l)] * ?? | i <- (0) + HA.table_size} ==> [distinct l] * ??.
  Proof. intros.
    eapply himp_trans.
    apply iter_sep_any. sep fail auto.
    apply distinct_from_parts.
  Qed.

  Lemma distinct : T.distinct.
  Proof. s.
    eapply himp_trans; [| apply distinct_from_parts_any].
    t. iter_imp; t. add_dis. t.
  Qed.

  Definition its := iter_sep.
  Lemma its_re : its = iter_sep. reflexivity. Qed.

   Ltac init_split :=  rewrite <- its_re.

   Ltac split_index'_ := idtac;
     match goal with
       | [ |- its ?P ?s ?len * ?Q ==> ?R ] =>
         eapply (sp_index_hyp P); [solve[auto] |]
       | [ |- ?R ==> its ?P ?s ?len * ?Q] =>
         eapply (sp_index_conc P); [solve[auto] |]
     end.

   Ltac split_index_ := search_prem split_index'_ || search_conc split_index'_.

   Definition lookup : T.lookup. s;
   refine (fm <- sub_array x (hash k)   (* extract the right bucket *)
     (fun fm =>
                l ~~ [array_length x = HA.table_size] *
                F.AT.rep fm (filter_hash (hash k) l) *
                   iter_sep (wf_bucket x l) 0 (hash k) *
                   iter_sep (wf_bucket x l) (S (hash k)) (HA.table_size - (hash k) - 1))
         ; {{F.lookup fm k (l ~~~ (filter_hash (hash k) l))
               <@> (l ~~ [array_length x = HA.table_size] *
                 (let p := array_plus x (hash k) in p ~~ p --> fm) *
                 iter_sep (wf_bucket x l) 0 (hash k) *
                 iter_sep (wf_bucket x l) (S (hash k)) (HA.table_size - (hash k) - 1))}});
   unf; repeat (simpl; init_split; sep fail ltac:(subst; try split_index_; simpler; unfold_local); t).
 Qed.

  Definition insert : T.insert. s;
  refine (fm <- sub_array x (hash k) (* find the right bucket *)
           (fun fm =>
             [array_length x = HA.table_size] *
             (l ~~ F.AT.rep fm (filter_hash (hash k) l) *
                 iter_sep (wf_bucket x l) 0 (hash k) *
                 iter_sep (wf_bucket x l) (S (hash k)) (HA.table_size - (hash k) - 1)))
         (* and use F.insert to insert the key value pair *)
         ; {{F.insert fm v (l ~~~ (filter_hash (hash k) l))
           <@>
             [array_length x = HA.table_size] *
             (let p := array_plus x (hash k) in p ~~ p --> fm) *
             (l ~~ (iter_sep (wf_bucket x l) 0 (hash k) *
                iter_sep (wf_bucket x l) (S (hash k)) (HA.table_size - (hash k) - 1)))
        }});
  unf; repeat (simpl; init_split; sep fail ltac:(subst; try split_index_; simpler; unfold_local); t); unfold its.
  repeat (iter_imp; t).
  Qed.

  Definition remove : T.remove. s;
  refine (fm <- sub_array x (hash k) (* find the right bucket *)
           (fun fm =>
             [array_length x = HA.table_size] *
             (l ~~ F.AT.rep fm (filter_hash (hash k) l) *
                 iter_sep (wf_bucket x l) 0 (hash k) *
                 iter_sep (wf_bucket x l) (S (hash k)) (HA.table_size - (hash k) - 1)))
         (* and use F.insert to insert the key value pair *)
       ; {{F.remove fm k (l ~~~ (filter_hash (hash k) l))
           <@>
             [array_length x = HA.table_size] *
             (let p := array_plus x (hash k) in p ~~ p --> fm) *
             (l ~~ (iter_sep (wf_bucket x l) 0 (hash k) *
                iter_sep (wf_bucket x l) (S (hash k)) (HA.table_size - (hash k) - 1)))}}) ;
  unf; repeat (simpl; init_split; sep fail ltac:(subst; try split_index_; simpler; unfold_local); t); unfold its.
  repeat (iter_imp; t).
  Qed.

End HashTable.


Require Import prosa.classic.util.all.
Require Import prosa.classic.model.arrival.basic.job prosa.classic.model.arrival.basic.task prosa.classic.model.arrival.basic.task_arrival.
Require Import prosa.classic.model.schedule.global.schedulability prosa.classic.model.schedule.global.response_time.
Require Import prosa.classic.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq div fintype bigop path.

Module Workload.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask TaskArrival ResponseTime Schedulability.

  (* Let's define the workload. *)
  Section WorkloadDef.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence ...*)
    Variable arr_seq: arrival_sequence Job.

    (* ...and any schedule of these jobs. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* Let tsk be any task. *)
    Variable tsk: sporadic_task.

    (* First, we define a function that returns the amount of service
       received by this task in a particular processor. *)
    Definition service_of_task (cpu: processor num_cpus)
                               (scheduled_job: option Job) : time :=
      if scheduled_job is Some j' then
        (job_task j' == tsk)
      else 0.

    (* Next, workload is defined as the service received by jobs of
       the task in the interval [t1,t2). *)
    Definition workload (t1 t2: time) :=
      \sum_(t1 <= t < t2)
        \sum_(cpu < num_cpus)
          service_of_task cpu (sched cpu t).

    (* Now, we define workload by summing up the cumulative service
       during [t1,t2) of the scheduled jobs, but only those spawned
       by the task that we care about. *)
    Definition workload_joblist (t1 t2: time) :=
      \sum_(j <- jobs_of_task_scheduled_between job_task sched tsk t1 t2)
        service_during sched j t1 t2.

    (* Next, we show that the two definitions are equivalent. *)
    Lemma workload_eq_workload_joblist :
      forall t1 t2,
      workload t1 t2 = workload_joblist t1 t2.
    Proof.
      intros t1 t2; unfold workload, workload_joblist, service_during.
      rewrite big_filter [\sum_(j <- jobs_scheduled_between _ _ _ | _) _]exchange_big /=.
      apply eq_big_nat; unfold service_at; intros t LEt.
      rewrite [\sum_(i <- jobs_scheduled_between _ _ _ | _) _](eq_bigr (fun i =>
               \sum_(cpu < num_cpus) (sched cpu t == Some i)));
        last by ins; rewrite big_mkcond; apply eq_bigr; ins; rewrite mulnbl.
      rewrite exchange_big /=; apply eq_bigr.
      intros cpu LEcpu; rewrite -big_filter.
      destruct (sched cpu t) as [j|] eqn:SCHED; simpl;
        last by rewrite big_const_seq iter_addn mul0n addn0.
      destruct (job_task j == tsk) eqn:EQtsk;
        try rewrite mul1n; try rewrite mul0n.
      {
        rewrite -> bigD1_seq with (j := j); last by rewrite filter_undup undup_uniq.
        {
          rewrite -> eq_bigr with (F2 := fun i => 0); last first.
          {
            intros i DIFF.
            apply/eqP; rewrite eqb0; apply/eqP; case => SAME; subst.
            by rewrite eq_refl in DIFF.
          }
          by rewrite /= big_const_seq iter_addn mul0n 2!addn0 eq_refl.
        }
        {
          rewrite mem_filter; apply/andP; split; first by ins.
          rewrite mem_undup.
          apply mem_bigcat_nat with (j := t); first by ins.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by rewrite SCHED inE; apply/eqP.
        }
      }
      {
        rewrite big_filter; rewrite -> eq_bigr with (F2 := fun i => 0);
          first by rewrite big_const_seq iter_addn mul0n addn0.
        intros i EQtsk2; destruct (Some j == Some i) eqn:SOME; last by done.
        move: SOME => /eqP SOME; inversion SOME; subst.
        by rewrite EQtsk2 in EQtsk.
      }
    Qed.

  End WorkloadDef.

End Workload.


Require Import Leapfrog.Benchmarks.ProofHeader.
Require Import Leapfrog.Benchmarks.Memory.

Require Import Coq.Arith.PeanoNat.

Require Import Leapfrog.Utils.FunctionalFP.

Notation A := WideSelf.aut.
Notation conf := (P4automaton.configuration (P4A.interp A)).
Notation start_left :=  MemoryWide.start.
Notation start_right := MemoryWide.start.

Definition r_states : {r : Reachability.state_pairs A & Reachability.reachable_states_wit start_left start_right r}.
  econstructor.
  unfold Reachability.reachable_states_wit.
  solve_fp_wit.
Defined.

Lemma init_states_wf:
  Reachability.valid_state_pair (Reachability.build_state_pair A start_left start_right).
Proof.
  vm_compute; Lia.lia.
Qed.

Definition top : Relations.rel conf :=
  fun q1 q2 => List.In (conf_to_state_template q1, conf_to_state_template q2) (projT1 r_states).

Definition top' : Relations.rel (state_template A) :=
  fun q1 q2 => List.In (q1, q2) (projT1 r_states).

Declare ML Module "mirrorsolve".

Lemma prebisim_mpls_unroll:
  forall q1 q2,
    interp_conf_rel' {| cr_st := {|
                        cs_st1 := {|
                          st_state := inl (inl (start_left));
                          st_buf_len := 0;
                        |};
                        cs_st2 := {|
                          st_state := inl (inr (start_right));
                          st_buf_len := 0;
                        |};
                      |};
                      cr_ctx := BCEmp;
                      cr_rel := btrue;
                    |} q1 q2 ->
  pre_bisimulation A
                    (wp (projT1 r_states))
                    top
                    []
                    (mk_init _ _ _ _ A start_left start_right)
                    q1 q2.
Proof.
  intros.

  pose proof (Reachability.reachable_states_wit_conv init_states_wf (projT2 r_states)) as Hr.

  unfold mk_init.
  rewrite Hr.
  clear Hr.

  set (foo := (List.nodup (conf_rel_eq_dec (a:=A)) (mk_partition _ _ _ _ _ _))).
  vm_compute in foo.
  subst foo.

  (* time "build phase" repeat (time "single step" run_bisim' top top' r_states interp_compile_simplify). *)
  time "build phase" repeat (time "single step" run_bisim top top' (projT1 r_states)).
  time "close phase" close_bisim' top'.

Time Admitted.


Require Import SIMT.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat fintype.
From mathcomp Require Import tuple finfun ssrint.

Section SIMT_verification_util.
  Variable num_threads : {n : nat | 0 < n}.
  Definition N := sval num_threads.

  Inductive program_with_inv : Type :=
  | asgn' : forall n, V n -> n.-tuple E -> E -> program_with_inv
  | skip' : program_with_inv
  | sync' : program_with_inv
  | seq' : program_with_inv -> program_with_inv -> program_with_inv
  | P_if' : E -> program_with_inv -> program_with_inv -> program_with_inv
  | P_while' : E -> program_with_inv -> assertion num_threads -> program_with_inv.
  Notation "'WHILE' e 'DO' P 'with' phi" := (P_while' e P phi) (at level 140).
  Notation "s '[[' e ']](' i ')'" := (E_under_state num_threads s e i) (at level 50).
(*
  Fixpoint emb_with_inv (P : program) : program_with_inv :=
    match P with
    | asgn n v es e => asgn' n v es e
    | skip => skip'
    | sync => sync'
    | seq P Q => seq' (emb_with_inv P) (emb_with_inv Q)
    | P_if e P Q => P_if' e (emb_with_inv P) (emb_with_inv Q)
    | P_while'
  Coercion Prg : program >-> program_with_inv.
 *)
  Fixpoint remove_inv (P : program_with_inv) : program :=
    match P with
    | asgn' n v es e => asgn n v es e
    | skip' => skip
    | sync' => sync
    | seq' p p' => SIMT.seq (remove_inv p) (remove_inv p')
    | P_if' e p p' => P_if e (remove_inv p) (remove_inv p')
    | P_while' e p _ => P_while e (remove_inv p)
    end.

  Inductive Hoare_proof' : assertion num_threads -> {ffun (T num_threads) -> int} -> program_with_inv -> assertion num_threads -> Prop :=
  | H_Skip' : forall phi m, Hoare_proof' phi m skip' phi
  | H_Sync' : forall (phi : assertion num_threads) (m : {ffun T _ -> int}), Hoare_proof' (fun s => (all num_threads m \/ none num_threads m) -> phi s) m sync' phi
  | H_Assign' : forall n x es e (m : {ffun T _ -> int}) (phi : assertion num_threads),
      Hoare_proof' (fun s : state num_threads =>
                      forall x', assign num_threads s n x' m x es e ->
                                 phi (update_state num_threads s n x x'))
                   m (asgn' n x es e) phi
  | H_Conseq' : forall (phi phi' psi psi' : assertion _) m P,
                  Hoare_proof' phi m P psi ->
                  (forall s, phi' s -> phi s) ->
                  (forall s, psi s -> psi' s) ->
                  Hoare_proof' phi' m P psi'
  | H_Seq' : forall phi m P psi Q chi,
               Hoare_proof' phi m P psi ->
               Hoare_proof' psi m Q chi ->
               Hoare_proof' phi m (seq' P Q) chi
  | H_If' : forall phi psi chi e (m : {ffun T _ -> int}) P Q,
              (forall z : {ffun T _ -> int}, Hoare_proof' (fun s => (forall i, s[[e]](i) = z i) /\ phi s) [ffun i => e_and [tuple m i;  z i]] P (psi z)) ->
              (forall z : {ffun T _ -> int}, Hoare_proof' (psi z) [ffun i => e_and [tuple m i; e_neg [tuple z i]]] Q chi) ->
              Hoare_proof' phi m (P_if' e P Q) chi
  | H_While' : forall phi (m : {ffun T _ -> int}) e P,
                 (forall z : {ffun T _ -> int}, Hoare_proof' (fun s => (forall i, s[[e]](i) = z i) /\ phi s) [ffun i => e_and [tuple m i; z i]] P phi) ->
                 Hoare_proof' phi m (WHILE e DO P with phi) (fun s => phi s /\ none _ [ffun i : T _ => e_and [tuple m i; s[[e]](i)]]).

  Lemma H_Conseq_pre' : forall (phi psi phi' : assertion num_threads) m p,
                         Hoare_proof' phi' m p psi ->
                         (forall s, phi s -> phi' s) ->
                         Hoare_proof' phi m p psi.
  Proof.
    intros.
    apply (H_Conseq' _ _ _ _ m p H H0 (fun s => id)).
  Qed.

  Lemma H_Conseq_post' : forall (phi psi psi' : assertion num_threads) m p,
                         Hoare_proof' phi m p psi' ->
                         (forall s, psi' s -> psi s) ->
                         Hoare_proof' phi m p psi.
  Proof.
    intros.
    apply (H_Conseq' _ _ _ _ m p H (fun s => id) H0).
  Qed.

  Lemma hoare_proof_remove_inv : forall phi m P psi,
                                   Hoare_proof' phi m P psi ->
                                   Hoare_proof _ phi m (remove_inv P) psi.
  Proof.
    move=> phi m P psi H.
    induction H => //= ; try (econstructor; fail).
    { eapply H_Conseq; eassumption. }
    { eapply H_Seq; eassumption. }
    { eapply H_If; eassumption. }
    { eapply H_While; eassumption. }
  Qed.
End SIMT_verification_util.


From Equations Require Import Equations.
Require Import Coq.Lists.List.
Require Import Coq.Arith.PeanoNat.

Require Export SystemFR.ErasedArrow.

Opaque reducible_values.
Opaque makeFresh.

Lemma reducible_value_zero:
  forall ρ, [ ρ ⊨ zero : T_nat ]v.
Proof.
  repeat step || simp_red.
Qed.

Lemma reducible_zero:
  forall ρ, [ ρ ⊨ zero : T_nat ].
Proof.
  repeat step || simp_red || unfold reduces_to || eexists || constructor.
Qed.

Lemma open_reducible_zero:
  forall Θ Γ,
    [ Θ; Γ ⊨ zero : T_nat ].
Proof.
  unfold open_reducible; steps;
    auto using reducible_zero.
Qed.

Lemma reducible_values_succ:
  forall ρ v,
    [ ρ ⊨ v : T_nat ]v ->
    [ ρ ⊨ succ v : T_nat ]v.
Proof.
  repeat step || simp_red; eauto with is_nat_value.
Qed.

Lemma reducible_succ:
  forall ρ t,
    valid_interpretation ρ ->
    [ ρ ⊨ t : T_nat ]  ->
    [ ρ ⊨ succ t : T_nat ].
Proof.
  unfold reduces_to; steps.
  exists (succ v); repeat step || simp_red; eauto with cbvlemmas;
    eauto with is_nat_value.
Qed.

Lemma reducible_nat_value:
  forall ρ v,
    is_nat_value v ->
    valid_interpretation ρ ->
    [ ρ ⊨ v : T_nat ]v.
Proof.
  induction 1; repeat step;
    eauto using reducible_value_zero;
    eauto using reducible_values_succ.
Qed.

Lemma reducible_nat:
  forall ρ v,
    is_nat_value v ->
    valid_interpretation ρ ->
    [ ρ ⊨ v : T_nat ].
Proof.
  induction 1; repeat step;
    eauto using reducible_zero;
    eauto using reducible_succ.
Qed.

Lemma open_reducible_succ:
  forall Θ Γ t,
    [ Θ; Γ ⊨ t : T_nat ] ->
    [ Θ; Γ ⊨ succ t : T_nat ].
Proof.
  unfold open_reducible in *; steps;
    eauto using reducible_succ.
Qed.

Lemma reducible_match:
  forall ρ tn t0 ts T,
    fv ts = nil ->
    fv t0 = nil ->
    wf t0 0 ->
    wf ts 1 ->
    is_erased_term t0 ->
    is_erased_term ts ->
    valid_interpretation ρ ->
    [ ρ ⊨ tn : T_nat ]  ->
    ([ tn ≡ zero ] -> [ ρ ⊨ t0 : T ] ) ->
     (forall n,
        [ tn ≡ succ n ] ->
        [ ρ ⊨ n : T_nat ]v ->
        [ ρ ⊨ open 0 ts n : T ]) ->
    [ ρ ⊨ tmatch tn t0 ts : T ].
Proof.
  steps.
  unfold reduces_to in H6; steps.
  eapply star_backstep_reducible with (tmatch v t0 ts);
    repeat step || list_utils || simp_red; t_closer;
      eauto with cbvlemmas.

  t_invert_nat_value; steps.

  - (* zero *)
    eapply backstep_reducible; eauto with smallstep;
      repeat step || list_utils || apply_any; eauto with fv;
      try solve [ eapply equivalent_star; steps; t_closer ].

  - (* succ v *)
    apply backstep_reducible with (open 0 ts v0);
      repeat step || list_utils || apply reducible_nat_value ||
      match goal with
      | H: forall n, _ -> _ -> [ _ ⊨ _ : _ ]  |-  _ => apply H
      end;
      eauto 4 with smallstep values;
      auto 2 with fv;
      eauto 2 with wf;
      eauto with erased;
      try solve [ eapply equivalent_star; steps; t_closer ].
Qed.

Lemma open_reducible_match:
  forall Θ tn t0 ts Γ T n p,
    wf ts 1 ->
    wf t0 0 ->
    subset (fv ts) (support Γ) ->
    subset (fv t0) (support Γ) ->
    ~(p ∈ fv tn) ->
    ~(p ∈ fv T) ->
    ~(p ∈ fv_context Γ) ->
    ~(n ∈ fv tn) ->
    ~(n ∈ fv ts) ->
    ~(n ∈ fv T) ->
    ~(n ∈ fv_context Γ) ->
    ~(p = n) ->
    is_erased_term t0 ->
    is_erased_term ts ->
    [ Θ; Γ ⊨ tn : T_nat ] ->
    [ Θ; (p, T_equiv tn zero) :: Γ ⊨ t0 : T ] ->
    [ Θ;
        (p, T_equiv tn (succ (fvar n term_var))) ::
        (n, T_nat) ::
        Γ ⊨
          open 0 ts (fvar n term_var) : T ] ->
    [ Θ; Γ ⊨ tmatch tn t0 ts : T ].
Proof.
  unfold open_reducible; repeat step || t_instantiate_sat3.

  apply reducible_match; repeat step || t_termlist;
    eauto with wf;
    eauto using subset_same with fv;
    eauto with erased.

  - (* zero *)
    unshelve epose proof (H14 ρ ((p, uu) :: lterms) _ _ _);
      repeat step || apply SatCons || simp_red || t_substitutions;
      t_closer.

  - (* successor *)
    unshelve epose proof (H15 ρ ((p, uu) :: (n,n0) :: lterms) _ _ _);
      repeat step || apply SatCons || simp_red || t_substitutions;
      t_closer;
      eauto with twf.
Qed.