Require Import List Bool DFA AutomataTactics.

Import ListNotations.

(* Note this file contains a lot of heavily automated proofs:
   for step-by-step versions, look in NFA_full.v *)

Structure nfa (A B : Type) := {
  nt : A -> B -> list A;
  ns : A;

  nF : A -> bool;
}.

Arguments nt {A} {B}.
Arguments ns {A} {B}.
Arguments nF {A} {B}.

Fixpoint ntStar {A B : Type} (M : nfa A B) (q : A) (str : list B) : list A :=
  match str with
  | []      => [q]
  | x :: xs => flat_map (fun st => ntStar M st xs) (nt M q x)
  end.

Definition naccepted {A B : Type} (M : nfa A B) (str : list B) : bool :=
  existsb (nF M) (ntStar M (ns M) str).

Lemma flat_map_id :
  forall {A : Type} (xs : list A), flat_map (fun x => [x]) xs = xs.
Proof.
autoinduction on xs.
Qed.

Lemma flat_map_app :
  forall {A B : Type} {f : A -> list B} (xs ys : list A),
    flat_map f (xs ++ ys) = flat_map f xs ++ flat_map f ys.
Proof.
autoinduction on xs.
Qed.

Lemma flat_map_comp :
  forall {A B C : Type} {f1 : A -> list B} {f2 : B -> list C} (xs : list A),
    flat_map f2 (flat_map f1 xs) = flat_map (fun x => flat_map f2 (f1 x)) xs.
Proof.
autoinduction xs with (apply flat_map_app).
Qed.

Lemma ntStar_step {A B : Type} (M : nfa A B) :
  forall (str : list B) (x : B) (q : A),
    ntStar M q (str ++ [x]) = flat_map (fun st => nt M st x) (ntStar M q str).
Proof.
autoinduction str with (apply flat_map_id).

rewrite flat_map_comp.
set (q' := nt M q a).
autoinduction q' with (rewrite IHstr).
Qed.

Definition dfa_to_nfa {A B : Type} (M : dfa A B) : nfa A B :=
  Build_nfa A B (fun st x => [t M st x]) (s M) (F M).

Lemma dfa_to_nfa_mirror {A B : Type} (M : dfa A B) :
  forall (str : list B), [tStar M (s M) str] = ntStar (dfa_to_nfa M) (ns (dfa_to_nfa M)) str.
Proof.
auto_rev_ind str with (rewrite tStar_step, ntStar_step).
Qed.

Theorem dfa_to_nfa_correct :
  forall {A B : Type} (M : dfa A B) (str : list B),
    accepted M str = true <-> naccepted (dfa_to_nfa M) str = true.
Proof.
intuition.

unfold accepted in H.
unfold naccepted.
rewrite <- dfa_to_nfa_mirror.
simpl.
now (rewrite H).

unfold accepted.
unfold naccepted in H.
rewrite <- dfa_to_nfa_mirror in H.
simpl in H.
now (rewrite orb_false_r in H).
Qed.

Definition powerset_nfa_trans
  {A B : Type} (M : nfa A B) (possible : list A) (x : B) : list A :=
    flat_map (fun source => nt M source x) possible.

Definition powerset_nfa_f
  {A B : Type} (M : nfa A B) (possible : list A) : bool :=
    existsb (nF M) possible.

Definition powerset_nfa
  {A B : Type} (M : nfa A B) : dfa (list A) B :=
    Build_dfa (list A) B
      (powerset_nfa_trans M)
      [ns M]
      (powerset_nfa_f M).

Lemma powerset_nfa_mirror
  {A B : Type} (M : nfa A B) :
    forall (str : list B),
      tStar (powerset_nfa M) (s (powerset_nfa M)) str = ntStar M (ns M) str.
Proof.
auto_rev_ind str with (rewrite tStar_step, ntStar_step).
Qed.

Theorem powerset_nfa_correct :
  forall {A B : Type} (M : nfa A B) (str : list B),
    accepted (powerset_nfa M) str = true <-> naccepted M str = true.
Proof.
intuition.

unfold accepted in H.
simpl in H.
unfold naccepted.
now (rewrite (powerset_nfa_mirror M) in H).

unfold accepted.
unfold naccepted in H.
simpl.
now (rewrite <- (powerset_nfa_mirror M) in H).
Qed.


Require Import McExamples.Cancel.Monoid.

Module Demo (M : Monoid).
  Import M.

  Local Infix "&" := P (at level 50).
  Local Infix "%is" := R (at level 70).

  Ltac ltac_canceler :=
    let cancel P Q :=
        let rec iter_right Q :=
            match Q with
            | ?L & ?R =>
              (apply plus_assoc_c1 ; iter_right L)
              || (apply plus_assoc_c2 ; iter_right R)
            | _ =>
              apply plus_cancel; [ apply refl | ]
            end
        in
        let rec iter_left P :=
            match P with
            | ?L & ?R =>
              (apply plus_assoc_p1 ; iter_left L)
              || (apply plus_assoc_p2 ; iter_left R)
            | _ =>
              match Q with
              | ?A & ?B =>
                iter_right A
                || (apply plus_comm_c; iter_right B)
              end
            end
        in
        match P with
        | ?A & ?B =>
          iter_left A
          || (apply plus_comm_p; iter_left B)
        end
    in
    repeat match goal with
           | [ |- ?P %is ?Q ] =>
             apply refl || cancel P Q
           end.

  Module Demo.
    Axiom N : nat -> M.M.

    Fixpoint build_plusL n : M.M :=
      match n with
      | 0 => N 0
      | S n' => M.P (N n) (build_plusL n')
      end.

    Fixpoint build_plusR n : M.M :=
      match n with
      | 0 => N 0
      | S n' => M.P (build_plusR n') (N n)
      end.

    Definition goal n := M.R (build_plusL n) (build_plusR n).

    Ltac prep := unfold goal, build_plusL, build_plusR.

    Theorem test1 : goal 10.
      prep.
      Time ltac_canceler.
    Time Qed.
    Print Assumptions test1.
  End Demo.
End Demo.


Require Import Lists.List Lists.ListSet Vector Arith.PeanoNat AbstractRelation OrdType SortedList Omega JMeq Util.

