Require Import Frap Setoid Classes.Morphisms SepCancel.
Export Setoid Classes.Morphisms.

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Shared notations and definitions; main material starts afterward. *)

Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
Definition heap := fmap nat nat.
Definition assertion := heap -> Prop.

Hint Extern 1 (_ <= _) => linear_arithmetic : core.
Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.

Ltac simp := repeat (simplify; subst; propositional;
                     try match goal with
                         | [ H : ex _ |- _ ] => invert H
                         end); try linear_arithmetic.

(** * Encore of last mixed-embedding language from last time *)

(* First, almost exactly the same syntactic language definition as from class: *)

Inductive loop_outcome acc res :=
| Done (r : res)
| Again (a : acc).
(* ^-- One slight difference: we allow the result type from a loop to differ from the
 *     type of the iteration variable.
 *)

Arguments Done {acc} {res}.
Arguments Again {acc} {res}.

Inductive cmd : Set -> Type :=
| Return {result : Set} (r : result) : cmd result
| Bind {result result'} (c1 : cmd result') (c2 : result' -> cmd result) : cmd result
| Read (a : nat) : cmd nat
| Write (a v : nat) : cmd unit
| Loop {acc res : Set} (init : acc) (body : acc -> cmd (loop_outcome acc res)) : cmd res
| Fail {result} : cmd result
| Alloc (numWords : nat) : cmd nat
| Free (base numWords : nat) : cmd unit.

Notation "x <- c1 ; c2" := (Bind c1 (fun x => c2)) (right associativity, at level 80).
Notation "'for' x := i 'loop' c1 'done'" := (Loop i (fun x => c1)) (right associativity, at level 80).

Fixpoint initialize (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => initialize h base numWords' $+ (base + numWords', 0)
  end.

Fixpoint deallocate (h : heap) (base numWords : nat) : heap :=
  match numWords with
  | O => h
  | S numWords' => deallocate (h $- base) (base+1) numWords'
  end.

(* Now here's *almost* exactly the same semantics.  See one exception noted
 * below. *)
Inductive step : forall A, heap * cmd A -> heap * cmd A -> Prop :=
| StepBindRecur : forall result result' (c1 c1' : cmd result') (c2 : result' -> cmd result) h h',
  step (h, c1) (h', c1')
  -> step (h, Bind c1 c2) (h', Bind c1' c2)
| StepBindProceed : forall (result result' : Set) (v : result') (c2 : result' -> cmd result) h,
  step (h, Bind (Return v) c2) (h, c2 v)

| StepLoop : forall (acc res : Set) (init : acc) (body : acc -> cmd (loop_outcome acc res)) h,
  step (h, Loop init body) (h, o <- body init; match o with
                                               | Done a => Return a
                                               | Again a => Loop a body
                                               end)

| StepRead : forall h a v,
  h $? a = Some v
  -> step (h, Read a) (h, Return v)
| StepWrite : forall h a v v',
  h $? a = Some v
  -> step (h, Write a v') (h $+ (a, v'), Return tt)

| StepAlloc : forall h numWords a,
  (forall i, i < numWords -> h $? (a + i) = None)
  -> a <> 0
  -> step (h, Alloc numWords) (initialize h a numWords, Return a)
(* ^-- DIFFERENCE FROM CLASS: Now we record that a freshly allocated object has
 * a nonnull address, so that we are free to use null (0) for a special purpose
 * in linked data structures. *)

| StepFree : forall h a numWords,
  step (h, Free a numWords) (deallocate h a numWords, Return tt).

Definition trsys_of (h : heap) {result} (c : cmd result) := {|
  Initial := {(h, c)};
  Step := step (A := result)
|}.

(* Here's exactly the same instantiation of the separation-logic connectives and
 * their algebraic laws. *)
Module Import Sep <: SEP.
  Definition hprop := heap -> Prop.

  (* Implication *)
  Definition himp (p q : hprop) := forall h, p h -> q h.

  (* Equivalence *)
  Definition heq (p q : hprop) := forall h, p h <-> q h.

  (* Lifting a pure proposition *)
  Definition lift (P : Prop) : hprop :=
    fun h => P /\ h = $0.

  (* Separating conjunction, one of the two big ideas of separation logic *)
  Definition star (p q : hprop) : hprop :=
    fun h => exists h1 h2, split h h1 h2 /\ disjoint h1 h2 /\ p h1 /\ q h2.

  (* Existential quantification *)
  Definition exis A (p : A -> hprop) : hprop :=
    fun h => exists x, p x h.

  (* Convenient notations *)
  Notation "[| P |]" := (lift P) : sep_scope.
  Infix "*" := star : sep_scope.
  Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
  Delimit Scope sep_scope with sep.
  Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
  Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).

  Local Open Scope sep_scope.

  Lemma iff_two : forall A (P Q : A -> Prop),
    (forall x, P x <-> Q x)
    -> (forall x, P x -> Q x) /\ (forall x, Q x -> P x).
  Proof.
    firstorder.
  Qed.

  Local Ltac t := (unfold himp, heq, lift, star, exis; propositional; subst);
                 repeat (match goal with
                         | [ H : forall x, _ <-> _ |- _  ] =>
                           apply iff_two in H
                         | [ H : ex _ |- _ ] => destruct H
                         | [ H : split _ _ $0 |- _ ] => apply split_empty_fwd in H
                         end; propositional; subst); eauto 15.

  Theorem himp_heq : forall p q, p === q
                               <-> (p ===> q /\ q ===> p).
  Proof.
    t.
  Qed.

  Theorem himp_refl : forall p, p ===> p.
  Proof.
    t.
  Qed.

  Theorem himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_left : forall p (Q : Prop) r,
    (Q -> p ===> r)
    -> p * [| Q |] ===> r.
  Proof.
    t.
  Qed.

  Theorem lift_right : forall p q (R : Prop),
    p ===> q
    -> R
    -> p ===> q * [| R |].
  Proof.
    t.
  Qed.

  Hint Resolve split_empty_bwd' : core.

  Theorem extra_lift : forall (P : Prop) p,
    P
    -> p === [| P |] * p.
  Proof.
    t.
    apply split_empty_fwd' in H1; subst; auto.
  Qed.

  Theorem star_comm : forall p q, p * q === q * p.
  Proof.
    t.
  Qed.

  Theorem star_assoc : forall p q r, p * (q * r) === (p * q) * r.
  Proof.
    t.
  Qed.

  Theorem star_cancel : forall p1 p2 q1 q2, p1 ===> p2
    -> q1 ===> q2
    -> p1 * q1 ===> p2 * q2.
  Proof.
    t.
  Qed.

  Theorem exis_gulp : forall A p (q : A -> _),
    p * exis q === exis (fun x => p * q x).
  Proof.
    t.
  Qed.

  Theorem exis_left : forall A (p : A -> _) q,
    (forall x, p x ===> q)
    -> exis p ===> q.
  Proof.
    t.
  Qed.

  Theorem exis_right : forall A p (q : A -> _) x,
    p ===> q x
    -> p ===> exis q.
  Proof.
    t.
  Qed.

  Theorem emp_heap : forall h, lift True h -> h = $0.
  Proof.
    t.
  Qed.
End Sep.

(* Instantiate our big automation engine to these definitions. *)
Module Import Se := SepCancel.Make(Sep).
Export Sep Se.

(* ** Some extra predicates outside the set that the engine knows about *)

(* These are exactly the same as before, too! *)

(* Capturing single-mapping heaps *)
Definition heap1 (a v : nat) : heap := $0 $+ (a, v).
Definition ptsto (a v : nat) : hprop :=
  fun h => h = heap1 a v.

Theorem try_ptsto_first : forall a v, try_me_first (ptsto a v).
Proof.
  simplify.
  apply try_me_first_easy.
Qed.

Hint Resolve try_ptsto_first : core.

(* Helpful notations, some the same as above *)
Notation "[| P |]" := (lift P) : sep_scope.
Notation emp := (lift True).
Infix "*" := star : sep_scope.
Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)) : sep_scope.
Delimit Scope sep_scope with sep.
Notation "p === q" := (heq p%sep q%sep) (no associativity, at level 70).
Notation "p ===> q" := (himp p%sep q%sep) (no associativity, at level 70).
Infix "|->" := ptsto (at level 30) : sep_scope.

Fixpoint multi_ptsto (a : nat) (vs : list nat) : hprop :=
  match vs with
  | nil => emp
  | v :: vs' => a |-> v * multi_ptsto (a + 1) vs'
  end%sep.

Infix "|-->" := multi_ptsto (at level 30) : sep_scope.

Fixpoint zeroes (n : nat) : list nat :=
  match n with
  | O => nil
  | S n' => zeroes n' ++ 0 :: nil
  end.

Fixpoint allocated (a n : nat) : hprop :=
  match n with
  | O => emp
  | S n' => (exists v, a |-> v) * allocated (a+1) n'
  end%sep.

Infix "|->?" := allocated (at level 30) : sep_scope.

(** * Finally, the Hoare logic *)

(* The only change we make here is in the loop rule. *)

Inductive hoare_triple : forall {result}, assertion -> cmd result -> (result -> assertion) -> Prop :=
(* First, some basic rules that look exactly the same as before *)
| HtReturn : forall P {result : Set} (v : result),
    hoare_triple P (Return v) (fun r => P * [| r = v |])%sep
| HtBind : forall P {result' result} (c1 : cmd result') (c2 : result' -> cmd result) Q R,
    hoare_triple P c1 Q
    -> (forall r, hoare_triple (Q r) (c2 r) R)
    -> hoare_triple P (Bind c1 c2) R

(* THIS RULE IS DIFFERENT. *)
| HtLoop : forall {acc res : Set} (init : acc) (body : acc -> cmd (loop_outcome acc res)) P Q,
    (* As before, the premise forces us to consider any accumulator at the start
     * of a loop iteration, proving a Hoare triple for each case. *)
    (forall acc,
        (* Important difference: now the rule is parameterized over both a
         * precondition [P] and a postcondition [Q], each of which takes, as an
         * extra argument, the latest accumulator value. *)
        hoare_triple (P acc) (body acc)
                     (fun r =>
                        match r with
                        | Done res =>
                          Q acc res
                          (* The loop is done?  Then the postcondition had
                           * better be satisfied directly.  Note that it takes
                           * the "before" and "after" accumulators as arguments.
                           * We'll see shortly why that pays off.... *)
                        | Again acc' =>
                          (* It's time for more iterations?  Then we'd better
                           * satisfy [P] w.r.t. the "after" accumulator, but
                           * with a twist.  We are allowed to *forget* some
                           * state, captured by the arbitrary frame predicate
                           * [R].  The idea is that the state we shunt into [R]
                           * will not be touched again until the loop finishes
                           * running. *)
                          exists R, P acc' * R
                                    (* There is another important requirement on
                                     * [R]: Assume that the loop finishes, so
                                     * that the postcondition [Q] is satisfied
                                     * w.r.t. the new accumulator [acc'].  If we
                                     * *put back* [R], we should then arrive at
                                     * a state where the postcondition is
                                     * satisfied w.r.t. the "before" accumulator
                                     * [acc]! *)
                                    * [| forall r, Q acc' r * R ===> Q acc r |]
                        end%sep))
    -> hoare_triple (P init) (Loop init body) (Q init)
(* All that may be a bit abstract, but we will soon show an example
 * verification, to illustrate. *)

| HtFail : forall {result},
    hoare_triple (fun _ => False) (Fail (result := result)) (fun _ _ => False)

| HtRead : forall a R,
    hoare_triple (exists v, a |-> v * R v)%sep (Read a) (fun r => a |-> r * R r)%sep
| HtWrite : forall a v v',
    hoare_triple (a |-> v)%sep (Write a v') (fun _ => a |-> v')%sep
| HtAlloc : forall numWords,
    hoare_triple emp%sep (Alloc numWords) (fun r => [| r <> 0 |] * r |--> zeroes numWords)%sep
| HtFree : forall a numWords,
    hoare_triple (a |->? numWords)%sep (Free a numWords) (fun _ => emp)%sep

| HtConsequence : forall {result} (c : cmd result) P Q (P' : assertion) (Q' : _ -> assertion),
    hoare_triple P c Q
    -> P' ===> P
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P' c Q'
| HtFrame : forall {result} (c : cmd result) P Q R,
    hoare_triple P c Q
    -> hoare_triple (P * R)%sep c (fun r => Q r * R)%sep.

(* Now more duplicated infrastructure from class.  Feel free to skip ahead to
 * the example verification. *)

Notation "{{ P }} c {{ r ~> Q }}" :=
  (hoare_triple P%sep c (fun r => Q%sep)) (at level 90, c at next level).

Lemma HtStrengthen : forall {result} (c : cmd result) P Q (Q' : _ -> assertion),
    hoare_triple P c Q
    -> (forall r, Q r ===> Q' r)
    -> hoare_triple P c Q'.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

Lemma HtWeaken : forall {result} (c : cmd result) P Q (P' : assertion),
    hoare_triple P c Q
    -> P' ===> P
    -> hoare_triple P' c Q.
Proof.
  simplify.
  eapply HtConsequence; eauto.
  reflexivity.
Qed.

(* Fancy theorem to help us rewrite within preconditions and postconditions *)
Instance hoare_triple_morphism : forall A,
  Proper (heq ==> eq ==> (eq ==> heq) ==> iff) (@hoare_triple A).
Proof.
  Transparent himp.
  repeat (hnf; intros).
  unfold pointwise_relation in *; intuition subst.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.

  eapply HtConsequence; eauto.
  rewrite H; reflexivity.
  intros.
  hnf in H1.
  specialize (H1 r _ eq_refl).
  rewrite H1; reflexivity.
Qed.

Global Opaque heq himp lift star exis ptsto.

Theorem use_lemma : forall result P' (c : cmd result) (Q : result -> assertion) P R,
  hoare_triple P' c Q
  -> P ===> P' * R
  -> hoare_triple P c (fun r => Q r * R)%sep.
Proof.
  simp.
  eapply HtWeaken.
  eapply HtFrame.
  eassumption.
  eauto.
Qed.

Theorem HtRead' : forall a v,
  hoare_triple (a |-> v)%sep (Read a) (fun r => a |-> v * [| r = v |])%sep.
Proof.
  simp.
  apply HtWeaken with (exists r, a |-> r * [| r = v |])%sep.
  eapply HtStrengthen.
  apply HtRead.
  simp.
  cancel; auto.
  subst; cancel.
  cancel; auto.
Qed.

Theorem HtRead'' : forall p P R,
  P ===> (exists v, p |-> v * R v)
  -> hoare_triple P (Read p) (fun r => p |-> r * R r)%sep.
Proof.
  simp.
  eapply HtWeaken.
  apply HtRead.
  assumption.
Qed.

Lemma HtReturn' : forall P {result : Set} (v : result) Q,
    P ===> Q v
    -> hoare_triple P (Return v) Q.
Proof.
  simp.
  eapply HtStrengthen.
  constructor.
  simp.
  cancel.
Qed.

Ltac basic := apply HtReturn' || eapply HtWrite || eapply HtAlloc || eapply HtFree.

Ltac step0 := basic || eapply HtBind || (eapply use_lemma; [ basic | cancel; auto ])
              || (eapply use_lemma; [ eapply HtRead' | solve [ cancel; auto ] ])
              || (eapply HtRead''; solve [ cancel ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ basic | cancel; auto ] | ])
              || (eapply HtConsequence; [ apply HtFail | .. ]).
Ltac step := step0; simp.
Ltac ht := simp; repeat step.
Ltac conseq := simplify; eapply HtConsequence.
Ltac use_IH H := conseq; [ apply H | .. ]; ht.
Ltac loop_inv0 P0 Q0 := eapply HtConsequence; [ apply HtLoop with (P := P0) (Q := Q0) | .. ].
Ltac loop_inv P0 Q0 := loop_inv0 P0 Q0; ht.
Ltac use H := (eapply use_lemma; [ eapply H | cancel; auto ])
              || (eapply HtStrengthen; [ eapply use_lemma; [ eapply H | cancel; auto ] | ]).

Ltac heq := intros; apply himp_heq; split.

(* Some lemmas that may or may not be useful. *)

Lemma star_emp_l P :
  emp * P === P.
Proof.
  heq; cancel.
Qed.

Lemma star_emp_r P :
  P * emp === P.
Proof.
  heq; cancel.
Qed.

(** * Binary trees *)

(* Now we define binary trees and ask you to verify two of their classic
 * operations. *)

Inductive tree :=
| Leaf
| Node (l : tree) (x : nat) (r : tree).

(* [m] for memory! *)
Fixpoint mtree' (t : tree) (p : nat) : hprop :=
  match t with
  | Leaf => [| p = 0 |]
  | Node l x r => [| p <> 0 |]
                  * exists p1 p2, p |--> [p1; x; p2]
                                  * mtree' l p1
                                  * mtree' r p2
  end%sep.

(* Here's the version that forgets exactly which tree it is. *)
Definition mtree (p : nat) : hprop :=
  (exists t, mtree' t p)%sep.

(* And here's an extra layer of indirection: a mutable pointer to a tree, which
 * comes in handy for operations that modify the tree. *)
Definition mtreep (p : nat) : hprop :=
  (exists p', [| p <> 0 |] * p |-> p' * mtree p')%sep.

(* Here's the usual lookup operation. *)
Definition lookup (x p : nat) :=
  t <- Read p; (* First peel away the initial layer of indirection.
                * You will want to use the regular old frame rule to forget
                * about some of the state that you won't need after this
                * point! *)
  for a := t loop
    (* The accumulator tells us: the node of the tree we have reached
     * (for [Again]) or whether the key [x] has been found (for [Done]). *)
    if a ==n 0 then
      (* Oh, the pointer is null.  Sorry, didn't find [x]. *)
      Return (Done false)
    else
      (* Read the data value of the current node (which must be nonnull). *)
      y <- Read (a + 1);
      if x ==n y then
        (* Found it! *)
        Return (Done true)
      else if x <=? y then
        (* The key must be earlier in the tree.  Read the left-child pointer and
         * continue looping with it. *)
        l <- Read a;
        Return (Again l)
      else
        (* The key must be later in the tree.  Read the right-child pointer and
         * continue looping with it. *)
        r <- Read (a + 1 + 1);
        (* Why [+ 1 + 1] instead of [+ 2]?  It happens to work better with the
         * automation we're using. ;) *)
        Return (Again r)
  done.

(* And here's the operation to add a new key to a tree. *)
Definition insert (x p : nat) :=
  for a := p loop
    (* Note that now the accumulator is not the latest tree root, but instead
     * *a pointer to it*, so that we may overwrite that pointer if necessary.
     * We start by reading the actual root out of the pointer [p]. *)
    q <- Read a;
    if q ==n 0 then
      (* It's a null pointer?  Perfect.  This is the spot to insert a new
       * node. *)
      node <- Alloc 3;
      (* Initialize its data field with [x]. *)
      _ <- Write (node + 1) x;
      (* Redirect the pointer [p] to the new node. *)
      _ <- Write a node;
      Return (Done tt)
    else
      (* Nonnull?  Read the data field into [y]. *)
      y <- Read (q + 1);
      if x <=? y then
        (* The right spot to insert must be to the left.  Recurse thataway. *)
        Return (Again q)
      else
        (* The right spot to insert must be to the right.  Recurse thataway. *)
        Return (Again (q + 1 + 1))
  done.

(* Something very subtle happened in that loop: we iterated using a pointer into
 * *the interior of a struct*, in each branch of the last [if]!  This is a fun
 * example of the kinds of tricks that can be played in a low-level language,
 * and the verification techniques are up to the challenge. *)

(* Your task: verify the two methods.  (By the way, our solution also includes a
 * soundness proof for this logic, but we aren't asking you to write one.)
 *
 * IMPORTANT NOTE:
 * The difficulty of this problem set is scoped assuming you will use the
 * tactics included in this file, which are very similar to the ones from
 * Lecture 20!  Trying to attack these proofs from first principles will likely
 * lead to proof size spiraling out of control.  The main ingredients you should
 * expect to reuse are:
 *  - [step]: A tactic to choose the right Hoare-logic rule to apply next, when
 *    your goal is a Hoare triple
 *  - [cancel]: A tactic to prove an implication between two separation-logic
 *    assertions, or reduce it to a simpler implication by *cancel*ing matching
 *    subformulas; before calling [cancel], be sure you have marked [Opaque]
 *    all of the predicates standing for data structures!  There is a commented-
 *    out [Opaque mtree] command in Pset9.v for precisely this reason; don't
 *    forget to uncomment it, with any lemmas about this predicate proved
 *    beforehand.
 *  - [heq]: A tactic to reduce a separation-logic assertion implication (using
 *    [===]) to two implications (using [===>])
 *  - [loop_inv P0 Q0]: A tactic to apply the loop rule, given an invariant
 *    split in a peculiar way; see above for an example
 *  - [setoid_rewrite H]: A tactic to rewrite within a separation-logic
 *    implication, using an equivalence that applies to one of its subterms
 *
 * Our solution also has a few direct uses of rules [HtConsequence] and
 * [HtFrame], sometimes using the [with] syntax of [apply] to specify values
 * for some variables that appear in these rules' statements. In particular,
 * you can use [HtConsequence] before [HtFrame] to ensure that the predicate
 * that you want to frame out is in the desired syntactic position so that
 * [HtFrame] will apply. The [exis_right] lemma will also be handy, as used
 * in the example above. *)
Module Type S.
  (* 10% for stating true and useful lemmas about empty trees *)
  (* 5% for proving lemmas about empty trees *)
  (* 20% for stating true and useful lemmas about non-empty trees *)
  (* 10% for proving lemmas about non-empty trees *)

  (* Confirm that [lookup] has no memory errors and that [p] still points to
   * some binary tree once [lookup] has completed. Note that this theorem is
   * very similar to [llength_ok]. We encourage you to adapt that proof to
   * this one.
   *)
  Axiom lookup_ok : forall x p, (* 25% *)
    {{mtreep p}}
      lookup x p
    {{_ ~> mtreep p}}.

  (* Confirm that [insert] has no memory errors and preserves the binary
   * tree structure pointed to by [p].
   *)
  Axiom insert_ok : forall x p, (* 30% *)
    {{mtreep p}}
      insert x p
    {{_ ~> mtreep p}}.
End S.

(* For an extra challenge, you might try implementing and verifying deletion. *)


(*
listerine: A mouthwash for every type of list.

listerine automatically figures out which combination of a lot of theorems for lists to apply.
It consists of:
  - a combination of theorems for empty lists
  - a combination of theorems for singleton lists
  - (x :: xs) = (y :: ys) -> (x = y) /\ (xs = ys)
  - xs ++ ys = xs ++ zs -> ys = zs
  - splitting lists into possible combinations for type: ys ++ zs = x :: xs
  - taking a step for not equal lists if a hypothesis is hinting that some elements aren't equal
*)

(*
TODO: Help Wanted
Some of these tactics complete the proof and others simply step forward.
This seems like two goals that can be separated.
Let `auto` handle the completion of proofs and
let `listerine` handle stepping forward.
Once `listerine` is more widely used in the code base,
remove stuff from `listerine` that could be handled by auto.
Then `listerine` becomes `repeat listerine_step; auto 10`.
*)

(*
TODO: Good First Issue
Inside the cases of match goal sometimes a tactic is applied
and other times a theorem is applied.
Find places where a theorem would be more surgical,
create those theorems and replace the tactics.
Example:

Local Ltac list_cons_eq :=
match goal with
  | [H: (cons ?X ?XS) = (cons ?Y ?YS) |- _ ] =>
    inversion H; clear H; subst
    (* (x :: xs) = (y :: ys) -> (x = y) /\ (xs = ys) *)
  | [H: ?XS ++ [?X] = ?YS ++ [?Y] |- _ ] =>
    apply app_inj_tail in H
    (* xs ++ [x] = ys ++ [y] ->
       xs = ys /\ x = y. *)
end.

replace `inversion H; clear H; subst` with a theorem `apply NewTheorem in H`.
*)

Require Import Coq.Lists.List.
Import Coq.Lists.List.ListNotations.

(* list_empty:
   finds empty lists in the hypotheses and the goal and tries to apply an appropriate tactic:
   - xs ++ ys = [] -> xs = [] /\ ys = []
   - [] = cons _ _ -> False
   - cons _ _ = [] -> False
   - [] = xs ++ y :: ys -> False
   - [] ++ xs -> xs
   - xs ++ [] -> xs
*)
Local Ltac list_empty :=
(* [] = cons _ _ -> False *)
(* cons _ _ = [] -> False *)
(* [] = x :: xs -> False *)
(* x :: xs = [] -> False *)
   discriminate
|| match goal with
| [ |- [] <> ?X ++ (?Y :: ?YS) ] =>
  apply app_cons_not_nil
  (* [] = xs ++ y :: ys -> False *)
| [ H: ?XS ++ ?YS = [] |- _ ] =>
  let H0 := fresh "H0" in
  let H1 := fresh "H1" in
  apply app_eq_nil in H;
  destruct H as [H0 H1];
  try rewrite H0 in *;
  try rewrite H1 in *
  (* xs ++ ys = [] ->
        xs = []
     /\ ys = []
  *)
| [ H: [] = ?XS ++ ?YS |- _ ] =>
  let H0 := fresh "H0" in
  let H1 := fresh "H1" in
  symmetry in H;
  apply app_eq_nil in H;
  destruct H as [H0 H1];
  try rewrite H0 in *;
  try rewrite H1 in *
  (* [] = xs ++ ys ->
       xs = []
    /\ ys = []
  *)
| [ H: context [[] ++ _] |- _ ] =>
  rewrite app_nil_l in H
  (* [] ++ xs = xs *)
| [ |- context [[] ++ _] ] =>
  rewrite app_nil_l
  (* [] ++ xs = xs *)
| [ H: context [_ ++ []] |- _ ] =>
  rewrite app_nil_r in H
  (* xs ++ [] = xs *)
| [ |- context [_ ++ []] ] =>
  rewrite app_nil_r
  (* xs ++ [] = xs *)
| [ |- [] = [] ] =>
  reflexivity
  (* [] = [] *)
end.

Example example_list_empty_neq_cons_r: forall {A: Type} (x: A) (xs: list A) ,
  [] <> x :: xs.
Proof.
intros.
list_empty.
Qed.

Example example_list_empty_neq_cons_l: forall {A: Type} (x: A),
  [] <> [x].
Proof.
intros.
list_empty.
Qed.

Example example_list_empty_eq_app: forall {A: Type} (xs: list A) (ys: list A),
  xs ++ ys = [] -> xs = [].
Proof.
intros.
list_empty.
reflexivity.
Qed.

Example example_list_empty_eq_app_easy: forall {A: Type} (xs: list A) (ys: list A),
  xs ++ ys = [] -> xs = [].
Proof.
intros.
list_empty.
easy.
Qed.

Example example_list_empty_eq_app_now: forall {A: Type} (xs: list A) (ys: list A),
  xs ++ ys = [] -> xs = [].
Proof.
intros.
now list_empty.
Qed.

Example example_list_empty_neq_unit_hyp_r: forall {A: Type} (x: A),
  [] <> [x].
Proof.
intros.
unfold not.
intros.
list_empty.
Qed.

Example example_list_empty_neq_unit_hyp_l: forall {A: Type} (x: A),
  [x] <> [].
Proof.
intros.
unfold not.
intros.
list_empty.
Qed.

Example example_list_empty_neq_app_cons: forall {A: Type} (xs: list A) (ys: list A) (y: A),
  [] <> xs ++ (y :: ys).
Proof.
intros.
list_empty.
Qed.

Example example_list_empty_app_l: forall {A: Type} (xs: list A),
  [] ++ xs = xs.
Proof.
intros.
list_empty.
reflexivity.
Qed.

Example example_list_empty_app_r: forall {A: Type} (xs: list A),
  xs ++ [] = xs.
Proof.
intros.
list_empty.
reflexivity.
Qed.

(* list_single:
   finds hypotheses with singleton lists and tries to apply an appropriate tactic.
   - xs ++ ys = [x] ->
         (xs = [] /\ ys = [x])
      \/ (xs = [x] /\ ys = [])
   Sometimes it is needed to group singleton lists for other tactics to be applicable.
   - xs ++ ys ++ [y] ->
         (xs ++ ys) ++ [y]
   - (x :: xs) ++ ys ->
         x :: (xs ++ ys)
*)
Local Ltac list_single :=
match goal with
  | [ H: ?XS ++ ?YS = [?X] |- _ ] =>
    let H0 := fresh "H0"
    in apply app_eq_unit in H;
       destruct H as [H0 | H0]; destruct H0; subst
    (* xs ++ ys = [x] ->
           (xs = [] /\ ys = [x])
        \/ (xs = [x] /\ ys = [])
    *)
  | [ H: [?X] = ?XS ++ ?YS  |- _ ] =>
    symmetry in H;
    let H0 := fresh "H0"
    in apply app_eq_unit in H;
       destruct H as [H0 | H0]; destruct H0; subst
    (* xs ++ ys = [x] ->
           (xs = [] /\ ys = [x])
        \/ (xs = [x] /\ ys = [])
    *)
  | [H: context [?XS ++ ?YS ++ [?Y]] |- _ ] =>
    rewrite app_assoc in H
    (* xs ++ ys ++ [y] ->
      (xs ++ ys) ++ [y] *)
  | [H: context [(?X :: ?XS) ++ ?YS] |- _ ] =>
    (* (x :: xs) ++ ys ->
       x :: (xs ++ ys) *)
    rewrite <- app_comm_cons in H
  | [ |- context [(?X :: ?XS) ++ ?YS] ] =>
    (* (x :: xs) ++ ys ->
       x :: (xs ++ ys) *)
    rewrite <- app_comm_cons
end.

Example example_list_single_app_eq_unit: forall {A: Type} (xs ys:list A) (x:A),
  xs ++ ys = [x] -> xs = [] /\ ys = [x] \/ xs = [x] /\ ys = [].
Proof.
intros.
list_single.
- left. constructor; reflexivity.
- right. constructor; reflexivity.
Qed.

Example example_list_single_app_eq_unit_auto: forall {A: Type} (xs ys:list A) (x:A),
  xs ++ ys = [x] -> xs = [] /\ ys = [x] \/ xs = [x] /\ ys = [].
Proof.
intros.
list_single; auto.
Qed.

(* list_cons_eq:
   Finds an equality between lists in the hypotheses,
   with a head or tail element that can be deconstructed.
   (x :: xs) = (y :: ys) -> (x = y) /\ (xs = ys)
   xs ++ [x] = ys ++ [y] -> xs = ys /\ x = y.
*)
Local Ltac list_cons_eq :=
match goal with
  | [H: (cons ?X ?XS) = (cons ?Y ?YS) |- _ ] =>
    inversion H; clear H; subst
    (* (x :: xs) = (y :: ys) -> (x = y) /\ (xs = ys) *)
  | [H: ?XS ++ [?X] = ?YS ++ [?Y] |- _ ] =>
    apply app_inj_tail in H
    (* xs ++ [x] = ys ++ [y] ->
       xs = ys /\ x = y. *)
end.

Example example_list_cons_eq: forall {A: Type} (x y: A) (xs ys: list A),
  (x :: xs) = (y :: ys) -> x = y.
Proof.
intros.
list_cons_eq.
reflexivity.
Qed.

Example example_list_app_assoc_app_inj_tail: forall {A: Type} (xs ys zs:list A) (y z:A),
  xs ++ ys ++ [y] = zs ++ [z] -> y = z.
Proof.
intros.
list_single.
list_cons_eq.
inversion H.
assumption.
Qed.

Example example_list_app_assoc_app_inj_tail_easy: forall {A: Type} (xs ys zs:list A) (y z:A),
  xs ++ ys ++ [y] = zs ++ [z] -> y = z.
Proof.
intros.
list_single.
list_cons_eq.
easy.
Qed.

(* list_app_eq:
   Finds an equality between lists in the hypotheses,
   with a common prefix or suffix:
   - xs ++ ys = xs ++ zs -> ys = zs.
   - xs ++ zs = ys ++ zs -> xs = ys.
*)
Local Ltac list_app_eq :=
match goal with
  | [H: ?XS ++ ?YS = ?XS ++ ?ZS |- _ ] =>
    apply app_inv_head in H
    (* xs ++ ys = xs ++ zs -> ys = zs *)
  | [H: (?XS ++ ?ZS) = (?YS ++ ?ZS) |- _ ] =>
    apply app_inv_tail in H
    (* xs ++ zs = ys ++ zs -> xs = ys*)
end.

Example example_list_app_eq_prefix: forall {A: Type} (xs ys zs: list A),
  xs ++ ys = xs ++ zs -> ys = zs.
Proof.
intros.
list_app_eq.
assumption.
Qed.

Example example_list_app_eq_suffix: forall {A: Type} (xs ys zs: list A),
  ys ++ xs = zs ++ xs -> ys = zs.
Proof.
intros.
list_app_eq.
assumption.
Qed.

(* list_app_uncons is used in a tactic below to deconstruct
   ys ++ zs = x :: xs
   into the possible combinations
   ys = [] /\ zs = x :: xs
   \/ ...
*)
Lemma list_app_uncons: forall {A: Type} (x: A) (xs ys zs: list A),
  ys ++ zs = x :: xs ->
  (ys = [] /\ zs = x :: xs)
  \/ (exists
     (ys': list A)
     (pys: ys = x :: ys'),
     ys' ++ zs = xs
  ).
Proof.
intros.
destruct ys.
- list_empty.
  left.
  constructor.
  + reflexivity.
  + assumption.
- right.
  list_single.
  list_cons_eq.
  exists ys.
  exists eq_refl.
  reflexivity.
Qed.

(* list_app_uncons:
   Finds an hypotheses that it can deconstruct using the list_app_cons lemma:
   ys ++ zs = x :: xs
   into the two goals, which consist of the possible combinations, as in:
   - ys = [] /\ zs = x :: xs
   - ...
*)
Local Ltac list_app_uncons :=
  match goal with
  | [ H: ?YS ++ ?ZS = cons ?X ?XS |- _ ] =>
    let C := fresh "C"
    in let E := fresh "E"
    in let L := fresh "L"
    in let E0 := fresh "E0"
    in apply list_app_uncons in H;
       destruct H as [C | E];
       [inversion_clear C; subst
       | inversion_clear E as [L E0]; inversion_clear E0; subst]
  end.

Example example_list_app_uncons_double:
  forall {A: Type} (xs ys: list A) (x y: A),
  xs ++ ys = [x;y] ->
  (xs = [] /\ ys = [x;y])
  \/ (xs = [x] /\ ys = [y])
  \/ (xs = [x;y] /\ ys = []).
Proof.
intros.
list_app_uncons.
- left. constructor; reflexivity.
- list_single.
  + right. left. constructor; reflexivity.
  + right. right. constructor; reflexivity.
Qed.

(*
list_cons_neq:
  Searches for hypotheses with `x <> y`,
  where `x` and/or `y` also occur in the goal as part lists that are also not equal:
  - x <> y -> x :: _ <> y :: _
  - x <> y -> _ <> x :: _ -> (x <> y -> ... -> False)
  - x <> y -> x :: _ <> _ -> (x <> y -> ... -> False)
  - y <> x -> _ <> x :: _ -> (y <> x -> ... -> False)
  - y <> x -> x :: _ <> _ -> (y <> x -> ... -> False)
*)
Local Ltac list_cons_neq :=
  match goal with
  | [ H: ?X <> ?Y |- cons ?X _ <> cons ?Y _ ] =>
    unfold not; intros; list_cons_eq; contradiction
    (* x <> y -> x :: _ <> y :: _ *)
   | [ H0: ?X <> ?Y, H1: context [?YS] |- cons ?X _ <> ?YS ] =>
    let N := fresh "N"
    in unfold not; intro N; rewrite <- N in *
    (* x <> y -> _ <> x :: _ -> (x <> y -> ... -> False) *)
  | [ H0: ?X <> ?Y, H1: context [?YS] |- ?YS <> cons ?X _ ] =>
    let N := fresh "N"
    in unfold not; intro N; rewrite N in *
    (* x <> y -> x :: _ <> _ -> (x <> y -> ... -> False) *)
  | [ H0: ?X <> ?Y, H1: context [?YS] |- cons ?Y _ <> ?YS ] =>
    let N := fresh "N"
    in unfold not; intro N; rewrite <- N in *
    (* y <> x -> _ <> x :: _ -> (y <> x -> ... -> False) *)
  | [ H0: ?X <> ?Y, H1: context [?YS] |- ?YS <> cons ?Y _ ] =>
    let N := fresh "N"
    in unfold not; intro N; rewrite N in *
    (* y <> x -> x :: _ <> _ -> (y <> x -> ... -> False) *)
  | [ H0: ?X <> ?Y |- cons ?X _ <> ?YS ] =>
    let N := fresh "N"
    in unfold not; intro N
    (* x <> y -> _ <> x :: _ -> (x <> y -> ... -> False) *)
  | [ H0: ?X <> ?Y |- ?YS <> cons ?X _ ] =>
    let N := fresh "N"
    in unfold not; intro N
    (* x <> y -> x :: _ <> _ -> (x <> y -> ... -> False) *)
  | [ H0: ?X <> ?Y |- cons ?Y _ <> ?YS ] =>
    let N := fresh "N"
    in unfold not; intro N
    (* y <> x -> _ <> x :: _ -> (y <> x -> ... -> False) *)
  | [ H0: ?X <> ?Y |- ?YS <> cons ?Y _ ] =>
    let N := fresh "N"
    in unfold not; intro N
    (* y <> x -> x :: _ <> _ -> (y <> x -> ... -> False) *)
  end.

Example example_list_cons_neq: forall (A: Type) (x: A) (y: A) (xs ys zs: list A),
  x <> y ->
  xs ++ ys = x :: zs ->
  xs <> [y].
Proof.
intros.
list_app_uncons.
- discriminate.
- list_cons_neq.
Qed.

Ltac listerine_step :=
     list_empty
  || list_single
  || list_cons_eq
  || list_app_eq
  || list_app_uncons
  || list_cons_neq
  .

Ltac listerine := repeat listerine_step.

(* Lots of list theorems have been added to the auto database named: datatypes
   Here is an example of using `auto with datatypes`.
*)
Example example_auto_with_datatypes: forall
    {A: Type} (x y:list A) (a:A),
    [] <> x ++ a :: y.
Proof.
intros.
auto with datatypes.
Qed.

(* `listerine` sometimes competes with `auto with datatypes`. *)
Example example_auto_with_datatypes_now_with_listerine: forall
    {A: Type} (x y:list A) (a:A),
    [] <> x ++ a :: y.
Proof.
intros.
listerine. (* `auto with datatypes.` also would have worked *)
Qed.

Example example_app_eq_unit:
forall {A: Type} (x y:list A) (a:A),
  x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = [].
Proof.
intros.
listerine.
- left. constructor; reflexivity.
- right; constructor; reflexivity.
Qed.

Example example_list_app_eq_double:
  forall {A: Type} (xs ys: list A) (x y: A),
  xs ++ ys = [x;y] ->
  (xs = [] /\ ys = [x;y])
  \/ (xs = [x] /\ ys = [y])
  \/ (xs = [x;y] /\ ys = []).
Proof.
intros.
listerine.
- left. constructor; reflexivity.
- right. left. constructor; reflexivity.
- right. right. constructor; reflexivity.
Qed.

Example example_list_app_eq_double_with_auto:
  forall {A: Type} (xs ys: list A) (x y: A),
  xs ++ ys = [x;y] ->
  (xs = [] /\ ys = [x;y])
  \/ (xs = [x] /\ ys = [y])
  \/ (xs = [x;y] /\ ys = []).
Proof.
intros.
listerine; auto.
Qed.

Example example_list_app_eq_triple: forall (A: Type) (x y: A) (xs ys: list A),
    xs ++ ys = [x;x;y] ->
    (xs = [] /\ ys = [x;x;y])
    \/ (xs = [x] /\ ys = [x;y])
    \/ (xs = [x;x] /\ ys = [y])
    \/ (xs = [x;x;y] /\ ys = []).
Proof.
intros.
listerine; auto.
Qed.

Example example_app_eq_quad: forall (A: Type) (x y: A) (xs ys: list A),
    xs ++ ys = [x;x;x;y] ->
    (xs = [] /\ ys = [x;x;x;y])
    \/ (xs = [x] /\ ys = [x;x;y])
    \/ (xs = [x;x] /\ ys = [x;y])
    \/ (xs = [x;x;x] /\ ys = [y])
    \/ (xs = [x;x;x;y] /\ ys = []).
Proof.
intros.
listerine; auto 10.
Qed.

Example example_list_eq_head: forall (A: Type) (x: A) (y: A) (xs: list A) (ys: list A),
    x :: xs = [y] ++ ys ->
    x = y /\ xs = ys.
Proof.
intros.
listerine.
constructor; reflexivity.
Qed.

Example example_list_extract_init: forall (A: Type) (x y z: A),
    [x; y; z] = [x; y] ++ [z].
Proof.
intros.
listerine.
reflexivity.
Qed.

Example example_neq_tail: forall (A: Type) (x y: A) (xs ys zs xs': list A),
    x <> y ->
    xs ++ ys ++ zs = xs' ++ [x] ->
    zs <> [y].
Proof.
intros.
listerine.
inversion_clear H0; subst.
contradiction.
Qed.

Example example_list_neq_swap_suffix:
  forall {A: Type} (x y: A) (xy: x <> y) (xs: list A),
  xs ++ [x] ++ [y] <> [y] ++ [x].
Proof.
intros.
listerine.
contradiction.
Qed.

Example example_list_neq_longer_suffix:
  forall {A: Type} (x y: A) (xy: x <> y) (xs: list A),
  xs ++ [x] ++ [y] <> [y] ++ [y] ++ [y] ++ [x].
Proof.
intros.
listerine.
contradiction.
Qed.

Example example_list_neq_longer_prefix:
  forall {A: Type} (x y: A) (xy: x <> y) (xs: list A),
  [y] ++ [y] ++ xs <> [x].
Proof.
intros.
listerine.
Qed.


From trace_program_logic.fairness Require Import fairness resources.
From trace_program_logic.prelude Require Import finitary quantifiers classical_instances.
From stdpp Require Import finite.

Section gmap.
  Context `{!EqDecision K, !Countable K}.

  Definition max_gmap (m: gmap K nat) : nat :=
    map_fold (λ k v r, v `max` r) 0 m.

  Lemma max_gmap_spec m:
    map_Forall (λ _ v, v <= max_gmap m) m.
  Proof.
    induction m using map_ind; first done.
    apply map_Forall_insert =>//. rewrite /max_gmap map_fold_insert //.
    - split; first lia. intros ?? Hnotin. specialize (IHm _ _ Hnotin). simpl in IHm.
      unfold max_gmap in IHm. lia.
    - intros **. lia.
  Qed.
End gmap.

Section finitary.
  Context `{M: FairModel}.
  Context `{Λ: language}.
  Context `{EqDecision M}.
  Context `{EqDecision (locale Λ)}.

  Context `{HPI0: forall s x, ProofIrrel ((let '(s', ℓ) := x in M.(fmtrans) s ℓ s'): Prop) }.

  Variable model_finitary: forall s1, Finite { '(s2, ℓ) | M.(fmtrans) s1 ℓ s2 }.

  Definition enum_inner (s1: M): list (M * option M.(fmrole)) :=
    map proj1_sig (@enum _ _ (model_finitary s1)).

  Lemma enum_inner_spec (s1 s2: M) ℓ:
    M.(fmtrans) s1 ℓ s2 -> (s2, ℓ) ∈ enum_inner s1.
  Proof.
    intros H. unfold enum_inner. rewrite elem_of_list_fmap.
    exists (exist _ (s2, ℓ) H). split =>//. apply elem_of_enum.
  Qed.

  Program Definition enumerate_next (δ1: aux_state (aux_fair_state M)) (oζ : olocale Λ) (c': cfg Λ):
    list (aux_state (aux_fair_state M) * @mlabel (fair_model (Λ := Λ) M)) :=
    '(s2, ℓ) ← (δ1.(ls_under), None) :: enum_inner δ1.(ls_under);
    fs ← enum_gmap_bounded' (live_roles _ s2) (max_gmap δ1.(ls_fuel) `max` fuel_limit s2);
    ms ← enum_gmap_range_bounded' (live_roles _ s2) (locales_of_list c'.1);
    let ℓ' := match ℓ with
              | None => match oζ with
                         Some ζ => Silent_step ζ
                       | None => Config_step
                       end
              | Some ℓ => match oζ with
                         | None => Config_step
                         | Some ζ => Take_step ℓ ζ
                         end
              end in
    mret ({| ls_under := s2;
             ls_fuel := `fs;
             (* ls_fuel_dom := proj2_sig fs; *) (* TODO: why this does not work?*)
             ls_mapping := `ms ;
             ls_mapping_dom := proj2_sig ms
          |}, ℓ').
  Next Obligation.
    intros ??????????. destruct fs as [??]. by simpl.
  Qed.

  Lemma valid_state_evolution_finitary_fairness φ:
    valid_state_evolution_finitary (aux_fair_state M) φ.
  Proof.
    intros extr auxtr c' oζ.
    eapply finite_smaller_card_nat.
    eapply (in_list_finite (enumerate_next (trace_last auxtr) oζ c')).
    intros [δ2 ℓ] [[Hlab [Htrans Hsmall]] _].
    unfold enumerate_next. apply elem_of_list_bind.
    exists (δ2.(ls_under), match ℓ with Take_step l _ => Some l | _ => None end).
    split; last first.
    { destruct ℓ as [ρ tid' | |].
      - inversion Htrans as [Htrans']. apply elem_of_cons; right. by apply enum_inner_spec.
      - apply elem_of_cons; left. f_equal. inversion Htrans as (?&?&?&?); done.
      - apply elem_of_cons; right. inversion Htrans as (?&?). by apply enum_inner_spec. }
    apply elem_of_list_bind. eexists (δ2.(ls_fuel) ↾ (ls_fuel_dom _)); split; last first.
    { eapply enum_gmap_bounded'_spec; split; first by apply ls_fuel_dom.
      intros ρ f Hsome. destruct ℓ as [ρ' tid' | |].
      - destruct (decide (ρ = ρ')) as [-> | Hneq].
        + inversion Htrans as [? Hbig]. destruct Hbig as (?&?&?&Hlim&?).
          rewrite Hsome /= in Hlim.
          assert (Hlive: ρ' ∈ live_roles _ δ2).
          { rewrite -ls_fuel_dom elem_of_dom. eauto. }
          specialize (Hlim Hlive). lia.
        + inversion Htrans as [? Hbig]. destruct Hbig as (?&?&Hleq&?&Hnew).
          destruct (decide (ρ ∈ live_roles _ (trace_last auxtr))) as [Hin|Hnotin].
          * assert (Hok: oleq (ls_fuel δ2 !! ρ) (ls_fuel (trace_last auxtr) !! ρ)).
            { apply Hleq =>//. congruence. }
            rewrite Hsome in Hok. destruct (ls_fuel (trace_last auxtr) !! ρ) as [f'|] eqn:Heqn; last done.
            rewrite <-ls_fuel_dom, elem_of_dom in Hin.
            pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. lia.
          * assert (Hok: oleq (ls_fuel δ2 !! ρ) (Some (fuel_limit δ2))).
            { apply Hnew. apply elem_of_dom_2 in Hsome. rewrite -ls_fuel_dom. set_solver. }
            rewrite Hsome in Hok. simpl in *. lia.
      - inversion Htrans as [? [? [Hleq Heq]]]. specialize (Hleq ρ).
        assert (Hok: oleq (ls_fuel δ2 !! ρ) (ls_fuel (trace_last auxtr) !! ρ)).
        { apply Hleq; last done. rewrite Heq -ls_fuel_dom elem_of_dom Hsome. by eauto. }
        rewrite Hsome in Hok. destruct (ls_fuel (trace_last auxtr) !! ρ) as [f'|] eqn:Heqn; last done.
        pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. lia.
      - inversion Htrans as [? [? [Hleq Hnew]]]. specialize (Hleq ρ).
        destruct (decide (ρ ∈ live_roles _ (trace_last auxtr))).
        + assert (Hok: oleq (ls_fuel δ2 !! ρ) (ls_fuel (trace_last auxtr) !! ρ)).
          { apply Hleq; done. }
          rewrite Hsome in Hok. destruct (ls_fuel (trace_last auxtr) !! ρ) as [f'|] eqn:Heqn; last done.
          pose proof (max_gmap_spec _ _ _ Heqn). simpl in *. lia.
        + assert (Hok: oleq (ls_fuel δ2 !! ρ) (Some (fuel_limit δ2))).
          { apply Hnew. apply elem_of_dom_2 in Hsome. rewrite -ls_fuel_dom. set_solver. }
          rewrite Hsome in Hok. simpl in *. lia. }
    apply elem_of_list_bind. exists (δ2.(ls_mapping) ↾ (ls_mapping_dom _)); split; last first.
    { eapply enum_gmap_range_bounded'_spec; split; first by apply ls_mapping_dom.
      intros ρ' tid' Hsome. unfold tids_smaller in *.
      apply locales_of_list_from_locale_from. eauto. }
    rewrite elem_of_list_singleton; f_equal.
    - destruct δ2; simpl. f_equal; apply ProofIrrelevance.
    - destruct ℓ; simpl; destruct oζ =>//; by inversion Hlab.

      Unshelve.
      + intros ??. apply make_decision.
      + intros. apply make_proof_irrel.
  Qed.
End finitary.


Require Import compcert.lib.Coqlib.
Require Import Bvector.
Require Import List.
Require Import compcert.lib.Integers.
Require Import BinNums.
Require Import sha.general_lemmas.
Require Import sha.ByteBitRelations.
Require Import sha.hmac_pure_lemmas.
Require Import sha.HMAC_common_defs.
Require Import sha.HMAC_spec_pad.
Require Import sha.HMAC_spec_concat.
Require Import sha.HMAC_spec_abstract.

Require Import FCF.Blist.

Lemma of_length_proof_irrel {A:Set} n (l: list A) M:
      Vector.to_list (@of_list_length _ n l M) = l.
Proof. destruct M. apply Vector.to_list_of_list_opp. Qed.

Require Import sha.HMAC_functional_prog. (*Just for HMAC_FUN*)

Module Type EQUIV_Inst (HF:HP.HASH_FUNCTION).

(*Section EQUIV.*)
  Parameter c:nat.
  Parameter C: NPeano.Nat.divide 8 c.
  Parameter p:nat.
  Definition b := (c+p)%nat.
  Parameter B: (0<b)%nat.
  Parameter BS: (HF.BlockSize * 8)%nat = b.

  Parameter h: Blist -> Blist -> Blist. (*To be instantiated to sha_h*)
  Parameter h_length
     : forall iv blk : list bool,
       length iv = c -> length blk = b -> length (h iv blk) = c. (*instantiation: sha_h_length*)

  Parameter ir: list int.
(*  Definition iv: Blist := convert ir. (*sha_iv*)*)
  Parameter iv_length: length (convert ir) = c. (*sha_iv_length*)
  (*Definition iv_v : Bvector c := of_list_length _ iv_length. (*Vector.of_list iv.*)*)
  Parameter iv_v : Bvector c.
  Parameter iv_eq : convert ir = Vector.to_list iv_v.
(*  Proof. unfold iv_v. rewrite of_length_proof_irrel. trivial.
  Qed.*)

  Parameter fpad_v : Bvector c -> Bvector p.
  Parameter fpad : Blist -> Blist.
  Parameter fpad_length: forall msg, length msg = c -> length (fpad msg) = p.
  Parameter fpad_eq: forall v l, l = Vector.to_list v ->
                    fpad l = Vector.to_list (fpad_v v).

  Parameter splitAndPad : Blist -> Blist.
  Parameter splitAndPad_v : Blist -> list (Bvector b).

  Parameter splitandpad_blocks: Blist -> list Blist.

  Parameter sap_fpad: forall l m, length l = b ->
                     InBlocks 8 m ->
                     splitAndPad (l ++ m) = l ++ HMAC_Concat.app_fpad fpad m.

  Parameter shasplitandpad_blocks_b:
           forall m, Forall (fun x => length x = b) (splitandpad_blocks m).

  Definition sap' (m:Blist):= concat (splitandpad_blocks m). (*plays role of sha_splitandpad_inc*)

  Parameter sap_app : forall (l m : Blist),
                         length l = b ->
                         splitAndPad (l ++ m) = l ++ sap' m.

  Parameter sap'_InBlocks: forall m, InBlocks b (sap' m).

  Parameter hashblock : list int -> list int -> list int.
  Parameter HHB : h =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))).

  Parameter hashblocks: list int -> list int -> list int.
  Parameter d:nat.

  Parameter HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end.
  Parameter D: (d * 32)%nat = b.

  Parameter gap:list byte -> list int.
  Parameter GAP: forall bits, NPeano.Nat.divide d (length (gap (bitsToBytes bits))).
  Parameter sap_gap: splitAndPad = fun bits => bytesToBits (intlist_to_bytelist (gap (bitsToBytes bits))).

  Parameter HASH: forall m, HF.Hash m = intlist_to_bytelist (hashblocks ir (gap m)).

  Parameter FOLD_HB_eq: forall l ls, length l = (c + p)%nat ->
     Forall (fun x => length x = (c + p)%nat) ls ->
     fold_left h (l :: ls) (Vector.to_list iv_v) =
          hash_blocks_bits (HMAC_spec_concat.HMAC_Concat.b c p) B h
          (Vector.to_list iv_v) (l ++ concat ls).

  Parameter length_splitandpad_inner: forall m,
    Forall2
     (fun (bv : Vector.t bool b) (bl : list bool) => bl = Vector.to_list bv)
     (splitAndPad_v m) (splitandpad_blocks m).
End EQUIV_Inst.

Module HMAC_Equiv (HF:HP.HASH_FUNCTION) (EQ: EQUIV_Inst HF).
Module I<:INST.
  Definition shah : Blist -> Blist ->  Blist := EQ.h.
  Definition hashblock : list int -> list int -> list int :=EQ.hashblock.
  Definition HHB : shah =
      (fun rgs bl : Blist =>
       intsToBits (hashblock (bitsToInts rgs) (bitsToInts bl))) := EQ.HHB.
  Definition hashblocks: list int -> list int -> list int := EQ.hashblocks.
  Definition d:nat := EQ.d.

  Definition HBS_eq : forall r msg : list int,
         hashblocks r msg =
         match msg with
         | List.nil => r
         | _ :: _ => hashblocks (hashblock r (firstn d msg)) (skipn d msg)
         end := EQ.HBS_eq.
End I.

(*Module HM:= HP.HMAC_FUN HF.*)
Module PAD := HMAC_Pad HF I.

  Definition h_v (iv:Bvector EQ.c) (blk:Bvector EQ.b): Bvector EQ.c :=
    of_list_length _
       (EQ.h_length _ _ (VectorToList_length _ iv) (VectorToList_length _ blk)).

  Lemma h_eq : forall (block_v : Bvector EQ.b) (block_l : Blist)
               (HVL: block_l = Vector.to_list block_v)
               ivA ivB (IV: ivA = Vector.to_list ivB),
               EQ.h ivA block_l = Vector.to_list (h_v ivB block_v).
  Proof. intros. unfold h_v, of_list_length.
    destruct (EQ.h_length (Vector.to_list ivB) (Vector.to_list block_v)
      (VectorToList_length EQ.c ivB) (VectorToList_length EQ.b block_v)).
    symmetry. subst. apply Vector.to_list_of_list_opp.
  Qed.

  Definition ipd := Byte.repr 54.
  Definition opd :=Byte.repr 92.

  Definition IPAD:=bytesToBits (PAD.HM.sixtyfour ipd).
  Definition OPAD:=bytesToBits (PAD.HM.sixtyfour opd).

  Lemma IL: length IPAD = EQ.b.
    unfold IPAD. rewrite bytesToBits_len, PAD.HM.length_SF, <- EQ.BS; trivial.
  Qed.
  Lemma OL: length OPAD = EQ.b.
    unfold OPAD. rewrite bytesToBits_len, PAD.HM.length_SF, <- EQ.BS; trivial.
  Qed.

  Definition ipad_v: Bvector EQ.b := of_list_length _ IL.
  Definition opad_v : Bvector EQ.b := of_list_length _ OL.
  Lemma OPADX:bytes_bits_lists (Vector.to_list opad_v) (PAD.HM.sixtyfour opd).
    apply bytes_bits_comp_ind.
      unfold PAD.HM.sixtyfour.
    unfold opad_v. rewrite of_length_proof_irrel. reflexivity.
  Qed.

  Lemma IPADX:bytes_bits_lists (Vector.to_list ipad_v) (PAD.HM.sixtyfour ipd).
    apply bytes_bits_comp_ind.
      unfold PAD.HM.sixtyfour.
    unfold ipad_v. rewrite of_length_proof_irrel. reflexivity.
  Qed.

Lemma BS_pos: (0< HF.BlockSize)%nat.
Proof.
  assert ((0 < HF.BlockSize * 8)%nat).
    rewrite EQ.BS. apply EQ.B.
  omega.
Qed.

  Lemma opad_ne_ipad : opad_v <> ipad_v.
  intros N.
  assert ((Vector.to_list ipad_v)  = bytesToBits (PAD.HM.sixtyfour ipd)  ).
    apply bits_bytes_ind_comp; trivial.
    apply IPADX.
  assert ((Vector.to_list opad_v)  = bytesToBits (PAD.HM.sixtyfour opd)  ).
    apply bits_bytes_ind_comp; trivial.
    apply OPADX.
  rewrite N, H in H0; clear N H.
  apply bytesToBits_injective in H0; trivial.
  unfold PAD.HM.sixtyfour in H0.
  apply list_repeat_injective in H0. inv H0.
  apply BS_pos.
Qed.

Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.Nat.divide 8 (length msg))
      (kv : Bvector EQ.b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v EQ.iv_v (HMAC_Abstract.wrappedSAP _ _ EQ.splitAndPad_v)
                      EQ.fpad_v opad_v ipad_v kv m) =
      bytesToBits (PAD.HM.HmacCore ipd opd
                     (bitsToBytes (HMAC_Abstract.Message2Blist m))
                     (bitsToBytes (Vector.to_list kv))).
Proof.
  assert (LK : length (Vector.to_list kv) = EQ.b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply EQ.fpad_eq.
  2: apply EQ.length_splitandpad_inner.
  erewrite HMAC_spec_list.HMAC_List.HMAC_list_concat with (B:=EQ.B)(sap':=EQ.sap').
  2: apply EQ.fpad_length.
  2: apply EQ.shasplitandpad_blocks_b.
  2: reflexivity.
  2: apply EQ.h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply EQ.FOLD_HB_eq.
  2: apply LK.

  erewrite <- HMAC_spec_concat.HMAC_Concat.HMAC_concat_pad.
  2: apply EQ.C.
  5: apply EQ.h_length.
  5: apply VectorToList_length.
  5: apply VectorToList_length.
  5: apply VectorToList_length.
  5: apply VectorToList_length.
  2: apply EQ.sap_app.
  2: apply EQ.sap_fpad.
  2: apply EQ.sap'_InBlocks.
  rewrite <- EQ.iv_eq.
  apply bits_bytes_ind_comp.
  eapply (PAD.HMAC_pad_concrete' _ _ EQ.B EQ.BS EQ.D EQ.ir _ EQ.GAP EQ.sap_gap EQ.HASH).
            erewrite bitsToBytes_len_gen. reflexivity.
            rewrite LK. rewrite EQ.BS; trivial.
            apply bytes_bits_comp_ind.
              rewrite bits_bytes_bits_id; trivial.
              apply InBlocks_len. rewrite LK, <- EQ.BS. eexists; reflexivity.
    apply bytes_bits_comp_ind.
              rewrite bits_bytes_bits_id; trivial.
              apply InBlocks_len. destruct m. simpl. apply HP. assumption.
    apply OPADX. apply IPADX. (*
    apply bytes_bits_comp_ind.
             unfold PAD.HM.sixtyfour. apply Forall_list_repeat. apply EQ.isbyteZ_Ipad.
             unfold opad_v. rewrite of_length_proof_irrel. reflexivity.
    apply bytes_bits_comp_ind.
             unfold PAD.HM.sixtyfour. apply Forall_list_repeat. apply EQ.isbyteZ_Ipad.
             unfold ipad_v. rewrite of_length_proof_irrel. reflexivity.*)
Qed.
   (*

Lemma opad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Opad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition opad_v: Bvector b := of_list_length _ opad_length.

Lemma ipad_length: length (bytesToBits (HP.HMAC_SHA256.sixtyfour
                       (Integers.Byte.unsigned HP.Ipad))) = b.
Proof. rewrite bytesToBits_len, length_SF. reflexivity. Qed.

Definition ipad_v: Bvector b := of_list_length _ ipad_length.

Lemma Equivalence (P : Blist -> Prop) (HP: forall msg, P msg -> NPeano.divide 8 (length msg))
      (kv : Bvector b) (m : HMAC_Abstract.Message P):
      Vector.to_list (HMAC_spec.HMAC h_v iv_v (HMAC_Abstract.wrappedSAP _ _ splitAndPad_v)
                      fpad_v opad_v ipad_v kv m) =
      bytesToBits (HP.HMAC_SHA256.HmacCore (Integers.Byte.repr 54) (Integers.Byte.repr 92)
                              (bitsToBytes (HMAC_Abstract.Message2Blist m))
                              (map Integers.Byte.repr (bitsToBytes (Vector.to_list kv)))).
Proof.
  assert (LK : length (Vector.to_list kv) = b).
    { apply VectorToList_length. }
  erewrite <- HMAC_Abstract.HMAC_abstract_list; try reflexivity.
  2: apply h_eq.
  2: apply fpad_eq.
  2: apply length_splitandpad_inner.
  rewrite HMAC256_spec_list.HMAC_list_concat_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  2: apply fold_hash_blocks_eq.
(*  rewrite <- sha_splitandpad_inc_eq.*)
  rewrite <- HMAC256_spec_concat.HMAC_concat_pad_sap_instantiated; trivial.
  2: apply sha_h_length.
  2: apply VectorToList_length.
  2: apply VectorToList_length.
  eapply HMAC256_spec_pad.HMAC_pad_concrete'.

  split; omega.
  split; omega.

  (* key length *)
  { rewrite map_length, bitsToBytes_len_gen with (n:=64%nat).
    reflexivity.
    rewrite LK; reflexivity. }

  (* key length *)
  { rewrite Zlength_map, bitsToBytes_len. reflexivity. apply LK. }

  (* TODO: maybe replace bytes_bits_lists with bytesToBits? Since bytes_bits_comp_ind
     is used a lot *)

  (* key *)
  { rewrite map_unsigned_Brepr_isbyte.
      apply bytes_bits_comp_ind.
      eapply bitsToBytes_isbyteZ; reflexivity.
      rewrite  bits_bytes_bits_id; trivial.
      apply block_8. assumption.
      eapply bitsToBytes_isbyteZ. reflexivity. }

  (* uses fact that message is in blocks of 8 *)
  { apply bytes_bits_comp_ind.
    eapply bitsToBytes_isbyteZ; reflexivity.
    rewrite bits_bytes_bits_id; trivial.
    apply InBlocks_len.
    apply HP. destruct m. simpl; trivial. }

  (* opad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Opad. omega.
    apply of_length_proof_irrel. }

  (* ipad *)
  { apply bytes_bits_comp_ind.
    apply Forall_list_repeat. unfold HP.Ipad. omega.
    apply of_length_proof_irrel. }

Qed.*)
End HMAC_Equiv.