Module MultiSet (O : OrdType.OrdType) <: REL.

  Module S := InsertionSort O.
  Import S.
  Module OV := OrdType.OrdVec O.

  Definition V := O.t.              (* values *)
  Definition T := Vector.t V.       (* tuples *)
  Definition R : nat -> Type := fun n => { l : list (T n) & is_sorted l = true }.

  Definition V_dec := O.eq_dec.
  Definition V_eqb := fun x y => if V_dec x y then true else false.
  Definition T_eqb {n} := fun x y => if OV.veq_dec n x y then true else false.

  (* internal list operations *)
  Definition list_minus {n} : list (T n) -> list (T n) -> list (T n)
    := fun l1 l2 =>
      let l := nodup (OV.veq_dec n) (l1 ++ l2) in
      List.fold_left (fun acc x => acc ++
        repeat x (count_occ (OV.veq_dec _) l1 x - count_occ (OV.veq_dec _) l2 x)) l List.nil.
  Definition list_inter {n} : list (T n) -> list (T n) -> list (T n)
    := fun l1 l2 =>
      let l := nodup (OV.veq_dec n) (l1 ++ l2) in
      List.fold_left (fun acc x => acc ++
        repeat x (min (count_occ (OV.veq_dec _) l1 x) (count_occ (OV.veq_dec _) l2 x))) l List.nil.
  Definition all_pairs {m} {n} : list (T m) -> list (T n) -> list (T m * T n)
    := fun l1 l2 => List.fold_left (fun acc x => acc ++ List.map (fun y => (x,y)) l2) l1 List.nil.
  Definition pair_dec {A} {B} :
    (forall a1 a2 : A, {a1 = a2} + {a1 <> a2}) ->
    (forall b1 b2 : B, {b1 = b2} + {b1 <> b2}) ->
    forall x y : A * B, {x = y} + {x <> y}.
  Proof.
    intros. decide equality.
  Qed.
  Definition list_times {m} {n} : list (T m) -> list (T n) -> list (T (m+n))
    := fun l1 l2 =>
      let l := nodup (pair_dec (OV.veq_dec m) (OV.veq_dec n)) (all_pairs l1 l2) in
      List.fold_left (fun acc x => acc ++
        repeat (Vector.append (fst x) (snd x))
          (count_occ (OV.veq_dec _) l1 (fst x) * count_occ (OV.veq_dec _) l2 (snd x))) l List.nil.
  Definition list_comp {m} {n} : list (T m) -> (T m -> T n) -> list (T n)
    := fun l0 f =>
      let l := nodup (OV.veq_dec _) l0 in
      List.fold_left (fun acc x => acc ++
        repeat (f x) (count_occ (OV.veq_dec _) l0 x)) l List.nil.
  Definition list_rcomp {m} {n} : list (T m) -> (T m -> list (T n)) -> list (T n)
    := fun l f =>
      let l1 := nodup (OV.veq_dec _) l in
      let l2 := nodup (OV.veq_dec _) (List.concat (List.map f l)) in
      List.fold_left
        (fun acc t => acc ++ repeat t
          (list_sum (List.map (fun u => count_occ (OV.veq_dec _) l u * count_occ (OV.veq_dec _) (f u) t) l1)))
        l2 List.nil.

  (* public operations *)
  Definition memb {n} := fun (r : R n) t => count_occ (OV.veq_dec n) (projT1 r) t.
  Definition plus {n} : R n -> R n -> R n
    := fun A B => existT _ (sort (projT1 A ++ projT1 B)) (sort_is_sorted _).
  Definition minus {n} : R n -> R n -> R n
    := fun A B => existT _ (sort (list_minus (projT1 A) (projT1 B))) (sort_is_sorted _).
  Definition inter {n} : R n -> R n -> R n
    := fun A B => existT _ (sort (list_inter (projT1 A) (projT1 B))) (sort_is_sorted _).
  Definition times {m} {n} : R m -> R n -> R (m + n)
    := fun A B => existT _ (sort (list_times (projT1 A) (projT1 B))) (sort_is_sorted _).
  Definition sum {m} {n} : R m -> (T m -> T n) -> R n
    := fun A f => existT _ (sort (list_comp (projT1 A) f)) (sort_is_sorted _).
  Definition rsum {m} {n} : R m -> (T m -> R n) -> R n
    := fun A f => existT _ (sort (list_rcomp (projT1 A) (fun x => projT1 (f x)))) (sort_is_sorted _).
  Definition sel {n} : R n -> (T n -> bool) -> R n
    := fun A p => existT _ (sort (List.filter p (projT1 A))) (sort_is_sorted _).
  Definition flat {n} : R n -> R n := fun A => existT _ (sort (nodup (OV.veq_dec n) (projT1 A))) (sort_is_sorted _).
  Definition supp {n} : R n -> list (T n) := fun A => nodup (OV.veq_dec n) (projT1 A).

  Implicit Arguments times [m n].
  Implicit Arguments sum [m n].
  Implicit Arguments sel [n].
  Implicit Arguments rsum [m n].

  Definition card {n} := fun S => memb (@sum n 0 S (fun _ => Vector.nil _)) (Vector.nil _).

  Definition Rnil {n} : R n := existT _ (sort List.nil) (sort_is_sorted _).
  Definition Rone : R 0 := existT _ (sort (List.cons (Vector.nil _) List.nil)) (sort_is_sorted _).
  (* generalized cartesian product of m relations, each taken with its arity n *)
  Fixpoint prod (Rl : list { n : nat & R n })
    : R (list_sum (List.map (projT1 (P := fun n => R n)) Rl)) :=
  match Rl as r return R (list_sum (List.map (projT1 (P := fun n => R n)) r)) with
  | List.nil => Rone
  | List.cons (existT _ x R) l0 => times R (prod l0)
  end.

  Definition flatnat := fun n => match n with 0 => 0 | _ => 1 end.

  (* it was perhaps a bad idea to put these in the module type *)
  Lemma V_eqb_eq : forall (x y :V), V_eqb x y = true <-> x = y.
  Proof.
    intros. unfold V_eqb. destruct (V_dec x y); intuition. discriminate H.
  Qed.
  Lemma T_dec : forall n, forall (x y : T n), {x = y} + {x <> y}.
  Proof.
    intros. eapply Vector.eq_dec. apply V_eqb_eq.
  Qed.
  Lemma T_eqb_eq : forall n, forall (v w : T n), T_eqb v w = true <-> v = w.
  Proof.
    intros. unfold T_eqb. destruct (OV.veq_dec n v w); intuition. discriminate H.
  Qed.

  (* private proofs *)
  Lemma count_occ_repeat {A} {dec} (x:A) n : count_occ dec (repeat x n) x = n.
  Proof.
    induction n; simpl; intuition. destruct (dec x x); intuition.
  Qed.

  Lemma count_occ_repeat_neq {A} {dec} (x y : A) n : x <> y -> count_occ dec (repeat x n) y = 0.
  Proof.
    intro. induction n; simpl; intuition. destruct (dec x y); intuition.
  Qed.

  Lemma count_occ_app {A} {dec} l1 l2 (x:A) :
    count_occ dec (l1 ++ l2) x = count_occ dec l1 x + count_occ dec l2 x.
  Proof.
    induction l1; intuition.
    simpl. destruct (dec a x); intuition.
  Qed.

  Lemma count_occ_fold {A} {dec} l1 l2 f (l : list A):
    forall acc, NoDup l ->
    (forall x, (0 < count_occ dec l1 x \/ 0 < count_occ dec l2 x) -> count_occ dec l x = 0 -> count_occ dec acc x = f x) ->
    (forall x, (0 < count_occ dec l1 x \/ 0 < count_occ dec l2 x) -> 0 < count_occ dec l x -> count_occ dec acc x = 0) ->
    forall x, (0 < count_occ dec l1 x \/ 0 < count_occ dec l2 x) ->
              count_occ dec (List.fold_left (fun acc' y => acc' ++ repeat y (f y)) l acc) x = f x.
  Proof.
    induction l; intuition.
    + simpl. apply IHl.
      - inversion H; assumption.
      - intros. destruct (dec a x0).
        rewrite e. rewrite count_occ_app. rewrite H1. simpl. rewrite count_occ_repeat. reflexivity.
        exact H2. rewrite e. simpl. destruct (dec x0 x0); intuition.
        rewrite count_occ_app. rewrite H0. rewrite count_occ_repeat_neq. omega. exact f0.
        exact H2. simpl. destruct (dec a x0); intuition.
      - intros. enough (a <> x0).
        rewrite count_occ_app. rewrite H1. rewrite count_occ_repeat_neq. reflexivity. exact H5.
        exact H2. simpl. destruct (dec a x0); intuition.
        inversion H. intro. apply H7. rewrite H9. eapply count_occ_In. exact H4.
      - left. exact H3.
    + simpl. apply IHl.
      - inversion H; assumption.
      - intros. destruct (dec a x0).
        rewrite e. rewrite count_occ_app. rewrite H1. simpl. rewrite count_occ_repeat. reflexivity.
        exact H2. rewrite e. simpl. destruct (dec x0 x0); intuition.
        rewrite count_occ_app. rewrite H0. rewrite count_occ_repeat_neq. omega. exact f0.
        exact H2. simpl. destruct (dec a x0); intuition.
      - intros. enough (a <> x0).
        rewrite count_occ_app. rewrite H1. rewrite count_occ_repeat_neq. reflexivity. exact H5.
        exact H2. simpl. destruct (dec a x0); intuition.
        inversion H. intro. apply H7. rewrite H9. eapply count_occ_In. exact H4.
      - right. exact H3.
  Qed.

  Lemma count_occ_fold' {A} {dec} f (l : list A):
    forall acc,
    forall x, count_occ dec l x = 0 -> count_occ dec acc x = 0 ->
              count_occ dec (List.fold_left (fun acc' y => acc' ++ repeat y (f y)) l acc) x = 0.
  Proof.
    induction l; intuition. simpl.
    apply IHl. simpl in H. destruct (dec a x); intuition.
    rewrite count_occ_app. rewrite H0. rewrite count_occ_repeat_neq. reflexivity.
    simpl in H. destruct (dec a x); intuition.
  Qed.

  Lemma count_occ_nodup {A} {dec} l (x:A) :
    count_occ dec (nodup dec l) x = 1 <-> 0 < count_occ dec l x.
  Proof.
    induction l; intuition.
    + simpl in H. discriminate H.
    + simpl in H1. destruct (in_dec dec a l); intuition.
      simpl. destruct (dec a x); intuition.
      simpl in H1. simpl. destruct (dec a x); intuition.
    + simpl. destruct (in_dec dec a l); intuition.
      apply H0. simpl in H1. destruct (dec a x); intuition.
      rewrite <- e. apply count_occ_In. exact i.
      simpl. simpl in H1. destruct (dec a x); intuition.
      f_equal. apply count_occ_not_In. intro. apply n.
      rewrite e. eapply nodup_In. exact H2.
  Qed.

  Lemma count_occ_nodup_O {A} {dec} l (x:A) : count_occ dec (nodup dec l) x = 0 <-> count_occ dec l x = 0.
  Proof.
    induction l; intuition.
    + simpl in H1. destruct (in_dec dec a l); intuition.
      enough (count_occ dec (nodup dec l) a = 1).
      simpl. destruct (dec a x); intuition. rewrite e in H0. rewrite H0 in H. discriminate H.
      apply NoDup_count_occ'. apply NoDup_nodup. apply nodup_In. exact i.
      simpl in H1. simpl. destruct (dec a x); intuition.
    + simpl. destruct (in_dec dec a l); intuition.
      simpl in H1. destruct (dec a x); intuition.
      simpl. simpl in H1. destruct (dec a x); intuition.
  Qed.

  (* internal properties of list_minus and list_inter *)
  Lemma count_occ_list_minus {n} l1 l2 :
    forall x, count_occ (OV.veq_dec n) (list_minus l1 l2) x
      = count_occ (OV.veq_dec n) l1 x - count_occ (OV.veq_dec n) l2 x.
  Proof.
    intro. unfold list_minus.
    destruct (or_eq_lt_n_O (count_occ (OV.veq_dec n) l1 x)).
    destruct (or_eq_lt_n_O (count_occ (OV.veq_dec n) l2 x)).
    rewrite H, H0. apply count_occ_fold'. apply count_occ_nodup_O.
    rewrite count_occ_app. rewrite H, H0. reflexivity.
    reflexivity.

    eapply (count_occ_fold l1 l2 (fun y => count_occ (OV.veq_dec n) l1 y - count_occ (OV.veq_dec n) l2 y)).
    apply NoDup_nodup. intros.
    pose (H3 := proj1 (count_occ_nodup_O _ _) H2); clearbody H3.
    rewrite count_occ_app in H3. destruct (count_occ (OV.veq_dec n) l1 x0); intuition.
    intros. reflexivity.
    right. exact H0.

    eapply (count_occ_fold l1 l2 (fun y => count_occ (OV.veq_dec n) l1 y - count_occ (OV.veq_dec n) l2 y)).
    apply NoDup_nodup. intros.
    pose (H2 := proj1 (count_occ_nodup_O _ _) H1); clearbody H2.
    rewrite count_occ_app in H2. destruct (count_occ (OV.veq_dec n) l1 x0); intuition.
    intros. reflexivity.
    left. exact H.
  Qed.

  Lemma count_occ_list_inter {n} l1 l2 :
    forall x, count_occ (OV.veq_dec n) (list_inter l1 l2) x
      = min (count_occ (OV.veq_dec n) l1 x) (count_occ (OV.veq_dec n) l2 x).
  Proof.
    intro. unfold list_inter.
    destruct (or_eq_lt_n_O (count_occ (OV.veq_dec n) l1 x)).
    destruct (or_eq_lt_n_O (count_occ (OV.veq_dec n) l2 x)).
    rewrite H, H0. apply count_occ_fold'. apply count_occ_nodup_O.
    rewrite count_occ_app. rewrite H, H0. reflexivity.
    reflexivity.

    eapply (count_occ_fold l1 l2 (fun y => min (count_occ (OV.veq_dec n) l1 y) (count_occ (OV.veq_dec n) l2 y))).
    apply NoDup_nodup. intros.
    pose (H3 := proj1 (count_occ_nodup_O _ _) H2); clearbody H3.
    rewrite count_occ_app in H3. destruct (count_occ (OV.veq_dec n) l1 x0); intuition.
    intros. reflexivity.
    right. exact H0.

    eapply (count_occ_fold l1 l2 (fun y => min (count_occ (OV.veq_dec n) l1 y) (count_occ (OV.veq_dec n) l2 y))).
    apply NoDup_nodup. intros.
    pose (H2 := proj1 (count_occ_nodup_O _ _) H1); clearbody H2.
    rewrite count_occ_app in H2. destruct (count_occ (OV.veq_dec n) l1 x0); intuition.
    intros. reflexivity.
    left. exact H.
  Qed.

  Fixpoint split {A} {m} {n} : Vector.t A (m+n) -> (Vector.t A m * Vector.t A n).
  refine
  (match m as m return Vector.t A (m+n) -> (Vector.t A m * Vector.t A n) with
   | 0 => fun v => (nil _,v)
   | S p => fun v => let h := Vector.hd v in let t := Vector.tl v in
      let (v1,v2) := split _ _ _ t in
      (Vector.cons _ h _ v1,v2)
   end).
  Defined.

  Lemma split_append {A} {m} {n} (l1 : Vector.t A m) (l2 : Vector.t A n) :
    split (append l1 l2) = (l1, l2).
  Proof.
    generalize l2. induction l1; simpl; intuition.
    rewrite IHl1. reflexivity.
  Qed.

  Lemma count_occ_hd {A} {dec} (a:A) l : 0 < count_occ dec (a::l) a.
  Proof.
    simpl. destruct (dec a a); intuition.
  Qed.

  Lemma count_occ_hd_neq {A} {dec} (a b:A) l : a <> b -> count_occ dec (a::l) b = count_occ dec l b.
  Proof.
    simpl. destruct (dec a b); intuition.
  Qed.

  Lemma count_occ_fold_times {m} {n} (l : list (T m*T n)) l1 l2 x1 x2:
    forall acc, NoDup l ->
    (0 < count_occ (OV.veq_dec m) l1 x1 -> 0 < count_occ (OV.veq_dec n) l2 x2 ->
      count_occ (pair_dec (OV.veq_dec _) (OV.veq_dec _)) l (x1,x2) = 0 ->
      count_occ (OV.veq_dec (m+n)) acc (append x1 x2) = count_occ (OV.veq_dec m) l1 x1 * count_occ (OV.veq_dec n) l2 x2) ->
    (0 < count_occ (OV.veq_dec m) l1 x1 -> 0 < count_occ (OV.veq_dec n) l2 x2 ->
      0 < count_occ (pair_dec (OV.veq_dec _) (OV.veq_dec _)) l (x1,x2) ->
      count_occ (OV.veq_dec (m+n)) acc (append x1 x2) = 0) ->
    0 < count_occ (OV.veq_dec m) l1 x1 -> 0 < count_occ (OV.veq_dec n) l2 x2 ->
      count_occ (OV.veq_dec (m+n)) (List.fold_left
        (fun acc' y => acc' ++ repeat (append (fst y) (snd y))
          (count_occ (OV.veq_dec m) l1 (fst y) * count_occ (OV.veq_dec n) l2 (snd y))) l acc)
        (append x1 x2) = count_occ (OV.veq_dec m) l1 x1 * count_occ (OV.veq_dec n) l2 x2.
  Proof.
    induction l; intuition.
    simpl. apply IHl.
    - inversion H; assumption.
    - intros. destruct (pair_dec (OV.veq_dec m) (OV.veq_dec n) (a0,b) (x1,x2)).
      injection e; intros. subst. rewrite count_occ_app. rewrite H4. simpl.
      rewrite count_occ_repeat. reflexivity.
      apply count_occ_hd.
      rewrite count_occ_app. rewrite H1. rewrite count_occ_repeat_neq. omega.
      intro; apply n0. rewrite <- (split_append x1 x2). rewrite <- H7. rewrite split_append. reflexivity.
      rewrite count_occ_hd_neq. exact H6. exact n0.
    - intros. enough ((a0,b) <> (x1,x2)).
      rewrite count_occ_app. rewrite H4. rewrite count_occ_repeat_neq. reflexivity.
      intro; apply H7. rewrite <- (split_append x1 x2). rewrite <- H8. rewrite split_append. reflexivity.
      rewrite count_occ_hd_neq. exact H6. exact H7.
      inversion H. intro. apply H9. injection H11; intros; subst. eapply count_occ_In. exact H6.
    - exact H2.
    - exact H3.
  Qed.

  Lemma count_occ_fold_times' {m} {n} {dec} f (l : list (T m*T n)):
    forall acc,
    forall x1 x2, f x1 x2 = 0 -> count_occ dec acc (append x1 x2) = 0 ->
      count_occ dec (List.fold_left (fun acc' y => acc' ++ repeat (append (fst y) (snd y)) (f (fst y) (snd y))) l acc)
        (append x1 x2) = 0.
  Proof.
    induction l; intuition. simpl.
    apply IHl. exact H.
    rewrite count_occ_app. rewrite H0. simpl.
    destruct (pair_dec (OV.veq_dec m) (OV.veq_dec n) (x1,x2) (a0,b)).
    + injection e. intros. subst. rewrite H. reflexivity.
    + rewrite count_occ_repeat_neq. reflexivity.
      intro. apply n0.
      rewrite <- (split_append x1 x2). rewrite <- H1. rewrite split_append. reflexivity.
  Qed.

  Lemma In_all_pairs {m} {n} (x1 : T m) (x2 : T n) l1 l2 :
    List.In x1 l1 -> List.In x2 l2 -> List.In (x1,x2) (all_pairs l1 l2).
  Proof.
    intros. unfold all_pairs.
    cut (forall acc l2, (List.In (x1,x2) acc \/ (List.In x1 l1 /\ List.In x2 l2)) ->
      List.In (x1, x2) (List.fold_left (fun (acc : list (T m * T n)) (x : T m) =>
      acc ++ List.map (fun y : T n => (x, y)) l2) l1 acc)).
    intro. apply H1. right. split; assumption. clear H H0.
    induction l1; intuition.
    + contradiction (in_nil H).
    + simpl. apply IHl1. left. apply in_or_app. left. exact H0.
    + simpl. destruct H.
      - subst. apply IHl1. left. apply in_or_app. right.
        induction l0. contradiction (in_nil H1).
        destruct H1. subst. left. reflexivity.
        right. apply IHl0. exact H.
      - apply IHl1. right. split; assumption.
  Qed.

  Lemma count_occ_list_times {m} {n} l1 l2 :
    forall x x1 x2, x = Vector.append x1 x2 -> count_occ (OV.veq_dec (m+n)) (list_times l1 l2) x
      = count_occ (OV.veq_dec m) l1 x1 * count_occ (OV.veq_dec n) l2 x2.
  Proof.
    intros. unfold list_times.
    destruct (or_eq_lt_n_O (count_occ (OV.veq_dec m) l1 x1)).
    + rewrite H0. simpl. rewrite H.
      apply (count_occ_fold_times'
        (fun x1 x2 => count_occ (OV.veq_dec m) l1 x1 * count_occ (OV.veq_dec n) l2 x2)).
      rewrite H0. reflexivity.
      reflexivity.
    + destruct (or_eq_lt_n_O (count_occ (OV.veq_dec n) l2 x2)).
      - rewrite H1. simpl. rewrite H. rewrite mult_0_r.
        apply (count_occ_fold_times'
          (fun x1 x2 => count_occ (OV.veq_dec m) l1 x1 * count_occ (OV.veq_dec n) l2 x2)).
        rewrite H1. apply mult_0_r.
        reflexivity.
      - rewrite H. apply count_occ_fold_times.
        * apply NoDup_nodup.
        * intros. enough (~List.In (x1, x2) (nodup (pair_dec (OV.veq_dec m) (OV.veq_dec n)) (all_pairs l1 l2))).
          contradiction H5. apply nodup_In. apply In_all_pairs.
          eapply count_occ_In. exact H0. eapply count_occ_In. exact H1.
          eapply count_occ_not_In. exact H4.
        * intros. reflexivity.
        * exact H0.
        * exact H1.
  Qed.

  Lemma filter_app : forall A (l l' : list A) p,
    List.filter p (l++l') = (List.filter p l)++(List.filter p l').
  Proof.
    intros A l. induction l; intuition; simpl.
    destruct (p a); simpl; auto. rewrite IHl. reflexivity.
  Qed.

(*
  Lemma list_sum_app : forall l1 l2, list_sum (l1 ++ l2) = list_sum l1 + list_sum l2.
  Proof.
    intros. induction l1; simpl; intuition.
 *)

  Lemma count_occ_list_comp {m} {n} l0 (f : T m -> T n) :
    forall t a l2,
    (count_occ (OV.veq_dec n) a t =
     list_sum (List.map (count_occ (OV.veq_dec m) l0) (filter (fun x : T m => T_eqb (f x) t) l2))) ->
    count_occ (OV.veq_dec n)
      (List.fold_left (fun (acc : list (T n)) (x : T m) => acc ++ repeat (f x) (count_occ (OV.veq_dec m) l0 x))
        (nodup (OV.veq_dec m) l0) a) t =
    list_sum (List.map (count_occ (OV.veq_dec m) l0) (filter (fun x => T_eqb (f x) t) l2))
    + list_sum (List.map (count_occ (OV.veq_dec m) l0) (filter (fun x : T m => T_eqb (f x) t) (nodup (OV.veq_dec m) l0))).
  Proof.
    intro. induction (nodup (OV.veq_dec m) l0). simpl.
    + intros. rewrite H. omega.
    + intros. simpl. destruct (T_eqb (f a) t) eqn:Hfat.
      - simpl. rewrite plus_assoc. rewrite (IHl _ (a::l2)).
        * simpl. rewrite Hfat. simpl. omega.
        * rewrite count_occ_app. rewrite H. simpl. rewrite Hfat. simpl.
          rewrite plus_comm. f_equal.
          rewrite (proj1 (T_eqb_eq _ _ _) Hfat).
          rewrite count_occ_repeat. reflexivity.
      - rewrite (IHl _ l2). reflexivity.
        rewrite count_occ_app. rewrite H. rewrite count_occ_repeat_neq. omega.
        intro. rewrite H0 in Hfat. rewrite (proj2 (T_eqb_eq _ _ _) eq_refl) in Hfat. discriminate Hfat.
  Qed.

  Lemma count_occ_list_rcomp {m} {n} l (f : T m -> list (T n)) :
    forall t,
    count_occ (OV.veq_dec n) (list_rcomp l f) t =
    list_sum (List.map
      (fun u => count_occ (OV.veq_dec _) l u * count_occ (OV.veq_dec _) (f u) t)
      (nodup (OV.veq_dec _) l)).
  Proof.
    intro. simpl. unfold list_rcomp.
    destruct (or_eq_lt_n_O (count_occ (OV.veq_dec n) (nodup (OV.veq_dec n) (concat (List.map f l))) t)).
    rewrite list_sum_O. rewrite count_occ_fold'; eauto.
    enough (count_occ (OV.veq_dec _) (List.concat (List.map f l)) t = O). clear H.
    intros.
    enough (List.In x (List.map (fun u => count_occ (OV.veq_dec _) l u * count_occ (OV.veq_dec _) (f u) t) l)).
    clear H. induction l in H0, H1 at 2 |- *.
    simpl in H1. contradiction.
    rewrite List.map_cons, concat_cons, count_occ_app in H0. destruct (plus_is_O _ _ H0); clear H0.
    rewrite List.map_cons in H1. destruct H1.
    rewrite <- H0, H. omega.
    apply IHl0. apply H2.
    apply H0.
    destruct (List.in_map_iff
     (fun u => count_occ (OV.veq_dec _) l u * count_occ (OV.veq_dec _) (f u) t)
     (nodup (OV.veq_dec _) l) x).
    destruct (H1 H); clear H1 H2. destruct H3.
    destruct (List.in_map_iff
     (fun u => count_occ (OV.veq_dec _) l u * count_occ (OV.veq_dec _) (f u) t)
     l x).
    apply H4. rewrite <- H1. exists x0. split; auto.
    destruct (nodup_In (OV.veq_dec _) l x0). auto.
    destruct (@count_occ_nodup_O _ (OV.veq_dec _) (concat (List.map f l)) t). auto.

    rewrite (count_occ_fold (nodup (OV.veq_dec n) (concat (List.map f l))) List.nil); eauto.
    apply NoDup_nodup.
    intros. destruct H0.
    rewrite H1 in H0. intuition.
    simpl in H0. intuition.
  Qed.

  (* public properties *)
  Lemma p_fs : forall n, forall r : R n, forall t, memb r t > 0 -> List.In t (supp r).
  Proof.
    intros n r t. destruct r. unfold memb, supp. simpl. intro.
    apply nodup_In. eapply count_occ_In. exact H.
  Qed.
  Lemma p_fs_r : forall n, forall r : R n, forall t, List.In t (supp r) -> memb r t > 0.
  Proof.
    intros n r t. destruct r. unfold memb, supp. simpl. intro.
    apply count_occ_In. eapply nodup_In. exact H.
  Qed.
  Lemma p_nodup : forall n, forall r : R n, NoDup (supp r).
  Proof.
    intros. destruct r. unfold supp. apply NoDup_nodup.
  Qed.

  Lemma p_plus : forall n, forall r1 r2 : R n, forall t, memb (plus r1 r2) t = memb r1 t + memb r2 t.
  Proof.
    intros. destruct r1. destruct r2. unfold memb. simpl.
    rewrite <- count_occ_sort. apply count_occ_app.
  Qed.
  Lemma p_minus : forall n, forall r1 r2 : R n, forall t, memb (minus r1 r2) t = memb r1 t - memb r2 t.
  Proof.
    intros. destruct r1. destruct r2. unfold memb; simpl.
    rewrite <- count_occ_sort. apply count_occ_list_minus.
  Qed.
  Lemma p_inter : forall n, forall r1 r2 : R n, forall t, memb (inter r1 r2) t = min (memb r1 t) (memb r2 t).
  Proof.
    intros. destruct r1. destruct r2. unfold memb; simpl.
    rewrite <- count_occ_sort. apply count_occ_list_inter.
  Qed.
  Lemma p_times : forall m n, forall r1 : R m, forall r2 : R n, forall t t1 t2,
                    t = Vector.append t1 t2 -> memb (times r1 r2) t = memb r1 t1 * memb r2 t2.
  Proof.
    intros. destruct r1. destruct r2. unfold memb; simpl.
    rewrite <- count_occ_sort. apply count_occ_list_times. exact H.
  Qed.
  Lemma p_sum : forall m n, forall r : R m, forall f : T m -> T n, forall t,
                    memb (sum r f) t = list_sum (List.map (memb r) (filter (fun x => T_eqb (f x) t) (supp r))).
  Proof.
    intros. destruct r. unfold memb, supp; simpl.
    rewrite <- count_occ_sort. clear e. unfold list_comp.
    rewrite (count_occ_list_comp _ _ _ _ List.nil); reflexivity.
  Qed.
  Lemma p_rsum : forall m n, forall r : R m, forall f : T m -> R n, forall t,
                    memb (rsum r f) t = list_sum (List.map (fun t0 => memb r t0 * memb (f t0) t) (supp r)).
  Proof.
    intros. destruct r. unfold memb, supp; simpl.
    rewrite <- count_occ_sort. clear e.
    rewrite count_occ_list_rcomp; reflexivity.
  Qed.

  Lemma p_self : forall n, forall r : R n, forall p t, p t = false -> memb (sel r p) t = 0.
  Proof.
    intros. destruct r. unfold memb; simpl.
    rewrite <- count_occ_sort. clear e. induction x; intuition.
    simpl. destruct (OV.veq_dec _ a t).
    + rewrite e. rewrite H. simpl. exact IHx.
    + destruct (p a). simpl. destruct (S.OV.veq_dec n a t); intuition. exact IHx.
  Qed.
  Lemma p_selt : forall n, forall r : R n, forall p t, p t = true -> memb (sel r p) t = memb r t.
  Proof.
    intros. destruct r. unfold memb; simpl.
    rewrite <- count_occ_sort. clear e. induction x; intuition.
    simpl. destruct (OV.veq_dec _ a t).
    + rewrite e. rewrite H. simpl. destruct (S.OV.veq_dec n t t); intuition.
    + destruct (p a). simpl. destruct (S.OV.veq_dec n a t); intuition. exact IHx.
  Qed.

  Lemma p_flat : forall n, forall r : R n, forall t, memb (flat r) t = flatnat (memb r t).
  Proof.
    intros. destruct r. unfold memb; simpl.
    rewrite <- count_occ_sort. clear e.
    destruct (in_dec (OV.veq_dec n) t x).
    + enough (exists m, count_occ (OV.veq_dec n) x t = S m). destruct H. rewrite H. simpl.
      apply NoDup_count_occ'. apply NoDup_nodup. apply nodup_In. exact i.
      enough (0 < count_occ (OV.veq_dec n) x t). inversion H; intuition; eauto.
      apply count_occ_In. exact i.
    + replace (count_occ (OV.veq_dec n) x t) with 0. simpl.
      apply count_occ_nodup_O. apply count_occ_not_In. exact n0.
      symmetry. apply count_occ_not_In. exact n0.
  Qed.
  Lemma p_nil : forall n (t : T n), memb Rnil t = 0.
  Proof.
    intros. reflexivity.
  Qed.
  Lemma p_one : forall r, memb Rone r = 1.
  Proof.
    intros. apply (case0 (fun x => memb Rone x = 1)).
    unfold memb, Rone. simpl. destruct (OV.veq_dec 0 (nil O.t) (nil O.t)); intuition.
  Qed.

  Lemma p_ext : forall n, forall r s : R n, (forall t, memb r t = memb s t) -> r = s.
  Proof.
    intros. destruct r. destruct s. unfold memb in H. simpl in H.

    assert (x = x0).
    apply ext_eq. apply sorted_is_sorted; assumption. apply sorted_is_sorted; assumption. exact H.

    generalize e; clear e. rewrite H0. intros. f_equal.
    destruct e. apply JMeq_eq. destruct e0. reflexivity.
  Qed.

  Definition Rsingle {n} : T n -> R n :=
    fun t => sum Rone (fun _ => t).
  Lemma p_single : forall n (t : T n), memb (Rsingle t) t = 1.
  Proof.
    intros. unfold Rsingle. rewrite p_sum. replace (T_eqb t t) with true.
    simpl. rewrite p_one. omega.
    rewrite (proj2 (T_eqb_eq _ _ _) eq_refl). reflexivity.
  Qed.
  Lemma p_single_neq : forall n (t1 t2 : T n), t1 <> t2 -> memb (Rsingle t1) t2 = 0.
  Proof.
    intros. unfold Rsingle. rewrite p_sum. replace (T_eqb t1 t2) with false. simpl. reflexivity.
    destruct (T_eqb t1 t2) eqn:e.
    contradiction H. eapply (proj1 (T_eqb_eq _ _ _)). exact e.
    reflexivity.
  Qed.

End MultiSet.


Require Import Helpers.Helpers.
Require Import Proc.
Require Import ProcTheorems.

(** * Specification style: Abstractions with pre- and post-conditions

 In POCS you will often write specifications that abstract away
 the state manipulated by the lower-level code into a higher-level
 representation of the state, which we will call a "spec state".
 This style of specification, for a given procedure, consists of
 two parts: (1) the type of the abstract state, and (2) a description
 of how this abstract state can change as a result of running a procedure.

 To prove that an implementation (code) meets its specification
 (spec), which puts the following obligations on you:

 - You need to define an abstraction relation that connects code
   states and spec states;

 - Whenever the code runs from state [w] to state [w'] and the abstraction
   relation holds between [w] and [state], you must show that there exists
   a spec state [state'] for which the abstraction relation holds between
   [w'] and [state'], and that the specification allows the procedure to
   change the abstract state from [state] to [state'].

 Here's a picture representing these proof obligations:

<<
                     spec semantics
     forall state ===================> exists state'
              ^                                 ^^
         absR |                            absR ||
              V   semantics of code             VV
       forall w  -----------------------> forall w'
>>

 Single lines are what the proof assumes, and double lines are what you
 must show in your proof.

 The rest of this file defines what it means to construct an abstraction
 relation between code states and spec states, what it means to define a
 specification, and how we can structure these proofs.
 *)

(** ** Abstraction relation and composition *)

(** A LayerAbstraction is a record with one field, [abstraction],
  which relates two states: one of type [State1] and another of type [State2].
  Think of [State1] as being the type of code states whereas [State2] is the
  type for specification states.  The abstraction relation links these two
  states together.

  For example, in StatDB lab, the spec state is a list of
  integers and the implementation state is is a pair of variables.  In the
  StatDB lab, the
  [abstraction] function must state what must be true of the relationship between
  the list of integers and the pair of variables.
 *)

Record LayerAbstraction State1 State2 :=
  { abstraction : State1 -> State2 -> Prop; }.

(**
  The above definition of [LayerAbstraction] helps us connect two
  layers, such as the layer of variables and the layer of the StatDB
  specification.

  A particular kind of abstraction is one that connects the bottom-most
  type of state, [world], with some abstract state above the world.
  (Recall that our model of execution is that, at the lowest level,
  procedures (code) always manipulates the "real world", whose state
  is of type [world].)

  We define [Abstraction] to be this particular kind of abstraction:
  it is a relation between [world] states and some other type of states,
  [State].
 *)

Definition Abstraction State := LayerAbstraction world State.

(**
  We can compose abstractions, by layering one abstraction on top
  of another.  In our case, since everything is ultimately connected
  to [world] states at the bottom, we define a composition of two
  kinds of abstraction: one that goes from [world] states to [State1],
  and another that goes from [State1] to [State2], to produce an
  abstraction from [world] to [State2].

  [abstraction_compose] makes this connection precise, by saying
  that [world] and [State2] states are connected by the fact that
  there exists some intermediate [State1] state that matches the
  two abstractions being composed.
  *)

Definition abstraction_compose
           `(abs1: Abstraction State1)
           `(abs2: LayerAbstraction State1 State2) :=
  {| abstraction := fun w state' => exists state, abstraction abs2 state state' /\
                                  abstraction abs1 w state; |}.

(**
  In some situations, we will want to keep the same level of abstraction
  (i.e., have the code and spec states be the same).  [IdAbstraction]
  defines this "identity" kind of abstraction: it is a relation between
  states of the same type [State], and the relation says that the two
  states must be equal.
 *)

Definition IdAbstraction State : LayerAbstraction State State :=
  {| abstraction := fun state state' => state' = state; |}.

(** ** Specification *)

(** Our specifications describe how a procedure can change the
  state of the system, at some level of abstraction.  We describe
  the allowed state changes using pre- and post-conditions, as
  captured by the following structure, [SpecProps].

  [SpecProps] is parametrized by three types: [T], [R], and [State].

  [State] is the type of states that this specification uses.
  For instance, in the StatDB example, [State] would be [list nat].

  [T] is the type of the return value of the procedure being
  specified.  Note that the [post] condition is a function of
  two arguments: one of type [T] (the returned value), and another
  of type [State] (the resulting state).

  In addition to pre- and post-conditions, our specifications include
  recovery conditions, which help reason about crashes during the
  execution of a procedure.  After a crash, a recovery procedure will
  run to recover any state from the crash.  The recovery procedure may
  also return some result; this result's type is [R], and the recovery
  condition, [recovered], takes two arguments: the return value from
  recovery, [R], and the state after recovery, [State].
 *)

Record SpecProps T R State :=
  Spec {
    pre: Prop;
    post: T -> State -> Prop;
    recovered: R -> State -> Prop;
  }.

(**
  One obvious part missing from the [SpecProps] specification is any
  reference to the starting state.  The reason we didn't pass it as
  an argument to the precondition, [pre], is that it's useful to refer
  to the starting state inside the [post] and [recovered] conditions
  as well, in order to connect the final state to the starting state.

  Another part which is not so obviously missing is a way to talk about
  existential variables in the specification (sometimes called "ghost
  variables" in the PL literature).  This is a bit hard to
  grasp in an abstract sense; we will use this in lab 4, and it's safe
  to ignore it until then.

  We add these two missing parts to a specification by defining the
  actual type of specifications, [Specification], as a function from
  a ghost variable [A] and a starting state [State] to a [SpecProps].
  This allows the pre-, post-, and recovered conditions in [SpecProps]
  to refer to the starting state (and the ghost variable).
 *)

Definition Specification A T R State := A -> State -> SpecProps T R State.

(** ** Correctness of a procedure

  [proc_spec] defines when a specification holds for a procedure
  [p] and a recovery procedure [rec].  (The recovery procedure
  will become important in labs 3 and 4, when we reason about
  crashes.)  [proc_spec] formalizes our intuition of what it
  might mean to satisfy a pre- and post-condition specification.

  The general shape of what [proc_spec] says, ignoring recovery
  for now, is:

<<
            pre                      post
             |                        ||
             V                        VV
           state                    state'
             ^                        ^^
        absR |                   absR ||
             V                        VV
             w ---[procedure p]-----> w'
>>

  The single arrows indicate the assumptions (that there exists
  some starting abstract state [state], corresponding to a world
  state [w], where the precondition [pre] holds, and that running
  the procedure [p] gives us state [w'].)

  The double arrows indicate what [proc_spec] concludes: that there
  is an abstract state [state'] corresponding to [w'], and that the
  postcondition holds in that resulting state [state'].

  This picture should look familiar; it is quite similar to the
  proof obligations described at the top of this file, with the
  extra detail of how we describe the allowed transitions (namely,
  using pre- and post-conditions).

  In more detail, [proc_spec] states that for all ghost variables
  [a], starting states [w], and spec states [state]:

  - assume that the abstraction relation holds between [w] and [state]

  - assume that the precondition holds for [a] and [state]

  - if the procedure [p] starts from code state [w], then one of the
    following must be true:

    - (1) if execution finishes without crashes in code state [w'] and
      returns [v], then there exists a spec state [state'] in which the
      abstraction relation holds between [w'] and [state'] and the
      postcondition holds in [state'] with return value [v], OR

    - (2) if execution finishes in code state [w'] and returns [v]
      (after perhaps several crashes and running the recovery
      procedure [r] on each crash), then there exists a spec state
      [state'] and some return value [v] from the recovery procedure,
      in which the abstraction relation holds
      between [w'] and [state'] and the recovered condition holds in [state']
      with return value [v].

  The [rexec] relation describes how procedures execute, and
  is defined in [Spec.Proc].
 *)

Definition proc_spec `(spec: Specification A T R State) `(p: proc T)
           `(rec: proc R)
           `(abs: Abstraction State) :=
  forall a w state,
    abstraction abs w state ->
    pre (spec a state) ->
    forall r, rexec p rec w r ->
         match r with
         | RFinished v w' => exists state',
                            abstraction abs w' state' /\
                            post (spec a state) v state'
         | Recovered v w' => exists state',
                            abstraction abs w' state' /\
                            recovered (spec a state) v state'
         end.

(** ** Proving correctness *)

(** To help us construct proofs about procedures satisfying
  a specification, it helps to have a notion of when one
  specification implies another specification.  Here, we
  define what it means for [spec1] to imply [spec2] (the
  two specifications must be at the same level of abstraction
  and must talk about the same types of return values):

   - for all ghost variables and all states [state] for which [spec2]'s
     precondition holds,

   - there exists a ghost variable for which [spec1]'s precondition
     holds in [state]

   - for all states [state'] in which the postcondition of [spec1]
     holds, then the post condition of [spec2] also holds

   - for all states [state'] in which the recovered condition of
     [spec1] holds, then the recovered condition of [spec2] also holds.
  *)

Definition spec_impl
           `(spec1: Specification A' T R State)
           `(spec2: Specification A T R State) :=
  forall a state, pre (spec2 a state) ->
         exists a', pre (spec1 a' state) /\
               (forall v state', post (spec1 a' state) v state' ->
                        post (spec2 a state) v state') /\
               (forall rv state', recovered (spec1 a' state) rv state' ->
                         recovered (spec2 a state) rv state').

(** We now prove that the above definition of what it means for
  one specification to imply another one is actually correct.
  This means that, if a procedure satisfies [spec1], and [spec1]
  implies [spec2], then the same procedure must also satisfy [spec2].
 *)

Theorem proc_spec_weaken : forall `(spec1: Specification A T R State)
                              `(spec2: Specification A' T R State)
                              `(p: proc T) `(rec: proc R)
                              (abs: Abstraction State),
    proc_spec spec1 p rec abs ->
    spec_impl spec1 spec2 ->
    proc_spec spec2 p rec abs.
Proof.
  unfold proc_spec at 2; intros.
  eapply H0 in H2; eauto; repeat deex.
  eapply H in H3; eauto.
  destruct r; simpl in *; repeat deex; intuition eauto.
Qed.

Hint Resolve tt.

(** This is a crucial step for constructing proofs of correctness.
  We will decompose proofs about a [Bind] operation (i.e.,
  combining two procedures, [p] and [rx], with a semicolon) into
  smaller proofs about the individual procedures [p] and [rx].

  Specifically, in order to prove that [p; rx] satisfies [spec'],
  it suffices to have some specification [spec] for [p], and to
  prove that the precondition of [spec'] implies the precondition
  of [spec], and that [rx] meets a specification that, informally,
  fixes up the postcondition of [spec] to match the postcondition
  of [spec'].

  More precisely:
 *)

Theorem proc_spec_rx : forall `(spec: Specification A T R State)
                         `(p: proc T) `(rec: proc R)
                         `(rx: T -> proc T')
                         `(spec': Specification A' T' R State)
                         `(abs: Abstraction State),
    proc_spec spec p rec abs ->
    (forall a' state, pre (spec' a' state) ->
             exists a, pre (spec a state) /\
                  (forall r,
                      proc_spec
                        (fun (_:unit) state' =>
                           {| pre := post (spec a state) r state';
                              post :=
                                fun r state'' =>
                                  post (spec' a' state) r state'';
                              recovered :=
                                fun r state'' =>
                                  recovered (spec' a' state) r state'' |})
                        (rx r) rec abs) /\
                  (forall r state', recovered (spec a state) r state' ->
                           recovered (spec' a' state) r state')) ->
    proc_spec spec' (Bind p rx) rec abs.
Proof.
  unfold proc_spec at 3; intros.
  inv_rexec.
  - inv_exec.
    match goal with
    | [ Hexec: exec p _ _ |- _ ] =>
      eapply RExec in Hexec
    end.
    eapply H0 in H2; repeat deex.
    eapply H in H9; simpl in *; safe_intuition (repeat deex; eauto).
    match goal with
    | [ Hexec: exec (rx _) _ _ |- _ ] =>
      eapply RExec in Hexec;
        eapply H3 in Hexec; eauto
    end.
  - inv_exec.
    + (* p finished, rx crashed *)
      match goal with
      | [ Hexec: exec p _ _ |- _ ] =>
        eapply RExec in Hexec
      end.
      eapply H0 in H2; repeat deex.
      eapply H in H10; simpl in *; safe_intuition (repeat deex; eauto).
      match goal with
      | [ Hexec: exec (rx _) _ _ |- _ ] =>
        eapply RExecCrash in Hexec; eauto;
          eapply H3 in Hexec; eauto
      end.
    + (* p crashed before running *)
      assert (exec p w' (Crashed w')) as Hexec by ( constructor; eauto ).
      eapply RExecCrash in Hexec; eauto.
      eapply H0 in H2; repeat deex.
      eapply H in Hexec; simpl in *; safe_intuition (repeat deex; eauto).
    + (* p crashed immediately after finishing *)
      inv_exec.
      match goal with
      | [ Hexec: exec p _ _ |- _ ] =>
        eapply RExec in Hexec
      end.
      eapply H0 in H2; repeat deex.
      eapply H in H10; simpl in *; safe_intuition (repeat deex; eauto).
      match goal with
      | [ Hexec: exec (rx _) _ _ |- _ ] =>
        apply ExecCrashEnd in Hexec;
          eapply RExecCrash in Hexec; eauto;
          eapply H3 in Hexec; eauto
      end.
    + (* p itself crashed *)
      match goal with
      | [ Hexec: exec p _ _ |- _ ] =>
        eapply RExecCrash in Hexec; eauto
      end.
      eapply H0 in H2; repeat deex.
      eapply H in H10; simpl in *; safe_intuition (repeat deex; eauto).
Qed.

(** In some situations, the precondition of a specification
  may define variables or facts that you want to [intros].
  Here we define several helper theorems and an Ltac tactic, [spec_intros],
  that does so.  This is done by changing the specification's precondition
  from an arbitrary Prop (i.e., [pre]) into a statement that there's
  some state [state0] such that [state = state0], and [intros]ing the
  arbitrary Prop in question as a hypothesis about [state0].
*)

Theorem spec_intros : forall `(spec: Specification A T R State)
                       `(p: proc T) `(rec: proc R)
                       `(abs: Abstraction State),
    (forall a state0,
        pre (spec a state0) ->
        proc_spec
          (fun (_:unit) state =>
             {| pre := state = state0;
                post :=
                  fun r state' => post (spec a state) r state';
                recovered :=
                  fun r state' => recovered (spec a state) r state';
             |}) p rec abs) ->
    proc_spec spec p rec abs.
Proof.
  unfold proc_spec at 2; intros.
  apply H in H1.
  eapply H1 in H2; eauto.
  simpl in *; eauto.
Qed.

Ltac spec_intros := intros; eapply spec_intros; intros.

Ltac spec_case pf :=
  eapply proc_spec_weaken; [ solve [ apply pf ] |
                             unfold spec_impl ].

(** Finally, we prove that our notion of equivalent procedures,
  [exec_equiv], is actually correct: if [p] and [p'] are equivalent,
  then they meet the same specifications.

  We will use this next to reason about procedure transformations
  that shouldn't change the behavior of a procedure.
 *)

Theorem spec_exec_equiv : forall `(spec: Specification A T R State)
                            (p p': proc T) `(rec: proc R)
                            `(abs: Abstraction State),
    exec_equiv p p' ->
    proc_spec spec p' rec abs ->
    proc_spec spec p rec abs.
Proof.
  unfold proc_spec; intros.
  eapply H0; eauto.
  eapply rexec_equiv; eauto.
  symmetry; auto.
Qed.

(** ** Reasoning about the [Ret] return operation.

  The simplest procedure we can construct in our model is
  the return operation, [Ret].  Writing a specification for
  [Ret] should be intuitively straightforward, but turns out
  to be slightly complicated by the possibility of crashes.
  The [rec_noop] definition below captures this notion: a
  [Ret v] procedure has no precondition, and has a simple
  postcondition (the state does not change and the return
  value is [v]), but in case of a crash, the state is wiped
  according to some [wipe] relation.

  [rec_noop] is a theorem that states that [Ret v] actually
  meets this specification.  Proving [rec_noop] will be a
  proof obligation, and boils down to showing that the recovery
  procedure [rec] corresponds to the wipe relation [wipe].
 *)

Definition rec_noop `(rec: proc R) `(abs: Abstraction State) (wipe: State -> State -> Prop) :=
  forall T (v:T),
    proc_spec
      (fun (_:unit) state =>
         {| pre := True;
            post := fun r state' => r = v /\
                             state' = state;
            recovered := fun _ state' => wipe state state'; |})
      (Ret v) rec abs.

(** A more general theorem about specifications for [Ret], which
  we will use as part of our proof automation, says
  that [Ret v] meets a specification [spec] if the [rec_noop]
  theorem holds (i.e., the recovery procedure is correctly
  described by a wipe relation [wipe]), and the specification
  [spec] matches the [wipe] relation:
 *)

Theorem ret_spec : forall `(abs: Abstraction State)
                     (wipe: State -> State -> Prop)
                     `(spec: Specification A T R State)
                     (v:T) (rec: proc R),
    rec_noop rec abs wipe ->
    (forall a state, pre (spec a state) ->
            post (spec a state) v state /\
            forall state', wipe state state' ->
                  forall r, recovered (spec a state) r state') ->
    proc_spec spec (Ret v) rec abs.
Proof.
  intros.
  unfold proc_spec; intros.
  eapply H in H3; simpl in *; eauto.
  eapply H0 in H2.
  destruct r; safe_intuition (repeat deex; eauto).
Qed.

(** ** Proof automation

  We will now define some Ltac tactics to help us prove
  the correctness of procedures.  We start with a simple
  tactic that will eliminate unnecessary [Ret] return
  statements and will re-order semicolons into a consistent
  order.

  This tactic, [monad_simpl], makes use of the [monad_left_id]
  and [monad_assoc] theorems to manipulate procedures, simplifying
  their return statements and semicolons, together with the theorem
  we proved above, [spec_exec_equiv], about specifications of
  equivalent procedures.
 *)

Ltac monad_simpl :=
  repeat match goal with
         | |- proc_spec _ (Bind (Ret _) _) _ _ =>
           eapply spec_exec_equiv; [ apply monad_left_id | ]
         | |- proc_spec _ (Bind (Bind _ _) _) _ _ =>
           eapply spec_exec_equiv; [ apply monad_assoc | ]
         end.

(** ** step_proc

  To simplify proofs, we automate reasoning about [proc_spec].
  Consider a proof for a [proc_spec] about "a ; b". What do
  we need to prove?

<<
      pre                             post
       |                               |
       V                               V
     state0 --[a]--> state1 --[b]--> state2
>>

  We need to find a [proc_spec] for [a] and line up our precondition with
  that spec's, then reduce to proving a [proc_spec] for b, with [a]'s post
  as the new pre.  Keep doing this repeatedly.

  There are two requirements to make this plan work:
    - a [proc_spec] for the [a] procedure
    - a way to line up our current state's precondition with
      [a]'s [proc_spec] precondition

  The following Ltac, [step_proc], implements this plan.
  It compares Coq's current goal to:

  - a [proc_spec] with a procedure that invokes a [Ret] operation:
    if so, apply the [ret_spec] theorem to consume the [Ret].  This
    will generate some proof obligations, corresponding to the premises
    of the [ret_spec] theorem.

  - a [proc_spec] with a procedure that sequences two operations [a] and [b]
    (with [Bind]): if so, apply the [proc_spec_rx] theorem to consume the
    [Bind].  This will generate some proof obligations, corresponding to
    the premises of the [proc_spec_rx] theorem.

    A common pattern is that we have already proven that [a] already meets
    some specification.  To automate this case, [step_proc] calls [eauto]
    to find such a theorem.  We tell Coq about these theorems using
    [Hint Resolve] statements that you will see throughout our lab code.

    Proving the correctness of the [b] procedure will remain as a proof
    obligation.

  - a [proc_spec] that is implied by a [proc_spec] that is already in
    context: if so, apply the [proc_spec_weaken] theorem and try to
    prove that one spec implies the other.
 *)

Ltac step_proc_basic :=
  match goal with
  | |- forall _, _ => intros; step_proc_basic
  | |- proc_spec _ (Ret _) _ _ =>
    eapply ret_spec
  | |- proc_spec _ _ _ _ =>
    monad_simpl;
    eapply proc_spec_rx; [ solve [ eauto ] | ]
  | [ H: proc_spec _ ?p _ _
      |- proc_spec _ ?p _ _ ] =>
    eapply proc_spec_weaken; [ eapply H | unfold spec_impl ]
  end.

Ltac step_proc :=
  intros;
  match goal with
  | |- proc_spec _ (Ret _) _ _ =>
    eapply ret_spec
  | |- proc_spec _ _ _ _ =>
    monad_simpl;
    eapply proc_spec_rx; [ solve [ eauto ] | ]
  | [ H: proc_spec _ ?p _ _
      |- proc_spec _ ?p _ _ ] =>
    eapply proc_spec_weaken; [ eapply H | unfold spec_impl ]
  end;
  intros; simpl;
  cbn [pre post recovered] in *;
  repeat match goal with
         | [ H: _ /\ _ |- _ ] => destruct H
         | [ |- rec_noop _ _ _ ] => eauto
         | [ |- forall _, _ ] => intros
         | [ |- exists (_:unit), _ ] => exists tt
         | [ |- _ /\ _ ] => split; [ solve [ trivial ] | ]
         | [ |- _ /\ _ ] => split; [ | solve [ trivial ] ]
         | _ => solve [ trivial ]
         | _ => progress subst
         | _ => progress autounfold in *
         end.

(** ** Initialization

  Initialization is special because, when the initialization
  procedure starts running, the system may be in a
  state that does not correspond to ANY abstract state yet.
  This means that we will need to write a stylized kind of
  specification about initialization procedures.

  As a common pattern, initialization can succeed or fail.
  If it fails, we typically do not promise anything.
 *)

Inductive InitResult :=
| Initialized
| InitFailed.

(** When we compose multiple layers together, a common pattern
  that emerges is trying to initialize the lower level first,
  and then initializing the higher level.  The reason we don't
  just combine the procedures using semicolon (i.e., [Bind])
  is that if the lower-level initialization fails, we should
  return failure right away, instead of continuing to run the
  higher-level initialization.
 *)

Definition then_init (init1 init2: proc InitResult) : proc InitResult :=
  r <- init1;
  match r with
  | Initialized => init2
  | Failed => Ret Failed
  end.

(** ** Initialization specs

  To specify what it means for the initialization procedure to
  be correct, it suffices to simply write a predicate describing
  the initialized states that will be produced by the initialization
  procedure.  A common description of these states is "any state
  that satisfies the abstraction relation", which we can define
  using [inited_any]:
 *)

Definition inited_any `(s : State) : Prop := True.

(** We define this shorthand for the specification of an initialization
  procedure.  Given a description of the states that initialization
  should produce (e.g., [inited_any] above), [init_abstraction] produces
  a full-fledged pre- and post-condition-style specification, which
  says that, if initialization returns success, the resulting state
  is one of the allowed states:
 *)

Definition init_abstraction
           (init: proc InitResult) (rec: proc unit)
           `(abs: Abstraction State) (init_sem: State -> Prop) :=
  proc_spec
    (fun (_:unit) w =>
       {| pre := True;
          post :=
            fun r w' => match r with
                     | Initialized =>
                       exists state, abstraction abs w' state /\ init_sem state
                     | InitFailed => True
                     end;
          recovered :=
            fun _ w' => True;
       |}) init rec (IdAbstraction world).

(** Since the [init_abstraction] specification above does not
  place any requirements in case we crash during initialization,
  the specific recovery procedure doesn't matter:
 *)

Theorem init_abstraction_any_rec : forall (init: proc InitResult)
                                   (rec rec': proc unit)
                                   `(abs: Abstraction State)
                                   (init_sem: State -> Prop),
    init_abstraction init rec abs init_sem ->
    init_abstraction init rec' abs init_sem.
Proof.
  unfold init_abstraction, proc_spec; simpl; intros.
  destruct matches; subst; eauto.
  eapply rexec_finish_any_rec in H2.
  eapply H in H2; eauto.
Qed.

(** Finally, we prove a specialized theorem about how to compose
  two initialization procedures using the [then_init] composition
  operator defined above:
 *)

Theorem then_init_compose : forall (init1 init2: proc InitResult)
                              (rec rec': proc unit)
                              `(abs1: Abstraction State1)
                              `(abs2: LayerAbstraction State1 State2)
                              (init1_sem: State1 -> Prop)
                              (init2_sem: State2 -> Prop),
    init_abstraction init1 rec abs1 init1_sem ->
    proc_spec
      (fun (_:unit) state =>
         {| pre := init1_sem state;
            post :=
              fun r state' => match r with
                       | Initialized =>
                         exists state'', abstraction abs2 state' state'' /\ init2_sem state''
                       | InitFailed => True
                       end;
            recovered :=
              fun _ state' => True; |}) init2 rec abs1 ->
    init_abstraction (then_init init1 init2) rec' (abstraction_compose abs1 abs2) init2_sem.
Proof.
  intros.
  eapply init_abstraction_any_rec with rec.
  unfold init_abstraction; intros.
  step_proc; intuition; simpl in *.
  descend; intuition eauto.
  destruct r.
  - clear H.
    unfold proc_spec in *; (intuition eauto); simpl in *;
      subst; repeat deex.
    eapply H in H3; eauto.
    destruct matches in *; safe_intuition (repeat deex; eauto).
    descend; intuition eauto.
  - unfold proc_spec; simpl; intros.
    destruct matches; subst; eauto.
    eexists; intuition eauto.
    inv_rexec; inv_exec.
    congruence.
Qed.

(** This theorem allows converting between abstraction layers:
 to prove the correctness of procedure [p] at a higher level of
 abstraction, it suffices to drop down to the lower level of
 abstraction, and prove that there exists a connection to the
 higher level in the postcondition. *)

Theorem spec_abstraction_compose :
  forall `(spec: Specification A T R State2)
    `(p: proc T) `(rec: proc R)
    `(abs2: LayerAbstraction State1 State2)
    `(abs1: Abstraction State1),
    proc_spec
      (fun '(a, state2) state =>
         {| pre := pre (spec a state2) /\
                   abstraction abs2 state state2;
            post :=
              fun v state' =>
                exists state2',
                  post (spec a state2) v state2' /\
                  abstraction abs2 state' state2';
            recovered :=
              fun v state' =>
                exists state2',
                  recovered (spec a state2) v state2' /\
                  abstraction abs2 state' state2'; |}) p rec abs1 ->
    proc_spec spec p rec (abstraction_compose abs1 abs2).
Proof.
  intros.
  unfold proc_spec, abstraction_compose;
    simpl; intros; safe_intuition (repeat deex).
  eapply (H (a, state)) in H2; simpl in *; eauto.
  destruct r; intuition (repeat deex; eauto).
Qed.


(** Properties about arbitrary pre-, partial, and total orders. We do not use
the relation [⊆] because we often have multiple orders on the same structure *)
From stdpp Require Export tactics.
From stdpp Require Import options.

Section orders.
  Context {A} {R : relation A}.
  Implicit Types X Y : A.
  Infix "⊆" := R.
  Notation "X ⊈ Y" := (¬X ⊆ Y).
  Infix "⊂" := (strict R).

  Lemma reflexive_eq `{!Reflexive R} X Y : X = Y → X ⊆ Y.
  Proof. by intros <-. Qed.
  Lemma anti_symm_iff `{!PartialOrder R} X Y : X = Y ↔ R X Y ∧ R Y X.
  Proof. split; [by intros ->|]. by intros [??]; apply (anti_symm _). Qed.
  Lemma strict_spec X Y : X ⊂ Y ↔ X ⊆ Y ∧ Y ⊈ X.
  Proof. done. Qed.
  Lemma strict_include X Y : X ⊂ Y → X ⊆ Y.
  Proof. by intros [? _]. Qed.
  Lemma strict_ne X Y : X ⊂ Y → X ≠ Y.
  Proof. by intros [??] <-. Qed.
  Lemma strict_ne_sym X Y : X ⊂ Y → Y ≠ X.
  Proof. by intros [??] <-. Qed.
  Lemma strict_transitive_l `{!Transitive R} X Y Z : X ⊂ Y → Y ⊆ Z → X ⊂ Z.
  Proof.
    intros [? HXY] ?. split; [by trans Y|].
    contradict HXY. by trans Z.
  Qed.
  Lemma strict_transitive_r `{!Transitive R} X Y Z : X ⊆ Y → Y ⊂ Z → X ⊂ Z.
  Proof.
    intros ? [? HYZ]. split; [by trans Y|].
    contradict HYZ. by trans X.
  Qed.
  Global Instance: Irreflexive (strict R).
  Proof. firstorder. Qed.
  Global Instance: Transitive R → StrictOrder (strict R).
  Proof.
    split; try apply _.
    eauto using strict_transitive_r, strict_include.
  Qed.
  Global Instance preorder_subset_dec_slow `{!RelDecision R} :
    RelDecision (strict R) | 100.
  Proof. solve_decision. Defined.
  Lemma strict_spec_alt `{!AntiSymm (=) R} X Y : X ⊂ Y ↔ X ⊆ Y ∧ X ≠ Y.
  Proof.
    split.
    - intros [? HYX]. split; [ done | by intros <- ].
    - intros [? HXY]. split; [ done | by contradict HXY; apply (anti_symm R) ].
  Qed.
  Lemma po_eq_dec `{!PartialOrder R, !RelDecision R} : EqDecision A.
  Proof.
    refine (λ X Y, cast_if_and (decide (X ⊆ Y)) (decide (Y ⊆ X)));
     abstract (rewrite anti_symm_iff; tauto).
  Defined.
  Lemma total_not `{!Total R} X Y : X ⊈ Y → Y ⊆ X.
  Proof. intros. destruct (total R X Y); tauto. Qed.
  Lemma total_not_strict `{!Total R} X Y : X ⊈ Y → Y ⊂ X.
  Proof. red; auto using total_not. Qed.
  Global Instance trichotomy_total
    `{!Trichotomy (strict R), !Reflexive R} : Total R.
  Proof.
    intros X Y.
    destruct (trichotomy (strict R) X Y) as [[??]|[<-|[??]]]; intuition.
  Qed.
End orders.

Section strict_orders.
  Context {A} {R : relation A}.
  Implicit Types X Y : A.
  Infix "⊂" := R.

  Lemma irreflexive_eq `{!Irreflexive R} X Y : X = Y → ¬X ⊂ Y.
  Proof. intros ->. apply (irreflexivity R). Qed.
  Lemma strict_anti_symm `{!StrictOrder R} X Y :
    X ⊂ Y → Y ⊂ X → False.
  Proof. intros. apply (irreflexivity R X). by trans Y. Qed.
  Global Instance trichotomyT_dec `{!TrichotomyT R, !StrictOrder R} :
      RelDecision R := λ X Y,
    match trichotomyT R X Y with
    | inleft (left H) => left H
    | inleft (right H) => right (irreflexive_eq _ _ H)
    | inright H => right (strict_anti_symm _ _ H)
    end.
  Global Instance trichotomyT_trichotomy `{!TrichotomyT R} : Trichotomy R.
  Proof. intros X Y. destruct (trichotomyT R X Y) as [[|]|]; tauto. Qed.
End strict_orders.

Ltac simplify_order := repeat
  match goal with
  | _ => progress simplify_eq/=
  | H : ?R ?x ?x |- _ => by destruct (irreflexivity _ _ H)
  | H1 : ?R ?x ?y |- _ =>
    match goal with
    | H2 : R y x |- _ =>
      assert (x = y) by (by apply (anti_symm R)); clear H1 H2
    | H2 : R y ?z |- _ =>
      unless (R x z) by done;
      assert (R x z) by (by trans y)
    end
  end.


Require Import ZArith.
Require Import Basic_type.

Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n.
 fix zn2z_word_comm 2.
 intros w n; case n.
  reflexivity.
  intros n0;simpl.
  case (zn2z_word_comm w n0).
  reflexivity.
Defined.

Fixpoint extend (n:nat) {struct n} : forall w:Set, zn2z w -> word w (S n) :=
 match n return forall w:Set, zn2z w -> word w (S n) with
 | O => fun w x => x
 | S m =>
   let aux := extend m in
   fun w x => WW W0 (aux w x)
 end.

Section ExtendMax.

 Variable w:Set.

 Definition Tmax n m :=
  (  {p:nat| word (word w n) p = word w m}
    + {p:nat| word (word w m) p = word w n})%type.

 Definition max : forall n m, Tmax n m.
  fix max 1;intros n.
  case n.
  intros m;left;exists m;exact (refl_equal (word w m)).
  intros n0 m;case m.
  right;exists (S n0);exact (refl_equal (word w (S n0))).
  intros m0;case (max n0 m0);intros H;case H;intros p Heq.
  left;exists p;simpl.
   case (zn2z_word_comm (word w n0) p).
   case Heq.
   exact (refl_equal (zn2z (word (word w n0) p))).
  right;exists p;simpl.
   case (zn2z_word_comm (word w m0) p).
   case Heq.
   exact (refl_equal (zn2z (word (word w m0) p))).
 Defined.

 Definition extend_to_max :
  forall n m (x:zn2z (word w n)) (y:zn2z (word w m)),
        (zn2z (word w m) + zn2z (word w n))%type.
  intros n m x y.
   case (max n m);intros (p, Heq).
   left; case Heq;exact (extend p (word w n) x).
   right;case Heq;exact (extend p (word w m) y).
 Defined.

End ExtendMax.

Section Reduce.

 Variable w : Set.
 Variable nT : Set.
 Variable N0 : nT.
 Variable eq0 : w -> bool.
 Variable reduce_n : w -> nT.
 Variable zn2z_to_Nt : zn2z w -> nT.

 Definition reduce_n1 (x:zn2z w) :=
  match x with
  | W0 => N0
  | WW xh xl =>
    if eq0 xh then reduce_n xl
    else zn2z_to_Nt x
  end.

End Reduce.

Section ReduceRec.

 Variable w : Set.
 Variable nT : Set.
 Variable N0 : nT.
 Variable reduce_1n : zn2z w -> nT.
 Variable c : forall n, word w (S n) -> nT.

 Fixpoint reduce_n (n:nat) : word w (S n) -> nT :=
  match n return word w (S n) -> nT with
  | O => reduce_1n
  | S m => fun x =>
    match x with
    | W0 => N0
    | WW xh xl =>
      match xh with
      | W0 => @reduce_n m xl
      | _ => @c (S m) x
      end
    end
  end.

End ReduceRec.

Definition opp_compare cmp :=
  match cmp with
  | Lt => Gt
  | Eq => Eq
  | Gt => Lt
  end.

Section CompareRec.

 Variable wm w : Set.
 Variable w_0 : w.
 Variable compare : w -> w -> comparison.
 Variable compare0_m : wm -> comparison.
 Variable compare_m : wm -> w -> comparison.

 Fixpoint compare0_mn (n:nat) : word wm n -> comparison :=
  match n return word wm n -> comparison with
  | 0 => compare0_m
  | S m => fun x =>
    match x with
    | W0 => Eq
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare0_mn m xl
      | r  => Lt
      end
    end
  end.

 Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison :=
  match n return word wm n -> w -> comparison with
  | 0 => compare_m
  | S m => fun x y =>
    match x with
    | W0 => compare w_0 y
    | WW xh xl =>
      match compare0_mn m xh with
      | Eq => compare_mn_1 m xl y
      | r  => Gt
      end
    end
  end.

End CompareRec.


Require Import Setoid.

Theorem not_not_not : forall P, ~~~P <-> ~P.
Proof.
  split.
  intros.
  unfold not in *.
  intro.
  apply H.
  intros.
  apply H1.
  apply H0.
  unfold not.
  intros.
  apply (H0 H).
Qed.

Theorem wierd : forall P, ~(~P /\ ~~P).
Proof.
  intros P H.
  destruct H as [A B].
  apply (B A).
Qed.

Theorem www : forall P Q, ~(~P /\ ~Q) <-> ~~(~~P \/ ~~Q).
  Proof.
  intros.
  split.

  intro And.
  unfold not in *.
  intro Or.
  apply And.
  split;
    intro aPQ;
    apply Or;
    [left | right];
    intro nPQ;
    apply (nPQ aPQ).
  intro Or.
  intro And.
  unfold not in *.
  apply Or.
  intro Or0.
  destruct Or0 as [Or1 | Or1];
    apply Or1;
    apply And.
Qed.

Theorem wierder : forall P, ~~(~P \/ ~~P).
Proof.
  intros P.
  unfold not at 1 2 4 5.
  rewrite <- not_not_not in |- *.
  apply www.
  unfold not.
  intro And.
  destruct And as [nnP nP].
  apply (nnP nP).
Qed.

Theorem PP : forall P, ((~P)->~~P)->~~P.
Proof.
  intros.
  unfold not in *.
  intro.
  apply (H H0 H0).
Qed.

Theorem PPP : forall P, (P \/ ~P) -> ((~P)->P)->P.
Proof.
  intros.
  case H.
  intro.
  apply H1.
  exact H0.
Qed.


Require Import rt.util.all.
Require Import rt.model.basic.schedule.
Require Import rt.analysis.basic.workload_bound.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module InterferenceBoundGeneric.

  Section Definitions.

    Import Schedule WorkloadBound.

    Context {sporadic_task: eqType}.
    Variable task_cost: sporadic_task -> time.
    Variable task_period: sporadic_task -> time.
    Variable task_deadline: sporadic_task -> time.

    (* Let tsk be the task to be analyzed. *)
    Variable tsk: sporadic_task.

    Let task_with_response_time := (sporadic_task * time)%type.

    (* Assume a known response-time bound for each interfering task ... *)
    Variable R_prev: seq task_with_response_time.

    (* ... and an interval length delta. *)
    Variable delta: time.

    Section PerTask.

      Variable tsk_R: task_with_response_time.
      Let tsk_other := fst tsk_R.
      Let R_other := snd tsk_R.

      (* Based on the workload bound, Bertogna and Cirinei define the
         following interference bound for a task. *)
      Definition interference_bound_generic :=
        minn (W task_cost task_period tsk_other R_other delta) (delta - (task_cost tsk) + 1).

    End PerTask.

  End Definitions.

End InterferenceBoundGeneric.


Require Import Gappa_tactic.

Goal forall x, (1/4 <= x <= 3/4 -> 0 <= x /\ not (1 <= x))%R.
gappa.
Qed.