Require Export Coq.FSets.FMapInterface.
Require Import Coq.FSets.FMapFacts
        Coq.Program.Program
        Coq.Structures.OrderedTypeEx
        Fiat.Common
        Fiat.Common.SetEq
        Fiat.Common.SetEqProperties
        Fiat.Common.List.ListFacts
        Fiat.Common.LogicFacts.

Unset Implicit Arguments.

Module FMapExtensions_fun (E: DecidableType) (Import M: WSfun E).
  Module Export BasicFacts := WFacts_fun E M.
  Module Export BasicProperties := WProperties_fun E M.

  Definition of_list {T} (ls : list (key * T)) : t T
    := List.fold_right
         (fun kv => add (fst kv) (snd kv))
         (empty _)
         ls.

  Definition TKey := key.

  (** TODO: merge with find_default *)
  Definition FindWithDefault {A} (key: TKey) (default: A) (fmap: t A) :=
    match find key fmap with
    | Some result => result
    | None        => default
    end.

  Definition Values {A} container :=
    List.map snd (@elements A container).

  Lemma FindWithDefault_dec :
    forall {A : Type} (key : TKey) (default : A) (fmap : t A),
      { exists result,
          MapsTo key result fmap /\
          @FindWithDefault A key default fmap = result } +
      { find key fmap = None /\
        @FindWithDefault A key default fmap = default }.
  Proof.
    unfold FindWithDefault;
      intros A key default fmap;
      destruct (find key fmap) eqn:find;
      [ left; rewrite <- find_mapsto_iff in find | right ];
      eauto.
  Qed.

  Lemma Values_empty :
    forall {A}, Values (empty A) = [].
  Proof.
    intros;
      unfold Values;
      rewrite elements_empty;
      reflexivity.
  Qed.

  Definition GetValues {A: Type} (db: t A) : list A  :=
    List.map snd (elements db).

  Definition IndexedBy {A} projection tree :=
    forall key (value: A),
      MapsTo key value tree ->
      key = projection value.

  Lemma FindWithDefault_MapsTo :
    forall {A} default key (value: A) tree,
      MapsTo key value tree ->
      FindWithDefault key default tree = value.
  Proof.
    unfold FindWithDefault; intros ? ? ? ? ? maps_to.
    rewrite find_mapsto_iff in *.
    rewrite maps_to; trivial.
  Qed.

  Definition ValueFilter {A B: Type} (pred: B -> bool) :=
    (fun (key: A) (value: B) => pred value).

  Lemma ValueFilter_proper:
    forall (B: Type) (pred: B->bool),
      Proper (E.eq ==> eq ==> eq) (ValueFilter pred).
  Proof.
    unfold Proper; compute; intros; subst; trivial.
  Qed.

  Definition SameElements {A: Type} (seq: list A) (db: t A) :=
    SetEq seq (GetValues db).

  Lemma elements_iff :
    forall (elt : Type) (m : t elt) (x : key) (e : elt),
      MapsTo x e m <-> InA (eq_key_elt (elt:=elt)) (x, e) (elements (elt:=elt) m).
  Proof.
    intros; split;
      eauto using elements_1, elements_2.
  Qed.

  Lemma elements_iff_find :
    forall (elt : Type) (m : t elt) (x : key) (e : elt),
      find x m = Some e <-> InA (eq_key_elt (elt:=elt)) (x, e) (elements (elt:=elt) m).
  Proof.
    intros; rewrite <- elements_iff.
    rewrite find_mapsto_iff; reflexivity.
  Qed.

  Lemma elements_iff' :
    forall (elt : Type) (m : t elt) (xe : key * elt),
      MapsTo (fst xe) (snd xe) m <-> InA (eq_key_elt (elt:=elt)) xe (elements (elt:=elt) m).
  Proof.
    intros; rewrite elements_iff; destruct xe; reflexivity.
  Qed.

  Lemma elements_iff_find' :
    forall (elt : Type) (m : t elt) (xe : key * elt),
      find (fst xe) m = Some (snd xe) <-> InA (eq_key_elt (elt:=elt)) xe (elements (elt:=elt) m).
  Proof.
    intros; rewrite elements_iff_find; destruct xe; reflexivity.
  Qed.

  Lemma InA_In_snd :
    forall {A: Type} (k: key) (e: A) (l : list (key*A)),
      InA (eq_key_elt (elt:=A)) (k, e) l -> List.In e (List.map snd l).
  Proof.
    intros ? k e ? in_a;
      rewrite InA_alt, in_map_iff in *;
      destruct in_a as [(k', e') (eq0, ?)];
      destruct eq0; simpl in *;
        exists (k', e'); intuition.
  Qed.

  Lemma equiv_eq_key_elt :
    forall {A: Type}, Equivalence (eq_key_elt (elt := A)).
  Proof.
    unfold eq_key_elt;
      repeat constructor;
      simpl in *;
      intuition;
      eauto using E.eq_trans, eq_trans.
  Qed.

  Lemma equiv_eq_key :
    forall elt,
      Equivalence (eq_key (elt:=elt)).
  Proof.
    intros; unfold eq_key; split; intuition.
    unfold Transitive; firstorder.
    transitivity (fst y); trivial.
  Qed.

  Lemma InA_front_InA :
    forall elt,
    forall {item} front middle tail,
      InA (eq_key_elt (elt:=elt)) item front -> InA (eq_key_elt (elt:=elt)) item (front ++ middle :: tail).
  Proof.
    intros; intuition.
    rewrite InA_app_iff;
      [intuition | apply equiv_eq_key_elt .. ].
  Qed.

  Lemma InA_tail_InA :
    forall elt,
    forall {item} front middle tail,
      InA (eq_key_elt (elt:=elt)) item tail -> InA (eq_key_elt (elt:=elt)) item (front ++ middle :: tail).
  Proof.
    intros; intuition.
    rewrite InA_app_iff;
      [intuition | apply equiv_eq_key_elt .. ].
  Qed.

  Lemma InA_front_tail_InA :
    forall elt,
    forall {item} front middle tail,
      InA (eq_key_elt (elt:=elt)) item front \/ InA (eq_key_elt (elt:=elt)) item tail ->
      InA (eq_key_elt (elt:=elt)) item (front ++ middle :: tail).
  Proof.
    intros elt item front middle tail in_or;
      destruct in_or; eauto using InA_front_InA, InA_tail_InA.
  Qed.

  Lemma eq_stronger_than_eq_key_elt :
    forall {A: Type} x seq,
      InA eq x seq -> InA (eq_key_elt (elt:=A)) x seq.
  Proof.
    intros.
    apply In_InA.
    apply equiv_eq_key_elt.
    induction seq; simpl in *; inversion H; subst; eauto.
  Qed.

  Lemma in_elements_mapsto :
    forall {A: Type} k (e: A) (m: t A),
      List.In (k, e) (elements m) -> MapsTo k e m.
    intros;
      eauto using elements_2, In_InA, equiv_eq_key_elt.
  Qed.

  Lemma in_elements_after_map :
    forall {A B: Type} (proc: A -> B) (m: t A) (x: B),
      List.In x (List.map snd (elements (map proc m)))
      -> exists k pred, MapsTo k pred m /\ proc pred = x.
    intros ? ? ? ? ? in_map;
      rewrite in_map_iff in in_map;
      destruct in_map as [(k, e) (is_proc, in_elements)];
      apply in_elements_mapsto in in_elements;
      rewrite map_mapsto_iff in in_elements;
      destruct in_elements as [e_pred (is_pred, maps_to)];
      exists k; exists e_pred;
        subst; intuition.
  Qed.

  Lemma map_list_map_fmap:
    forall {A B: Type} m (proc: A -> B),
      SetEq (GetValues (map proc m)) (List.map proc (GetValues m)).
  Proof.
    unfold GetValues; split; intros.

    apply in_elements_after_map in H;
      destruct H as [k [predecessor (maps_to, is_predecessor)]];
      rewrite in_map_iff;
      exists predecessor;
      subst;
      intuition;
      apply (InA_In_snd k), elements_1;
      trivial.

    rewrite in_map_iff in H;
      destruct H as [x0 (?, H)];
      rewrite in_map_iff in H;
      destruct H as [x1 (is_pred, ?)].

    apply (InA_In_snd (fst x1));
      rewrite <- elements_mapsto_iff;
      apply map_mapsto_iff;
      exists x0;
      split;
      [ | apply in_elements_mapsto;
          rewrite <- is_pred, <- surjective_pairing ];
      subst;
      congruence.
  Qed.

  Lemma filter_list_filter_fmap :
    forall {A: Type} m pred,
      SetEq (List.filter pred (GetValues (A:=A) m)) (GetValues (filter (ValueFilter pred) m)).
  Proof.
    intros.
    unfold SetEq; intuition.
    unfold GetValues.

    rewrite filter_In in H.
    destruct H as [inL sat].
    unfold GetValues in inL.
    apply in_map_iff in inL.
    destruct inL as [x0 (ok, inL)].

    destruct x0.
    apply in_elements_mapsto in inL.
    subst.
    simpl.

    apply (InA_In_snd k).
    apply elements_mapsto_iff.
    rewrite filter_iff.
    intuition.

    eauto using ValueFilter_proper.

    unfold GetValues in *.
    rewrite filter_In.

    rewrite in_map_iff in H.
    destruct H as [(k, e) (is_snd, is_in)].

    apply in_elements_mapsto in is_in.

    rewrite filter_iff in is_in; eauto using ValueFilter_proper.

    destruct is_in as [maps_to sat].
    compute in sat.
    simpl in *.
    subst.
    intuition.

    rewrite elements_mapsto_iff in maps_to.
    apply (InA_In_snd k).
    trivial.
  Qed.

  Lemma map_modulo_equiv :
    forall {A B: Type} (db: t A) (seq: list A),
      SameElements seq db ->
      forall (proc: A -> B),
        SameElements (List.map proc seq) (map proc db).
  Proof.
    unfold SameElements; intros.
    rewrite (@map_modulo_SetEq _ _ _ (GetValues db)); trivial.
    clear H; clear seq.
    unfold SetEq.
    symmetry.
    apply map_list_map_fmap.
  Qed.

  Lemma MapsTo_snd :
    forall {A: Type} val tree,
      (exists key, MapsTo key val tree)
      <-> List.In val (List.map snd (elements (elt:=A) tree)).
  Proof.
    split;
      intro H;
      [
        destruct H as [key mapsto];
        apply (InA_In_snd key);
        apply elements_1
      |
      rewrite in_map_iff in H;
      destruct H as [(key, val') (eq_val_val', in_lst)];
      subst; simpl;
      exists key;
      apply in_elements_mapsto
      ]; trivial.
  Qed.

  Lemma MapsTo_In :
    forall {A: Type} key (val: A) tree,
      MapsTo key val tree -> In key tree.
  Proof.
    intros.
    rewrite elements_in_iff.
    rewrite elements_mapsto_iff in *.
    eauto.
  Qed.

  Lemma in_elements_after_add:
    forall {A: Type} key (added elem: A) tree,
      (List.In elem (GetValues (add key added tree))
       -> (elem = added \/ List.In elem (GetValues tree))).
  Proof.
    unfold GetValues;
      intros ? ? ? ? ? is_in;
      rewrite <- MapsTo_snd;
      rewrite <- MapsTo_snd in is_in.

    destruct is_in as [key' map_add];
      rewrite add_mapsto_iff in map_add;
      destruct map_add;
      [ left | right ]; intuition; eauto.
  Qed.

  Lemma in_elements_after_add':
    forall {A: Type} _key (added elem: A) tree,
      (~ In _key tree) ->
      (elem = added \/ List.In elem (GetValues tree))
      -> (List.In elem (GetValues (add _key added tree))).
  Proof.
    unfold GetValues;
      intros ? ? ? ? ? not_in is_in;
      rewrite <- MapsTo_snd;
      rewrite <- MapsTo_snd in is_in.

    setoid_rewrite add_mapsto_iff;
      destruct is_in as [eq | [_key' _key'_map]];
      [ exists _key
             | exists _key';
               right;
               split;
               [ intro Eeq;
                 apply MapsTo_In in _key'_map;
                 apply not_in;
                 rewrite (In_iff _ Eeq) | ]
      ]; intuition.
  Qed.

  Lemma in_elements_after_add_iff:
    forall {A: Type} key (added elem: A) tree,
      (~ In key tree) ->
      (List.In elem (GetValues (add key added tree))
       <-> (elem = added \/ List.In elem (GetValues tree))).
  Proof.
    intros;
      split;
      eauto using in_elements_after_add, in_elements_after_add'.
  Qed.

  Lemma In_MapsTo :
    forall A tree key,
      In key tree ->
      exists (value: A),
        (MapsTo key value tree /\ find key tree = Some value).
  Proof.
    intros A tree key H;
      apply in_find_iff in H;
      destruct (find key tree) as [value | ] eqn:eq_option;
      try rewrite <- find_mapsto_iff in eq_option;
      intuition eauto.
  Qed.

  Require Import Coq.Sorting.Permutation Fiat.Common.List.PermutationFacts.

  Lemma InA_mapsto_add {Value} :
    forall bag' kv k' (v' : Value),
      InA (@eq_key_elt _) kv (elements (add k' v' bag')) ->
      eq_key_elt kv (k', v') \/
      (~ E.eq (fst kv) k' /\
       InA (@eq_key_elt _) kv (elements bag')).
  Proof.
    intros.
    destruct kv as [k v]; apply elements_2 in H.
    apply add_mapsto_iff in H; intuition; subst;
      [left; split; simpl; eauto |
       right; eauto using elements_1].
  Qed.

  Lemma InA_mapsto_add' {Value} :
    forall bag' kv k' (v' : Value),
      (eq_key_elt kv (k', v') \/
       (~ E.eq (fst kv) k' /\
        InA (@eq_key_elt _) kv (elements bag')))
      -> InA (@eq_key_elt _) kv (elements (add k' v' bag')).
  Proof.
    intros; destruct kv as [k v]; apply elements_1;
      apply add_mapsto_iff; intuition;
        [destruct H0; eauto
        | right; intuition; apply elements_2; eauto].
  Qed.

  Lemma Permutation_InA_cons {Value} :
    forall l (l' : list (key * Value)),
      NoDupA (@eq_key _) l
      -> NoDupA (@eq_key _) l'
      -> (forall k v,
             InA (@eq_key_elt _) (k, v) l' <->
             (InA (@eq_key_elt _) (k, v) l))
      -> Permutation (List.map snd l')
                     (List.map snd l).
  Proof.
    induction l; intros.
    destruct l'.
    constructor.
    assert (InA (eq_key_elt (elt:=Value)) (fst p, snd p) []) as H2
                                                               by (eapply H1; left; split; reflexivity); inversion H2.
    destruct a as [k v].
    assert (InA (eq_key_elt (elt:=Value)) (k, v) l') as H2
                                                       by (eapply H1; econstructor; split; reflexivity).
    destruct (InA_split H2) as [l'1 [kv [l'2 [eq_kv eq_l]]]]; subst.
    repeat rewrite List.map_app; simpl.
    etransitivity.
    symmetry.
    apply Permutation_middle.
    destruct eq_kv; simpl in *; subst; constructor.
    rewrite <- List.map_app.
    eapply NoDupA_swap in H0; eauto using eqk_equiv.
    inversion H0; inversion H; subst; apply IHl; eauto.
    assert (forall (k0 : key) (v : Value),
               InA (eq_key_elt (elt:=Value)) (k0, v) (kv :: (l'1 ++ l'2)) <->
               InA (eq_key_elt (elt:=Value)) (k0, v) ((k, snd kv) :: l)) by
        (split; intros;
         [ eapply H1; eapply InA_app_cons_swap
         | eapply H1 in H4; eapply InA_app_cons_swap in H4 ]; eauto using eqke_equiv).
    split; intros.
    + generalize (proj1 (H4 k0 v) (InA_cons_tl _ H5)); intros.
      inversion H8; subst; eauto.
      destruct H12; simpl in *.
      elimtype False; apply H6.
      revert H5 H9 H3; clear; induction (l'1 ++ l'2); intros;
        inversion H5; subst;
          [ constructor; destruct H0; simpl in *; unfold eq_key;
            rewrite <- H3, <- H9; eauto
          | constructor 2; eauto ].
    + generalize (proj2 (H1 k0 v) (InA_cons_tl _ H5)); intros.
      eapply InA_app_cons_swap in H8; eauto using eqke_equiv.
      inversion H8; subst; eauto.
      destruct H12; simpl in *.
      elimtype False; apply H10.
      revert H5 H9 H3; clear; induction l; intros;
        inversion H5; subst;
          [ constructor; destruct H0; simpl in *; unfold eq_key;
            simpl; rewrite <- H, H9; eauto
          | constructor 2; eauto ].
  Qed.

  Lemma FMap_Insert_fold_add {Value}
    : forall (f : Value -> Value) (bag : t Value) bag',
      (forall (k : key), InA E.eq k (List.map fst (elements bag))
                         -> ~ In k bag')
      -> Permutation
           (List.map snd (elements (fold (fun k bag'' r' => add k (f bag'') r')
                                         bag bag')))
           (List.map snd ((List.map (fun kv => (fst kv, f (snd kv))) (elements bag)) ++ elements bag')).
  Proof.
    intros.
    intros; rewrite fold_1.
    generalize (elements_3w bag) as NoDupl.
    revert bag' H; induction (elements bag); simpl; intros.
    reflexivity.
    rewrite IHl, Permutation_cons_app;
      try (rewrite List.map_app; reflexivity).
    rewrite List.map_app, List.map_map.
    apply Permutation_app; try reflexivity.
    apply (Permutation_InA_cons ((fst a, f (snd a)) :: elements bag'));
      eauto using elements_3w.
    econstructor; eauto using elements_3w.
    unfold not; intros; eapply (H (fst a));
      [ constructor; reflexivity
      | eapply elements_in_iff; revert H0; clear; intro; induction H0].
    repeat econstructor; eauto.
    destruct IHInA; econstructor; econstructor 2; eauto.
    split; intros.
    apply InA_mapsto_add in H0; intuition.
    inversion H0; subst; eapply InA_mapsto_add'; intuition.
    right; intuition.
    eapply H; simpl.
    econstructor; reflexivity.
    eapply elements_in_iff; revert H2 H1; clear; intros;
      induction H2.
    destruct H; repeat econstructor; eauto.
    destruct IHInA; econstructor; econstructor 2; eauto.
    unfold not; intros.
    apply add_in_iff in H1; destruct H1.
    inversion NoDupl; subst; rewrite <- H1 in H0; eapply H4.
    revert H0; clear; induction l; intros; inversion H0; subst.
    constructor; eauto.
    econstructor 2; eauto.
    eapply H; eauto.
    inversion NoDupl; eauto.
  Qed.

  Lemma FMap_fold_add_MapsTo_NIn {Value}
    : forall (f : Value -> Value) l k v bag',
      ~ InA (@eq_key _) (k,v) (List.map (fun kv => (fst kv, f (snd kv))) l)
      -> (MapsTo k v (fold_left (fun a p => add (fst p) (f (snd p)) a) l bag')
          <-> MapsTo k v bag').
  Proof.
    unfold eq_key; intros; revert k v bag' H.
    induction l; simpl; intros; split; eauto.
    intros; assert (MapsTo k v (add (fst a) (f (snd a)) bag')).
    apply IHl;
      [unfold not; intros; apply H; constructor 2; eauto
      | eauto].
    apply add_mapsto_iff in H1; intuition; subst.
    intros; eapply IHl; eauto using add_2.
  Qed.

  Lemma FMap_fold_add_MapsTo_In {Value}
    : forall (f : Value -> Value) (bag : t Value) bag' k v,
      InA (@eq_key_elt _) (k,v) (List.map (fun kv => (fst kv, f (snd kv))) (elements bag))
      -> MapsTo k v
                (fold (fun k bag'' r' => add k (f bag'') r') bag bag').
  Proof.
    intros; rewrite fold_1 in *; revert k v bag' H;
      generalize (elements_3w bag); induction (elements bag);
        intros; inversion H0; inversion H; subst; simpl in *; eauto.
    destruct H2; simpl in *; subst; rewrite H1.
    apply FMap_fold_add_MapsTo_NIn; eauto.
    unfold not, eq_key in *; intros; apply H6; revert H2; clear;
      induction l; simpl in *; intros; inversion H2; subst; eauto.
    apply add_1; reflexivity.
  Qed.

  Lemma FMap_Insert_fold_add_MapsTo {Value}
    : forall (f : Value -> Value) (bag : t Value) bag' k v,
      MapsTo k v
             (fold (fun k bag'' r' => add k (f bag'') r') bag bag') ->
      MapsTo k v bag' \/
      InA (@eq_key_elt _) (k,v) (List.map (fun kv => (fst kv, f (snd kv))) (elements bag)).
  Proof.
    intros; rewrite fold_1 in *; revert bag' H;
      induction (elements bag); simpl in *; eauto; intros.
    apply IHl in H; intuition.
    apply add_mapsto_iff in H0; intuition; subst.
    right; constructor; split; eauto.
  Qed.

  Lemma InA_Map {A B} eqB
    : forall (f : A -> B) (b : B) (l : list A),
      InA eqB b (List.map f l) <->
      exists a, eqB b (f a) /\ List.In a l.
  Proof.
    split; induction l; simpl; intros; inversion H; subst;
      eauto. destruct (IHl H1) as [a' [In_a eq_b]]; eauto.
    intuition.
    intuition; subst.
    constructor; eauto.
    constructor 2; eauto.
  Qed.

  Lemma FMap_Insert_fold_add_map_eq {Value}
    : forall (f : Value -> Value) (bag : t Value),
      Equal
        (fold (fun k bag'' r' => add k (f bag'') r') bag (empty _))
        (map f bag).
  Proof.
    unfold Equal.
    intros; case_eq (find y
                          (fold
                             (fun (k : key) (bag'' : Value) (r' : t Value) => add k (f bag'') r')
                             bag (empty Value)));
    intros; case_eq (find y (map f bag)); intros; eauto.
    - apply find_2 in H; apply find_2 in H0.
      apply FMap_Insert_fold_add_MapsTo in H; destruct H.
      elimtype False; apply empty_mapsto_iff in H; eauto.
      apply map_mapsto_iff in H0; destruct H0 as [a [eq_a MapsTo_y]]; subst.
      generalize (elements_3w bag); apply elements_1 in MapsTo_y;
        induction MapsTo_y; intros.
      + inversion H1; subst; destruct H0; simpl in *; subst.
        inversion H; subst;
          [destruct H3; simpl in *; subst; eauto
          | elimtype False; apply H4; revert H0 H3; clear; induction l;
            intros; inversion H3; subst; unfold eq_key in *].
        destruct H1; simpl in *; subst; constructor; eauto.
        constructor 2; eauto.
      + inversion H0; subst; eapply IHMapsTo_y; eauto.
        inversion H; subst; eauto.
        destruct H2; simpl in *; subst.
        elimtype False; apply H3; revert H1 MapsTo_y; clear; induction l;
          intros; inversion MapsTo_y; subst; unfold eq_key in *.
        destruct H0; simpl in *; subst; constructor; eauto.
        constructor 2; eauto.
    - apply find_2 in H; apply FMap_Insert_fold_add_MapsTo in H; destruct H.
      elimtype False; apply empty_mapsto_iff in H; eauto.
      apply InA_Map in H; destruct H as [[k v'] [eq_k In_k]]; simpl in *.
      destruct eq_k; simpl in *; rewrite H in H0.
      apply not_find_in_iff in H0; elimtype False; eapply H0.
      apply map_in_iff; exists v'; apply elements_2.
      apply InA_alt; eexists; repeat split; eauto.
    - apply find_2 in H0; apply not_find_in_iff in H.
      apply map_mapsto_iff in H0; destruct H0 as [k [k_eq MapsTo_k]]; subst.
      elimtype False; apply H.
      econstructor 1 with (x := f k); apply FMap_fold_add_MapsTo_In.
      apply elements_1 in MapsTo_k; revert MapsTo_k; clear;
        intro; induction MapsTo_k; simpl.
      repeat constructor; destruct H; simpl in *; subst; eauto.
      constructor 2; eauto.
  Qed.

  (* Partitioning a finite map [m] with a function that respects key and value equality
       will produce a pair of maps equivalent to [m]. *)
  Lemma MapsTo_partition_fst:
    forall TValue f k v (m: t TValue),
      Proper (E.eq ==> eq ==> eq) f ->
      MapsTo k v (fst (partition f m)) ->
      MapsTo k v m.
  Proof.
    intros * ? maps_to.
    rewrite partition_iff_1 with (f := f) (m := m) in maps_to;
      intuition.
  Qed.

  Lemma MapsTo_partition_snd:
    forall TValue f k v (m: t TValue),
      Proper (E.eq ==> eq ==> eq) f ->
      MapsTo k v (snd (partition f m)) ->
      MapsTo k v m.
  Proof.
    intros * ? maps_to.
    rewrite partition_iff_2 with (f := f) (m := m) in maps_to;
      intuition.
  Qed.

  (* A restatement of the specification of the [Partition] relation. *)
  Lemma partition_Partition_simple :
    forall TValue f,
      Proper (E.eq ==> eq ==> eq) f ->
      forall (m: t TValue),
        Partition m
                  (fst (partition f m))
                  (snd (partition f m)).
  Proof.
    intros.
    eapply partition_Partition; eauto.
  Qed.

  (* folding a function [f] which respects key, value, and accumulator
       equivalences over two equivalent maps [m1] [m2] will produce
       equivalent values. *)
  Lemma fold_Equal_simpl :
    forall {TValue TAcc} {eqA: TAcc -> TAcc -> Prop} {m1 m2: t TValue} {f} {init: TAcc},
      Equal m1 m2 ->
      Equivalence eqA ->
      Proper (E.eq ==> eq ==> eqA ==> eqA) f ->
      transpose_neqkey eqA f ->
      eqA (fold f m1 init) (fold f m2 init).
  Proof.
    intros.
    apply fold_Equal; assumption.
  Qed.

  Lemma fold_empty :
    forall {TValue TAcc} f (default: TAcc),
      fold f (empty TValue) default = default.
  Proof.
    intros;
      apply fold_Empty;
      eauto using empty_1.
  Qed.

  (* Adding the same key [k] to equivalent maps will produce equivalent maps*)
  Lemma add_Equal_simple :
    forall {TValue} {m1 m2: t TValue},
      Equal m1 m2 ->
      forall k v,
        Equal (add k v m1) (add k v m2).
  Proof.
    intros.
    apply add_m; eauto.
  Qed.

  (* Adding a key [k] overwrites previous values of [k] in a map. *)
  Lemma multiple_adds :
    forall {TValue} k v1 v2 (m: t TValue),
      Equal (add k v2 (add k v1 m))
            (add k v2 m).
  Proof.
    intros.
    unfold Equal.
    intros k'.
    destruct (E.eq_dec k k').

    rewrite !add_eq_o; eauto.
    rewrite !add_neq_o; eauto.
  Qed.

  Lemma Values_fold_Proper :
    forall {A},
      Proper (E.eq ==> eq ==> Permutation (A:=A) ==> Permutation (A:=A))
             (fun (_ : key) (val : A) (acc : list A) => val :: acc).
  Proof.
    unfold Proper, respectful; intros.
    subst; eauto.
  Qed.

  Lemma Values_fold_transpose_neqkey :
    forall {A},
      transpose_neqkey (Permutation (A:=A))
                       (fun (_ : key) (val : A) (acc : list A) => val :: acc).
  Proof.
    unfold transpose_neqkey; intros; constructor.
  Qed.

  Lemma empty_In :
    forall {TValue} k,
      ~ In k (empty TValue).
  Proof.
    intros; rewrite empty_in_iff; tauto.
  Qed.

  Lemma fold_right_map :
    forall {A B} f seq,
      @List.fold_right (list B) A (fun b a => f b :: a) [] seq = List.map f seq.
  Proof.
    intros; induction seq; simpl; try rewrite IHseq; reflexivity.
  Qed.

  Lemma fold_left_map :
    forall {A B} f seq,
      @List.fold_left (list B) A (fun a b => f b :: a) seq [] = List.map f (rev seq).
  Proof.
    intros; rewrite <- fold_left_rev_right; apply fold_right_map.
  Qed.

  Lemma Values_fold_perm :
    forall {TValues} (m: t TValues),
      Permutation
        (Values m)
        (fold (fun key val acc => cons val acc) m []).
  Proof.
    intros.
    rewrite fold_1.

    rewrite fold_left_map.
    unfold Values.

    rewrite map_rev.
    apply Permutation_rev.
  Qed.

  Lemma Values_fold_eq :
    forall {TValues} (m: t TValues),
      (Values m) =
      (rev (fold (fun key val acc => cons val acc) m [])).
  Proof.
    intros.
    rewrite fold_1.

    rewrite fold_left_map.
    unfold Values.

    rewrite map_rev.
    rewrite rev_involutive; reflexivity.
  Qed.

  Lemma map_fold :
    forall {A B TValue} f g m init,
      (@List.map A B g
                 (fold
                    (fun k (v: TValue) acc =>
                       f k v :: acc) m init)) =
      (fold (fun k v acc => g (f k v) :: acc) m (List.map g init)).
  Proof.
    intros until m; setoid_rewrite fold_1.
    setoid_rewrite <- fold_left_rev_right; simpl.
    induction (elements m) as [ | ? ? IH ]; simpl; trivial.
    setoid_rewrite fold_right_app.
    setoid_rewrite IH; simpl.
    reflexivity.
  Qed.

  Lemma elements_fold_eq :
    forall {TValues} (m: t TValues),
      (elements m) =
      (rev (fold (fun key val acc => cons (key, val) acc) m [])).
  Proof.
    intros.
    rewrite fold_1.

    assert ((fold_left
               (fun (a : list (key * TValues)) (p : key * TValues) =>
                  (fst p, snd p) :: a) (elements m) [])
            = (fold_left
                 (fun (a : list (key * TValues)) (p : key * TValues) =>
                    p :: a) (elements m) []))
      by (f_equal; repeat (apply functional_extensionality; intros);
          rewrite <- surjective_pairing; reflexivity).

    rewrite H.

    setoid_rewrite fold_left_id.
    rewrite rev_involutive; reflexivity.
  Qed.

  Lemma elements_fold_perm :
    forall {TValues} (m: t TValues),
      Permutation
        (elements m)
        (fold (fun key val acc => cons (key, val) acc) m []).
  Proof.
    intros.
    rewrite fold_1.

    assert ((fold_left
               (fun (a : list (key * TValues)) (p : key * TValues) =>
                  (fst p, snd p) :: a) (elements m) [])
            = (fold_left
                 (fun (a : list (key * TValues)) (p : key * TValues) =>
                    p :: a) (elements m) []))
      by (f_equal; repeat (apply functional_extensionality; intros);
          rewrite <- surjective_pairing; reflexivity).

    rewrite H.

    setoid_rewrite fold_left_id.
    apply Permutation_rev.
  Qed.

  Lemma values_add_not_in {A : Type} :
    forall (m: t A),
    forall k v,
      ~ In k m ->
      Permutation
        (Values (add k v m))
        (v :: Values m).
  Proof.
    intros.
    unfold Values.
    rewrite elements_fold_eq.

    rewrite map_rev.
    rewrite map_fold; simpl.
    etransitivity.
    symmetry.
    etransitivity; [ | apply Permutation_rev].
    symmetry.
    apply (fold_add (elt := A) (eqA := @Permutation A )); eauto.

    apply Permutation_Equivalence.

    unfold Proper, respectful; intros; simpl;
      subst; apply Permutation_cons; try reflexivity; assumption.

    unfold transpose_neqkey; intros; simpl;
      constructor.

    rewrite fold_1.
    rewrite fold_left_map.
    econstructor.
    rewrite Permutation_rev.

    rewrite map_rev.
    rewrite rev_involutive.
    reflexivity.
  Qed.

  (* This should be simplified by the switch to Permutations.

  Lemma EnsembleListEquivalence_fmap_add_filtered :
    forall {A: Type} (cond : A -> Prop) ensemble key tree added,
      cond added ->
      (~ In (elt:=A) key tree) ->
      EnsembleListEquivalence
        (fun x => Ensembles.In _ ensemble x /\ cond x)
        (GetValues tree) ->
      EnsembleListEquivalence
        (fun x => (x = added \/ Ensembles.In _ ensemble x) /\ cond x)
        (GetValues (add key added tree)).
  Proof.
    unfold EnsembleListEquivalence;
    repeat split; intros;
    unfold Ensembles.In in *; simpl in *; intuition.

    apply in_elements_after_add'; trivial.
    rewrite <- H1.
    intuition.

    apply in_elements_after_add in H2.
    destruct H2; intuition.
    subst; intuition.
    rewrite <- H1 in H2; intuition.
    rewrite <- H1 in H2; intuition.
  Qed. *)

  Lemma fold_pair {A B A' B' V} :
    forall (m : t V) (ab : A * B) (f : TKey -> V -> (A' * B')) fa fb,
      @fold V (A * B) (fun k (v : V) (ab : A * B) =>
                         let (a, b) := f k v in
                         let (a', b') := ab in
                         (fa k a a', fb k b b'))
            m ab
      = (fold (fun k m (a' : A) =>
                 fa k (fst (f k m)) a') m (fst ab),
         fold (fun k m (b' : B) =>
                 fb k (snd (f k m)) b')
              m (snd ab)).
  Proof.
    intros; repeat rewrite fold_1; revert ab; induction (elements m);
      destruct ab; simpl; eauto.
    destruct a; simpl; destruct (f k v);
      rewrite IHl; reflexivity.
  Qed.

  Lemma fold_over_Values :
    forall {TValue TAcc} (m: t TValue) f g (init: TAcc),
      (forall k v acc, f k v acc = g acc v) ->
      fold f m init = fold_left g (Values m) init.
  Proof.
    intros * equiv.
    rewrite fold_1.
    unfold Values.
    rewrite <- fold_map.
    revert init; induction (elements m); simpl; eauto.
    intros; rewrite IHl, equiv; reflexivity.
  Qed.

  Lemma Permutation_map_Values {A B} :
    forall (f : A -> B) m,
      Permutation
        (List.map f (Values m))
        (Values (map f m)).
  Proof.
    unfold Values; intros.
    rewrite map_snd.
    apply Permutation_InA_cons; eauto using elements_3w.
    - pose proof (elements_3w m) as NoDupM.
      induction NoDupM; simpl in *; simpl; constructor; eauto.
      unfold not; intros; apply H; clear NoDupM IHNoDupM H;
        induction l; simpl in *; inversion H0; subst; eauto.
    - split; intros.
      apply elements_1.
      rewrite InA_Map in H; destruct H as [[k' v'] [eq_k In_k]];
        destruct eq_k; simpl in *; subst.
      rewrite H; eauto using elements_2, map_1, In_InA, equiv_eq_key_elt.
      rewrite InA_Map.
      apply elements_2 in H.
      apply map_mapsto_iff in H; destruct H as [a [a_eq MapsTo_k]]; subst.
      apply elements_1 in MapsTo_k.
      rewrite InA_alt in MapsTo_k.
      destruct MapsTo_k as [[k' a'] [eq_k In_k]].
      eexists; split; eauto.
      destruct eq_k; simpl in *; subst; constructor; eauto.
  Qed.

  Lemma Permutation_filter_Values {B} :
    forall (f : key -> B -> bool) m
           (Proper_f : Proper (E.eq ==> eq ==> eq) f),
      Permutation
        (Values (filter f m))
        (List.map snd (List.filter (fun kv => f (fst kv) (snd kv)) (elements m))).
  Proof.
    unfold Values; intros.
    apply Permutation_InA_cons; eauto using elements_3w.
    - pose proof (elements_3w m) as NoDupM.
      induction NoDupM; simpl in *; simpl; try constructor.
      case_eq (f (fst x) (snd x)); simpl; eauto.
      intros; constructor; eauto.
      unfold not; intros; apply H; clear NoDupM IHNoDupM H;
        induction l; simpl in *.
      inversion H0; subst; eauto.
      case_eq (f (fst a) (snd a)); intros; rewrite H in *; eauto.
      inversion H1; subst.
      constructor; eauto.
      constructor 2; eauto.
    - intros; rewrite <- elements_mapsto_iff, filter_iff; eauto;
        intuition.
      + rewrite elements_mapsto_iff in H0; induction H0.
        * simpl; destruct H; rewrite Proper_f in H1; eauto;
            rewrite H1; repeat constructor; eauto.
        * simpl; destruct (f (fst y) (snd y)); simpl; eauto.
      + rewrite elements_mapsto_iff; induction (elements m);
          simpl in *.
        * inversion H.
        * case_eq (f (fst a) (snd a)); intros; rewrite H0 in H.
          inversion H; subst.
          constructor; eauto.
          constructor 2; eauto.
          constructor 2; eauto.
      + induction (elements m); simpl in *.
        * inversion H.
        * case_eq (f (fst a) (snd a)); intros; rewrite H0 in H; eauto.
          inversion H; subst.
          destruct H2; rewrite Proper_f in H0; eauto.
          eauto.
  Qed.

  Lemma Permutation_Partition_App {Value}:
    forall (m m1 m2 : t Value),
      Partition m m1 m2 ->
      Permutation (Values m) (Values m1 ++ Values m2).
  Proof.
    unfold Partition; intros; intuition.
    unfold Values; rewrite <- List.map_app.
    eapply Permutation_InA_cons; eauto using elements_3w.
    eapply NoDupA_app; eauto using elements_3w, equiv_eq_key.
    intros; destruct x as [k v]; eapply (H0 k).
    apply InA_alt in H; destruct H; apply InA_alt in H2; destruct H2;
      intuition; unfold eq_key in *; simpl in *.
    destruct x; simpl in *; rewrite H3; econstructor;
      apply elements_2; eauto; apply In_InA; eauto using equiv_eq_key_elt.
    destruct x0; simpl in *; rewrite H; econstructor;
      apply elements_2; eauto; apply In_InA; eauto using equiv_eq_key_elt.
    intros; rewrite InA_app_iff by eauto using equiv_eq_key_elt;
      intuition.
    apply elements_2 in H; rewrite H1 in H; intuition;
      eauto using elements_1.
    apply elements_1; rewrite H1; eauto using elements_2.
    apply elements_1; rewrite H1; eauto using elements_2.
  Qed.

  Corollary Permutation_partition {Value}:
    forall f (m : t Value),
      (Proper (E.eq ==> eq ==> eq) f)
      -> Permutation (Values m)
                     (Values (fst (partition f m)) ++ Values (snd (partition f m))).
  Proof.
    intros; eauto using Permutation_Partition_App,
            partition_Partition_simple.
  Qed.

  Lemma map_add {A B}:
    forall (f : A -> B) m k v,
      Equal (map f (add k v m))
            (add k (f v) (map f m)).
  Proof.
    unfold Equal; intros; case_eq (find y (add k (f v) (map f m)));
      case_eq (find y (map f (add k v m))); intros; eauto.
    - rewrite <- find_mapsto_iff in H, H0.
      rewrite map_mapsto_iff in H; destruct H as [a [b_eq In_b]]; subst.
      rewrite add_mapsto_iff in H0, In_b; intuition; subst; eauto.
      rewrite map_mapsto_iff in H3; destruct H3 as [a' [b_eq' In_b']]; subst.
      rewrite find_mapsto_iff in In_b', H2; congruence.
    - rewrite <- find_mapsto_iff in H0.
      rewrite <- not_find_in_iff in H; exfalso; apply H.
      rewrite add_mapsto_iff in H0; intuition; subst; eauto.
      rewrite H0, map_in_iff, add_in_iff; eauto.
      rewrite map_mapsto_iff in H2; destruct H2 as [a [b_eq In_b]]; subst.
      rewrite map_in_iff, add_in_iff; right; econstructor; eauto.
    - rewrite <- find_mapsto_iff in H.
      rewrite <- not_find_in_iff in H0; exfalso; apply H0.
      rewrite map_mapsto_iff in H; destruct H as [a [b_eq In_b]]; subst.
      rewrite add_mapsto_iff in In_b; intuition; subst; eauto.
      rewrite H1, add_in_iff; eauto.
      rewrite add_in_iff, map_in_iff; right; econstructor; eauto.
  Qed.

  Lemma Equal_elements {A} :
    forall m1 m2,
      Equal m1 m2
      -> forall k (a : A), (InA (@eq_key_elt _) (k, a) (elements m1)
                            <-> InA (@eq_key_elt _) (k, a) (elements m2)).
  Proof.
    unfold Equal; split; intros;
      rewrite <- elements_mapsto_iff, find_mapsto_iff in H0;
      rewrite <- elements_mapsto_iff, find_mapsto_iff; congruence.
  Qed.

  Add Parametric Morphism {A} :
    (@Values A)
      with signature (Equal ==> @Permutation A)
        as Permutation_Equal_Values.
  Proof.
    intros; unfold Values.
    eapply Permutation_InA_cons; eauto using elements_3w, Equal_elements.
  Qed.

  Lemma elements_in_iff' :
    forall (elt : Type) (m : t elt) x,
      In x m <->
      exists v, InA (eq_key (elt:=elt)) (x, v) (elements m) .
  Proof.
    split; rewrite elements_in_iff; intros.
    destruct H; induction H.
    destruct H; eexists x0; econstructor; eauto.
    destruct IHInA; econstructor; econstructor 2; eassumption.
    destruct H; induction H.
    eexists; repeat econstructor; simpl; eauto.
    destruct IHInA; eexists; econstructor 2; eauto.
  Qed.

  Corollary elements_in_if' :
    forall (elt : Type) (m : t elt) x v,
      InA (eq_key (elt:=elt)) (x, v) (elements m) ->
      In x m.
  Proof.
    intros; eapply elements_in_iff'; eauto.
  Qed.

  Definition KeyBasedPartitioningFunction BagType reference :=
    fun key (_: BagType) => if E.eq_dec key reference then true else false.

  Lemma KeyBasedPartitioningFunction_Proper :
    forall BagType reference,
      Proper (E.eq ==> eq ==> eq) (KeyBasedPartitioningFunction BagType reference).
  Proof.
    intros;
      unfold KeyBasedPartitioningFunction, Proper, respectful; intros x y E_eq **; subst;
        destruct (F.eq_dec x _), (F.eq_dec y _); rewrite E_eq in *; intuition.
  Qed.

  Lemma negb_KeyBasedPartitioningFunction_Proper :
    forall BagType reference,
      Proper (E.eq ==> eq ==> eq)
             (fun k e => negb (KeyBasedPartitioningFunction BagType reference k e)).
  Proof.
    intros;
      unfold KeyBasedPartitioningFunction, Proper, respectful; intros x y E_eq **; subst;
        destruct (F.eq_dec x _), (F.eq_dec y _); rewrite E_eq in *; intuition.
  Qed.

  Lemma eq_dec_refl :
    forall x,
      (if E.eq_dec x x then true else false) = true.
  Proof.
    intros; destruct (E.eq_dec _ _); eauto using E.eq_refl.
  Qed.

  Lemma eq_dec_comm :
    forall x y,
      (if E.eq_dec x y then true else false) = (if E.eq_dec y x then true else false).
  Proof.
    intros; destruct (E.eq_dec x y), (E.eq_dec y x); intuition.
  Qed.

  Lemma KeyBasedPartitioningFunction_eq_true :
    forall TValue k k' v,
      E.eq k k' <->
      KeyBasedPartitioningFunction TValue k k' v = true.
  Proof.
    intros; unfold KeyBasedPartitioningFunction; destruct (E.eq_dec _ _); intuition.
  Qed.

  Lemma KeyBasedPartitioningFunction_eq_false :
    forall TValue k k' v,
      ~ E.eq k k' <->
      KeyBasedPartitioningFunction TValue k k' v = false.
  Proof.
    intros; unfold KeyBasedPartitioningFunction; destruct (E.eq_dec _ _); intuition.
  Qed.

  Lemma KeyBasedPartitioningFunction_refl :
    forall TValue k k' v,
      KeyBasedPartitioningFunction TValue k k' v = KeyBasedPartitioningFunction TValue k' k v.
  Proof.
    intros; unfold KeyBasedPartitioningFunction; rewrite eq_dec_comm; reflexivity.
  Qed.

  (* The value [v] mapped to by [k] is the unique value [k] maps to. *)
  Lemma KeyBasedPartition_fst_singleton :
    forall {TValue} k v (m: t TValue),
      MapsTo k v m ->
      Equal (fst (partition (KeyBasedPartitioningFunction TValue k) m)) (add k v (empty TValue)).
  Proof.

    intros.
    symmetry.
    unfold Equal; intro key.

    destruct (E.eq_dec key k) as [ eq_k_proj | neq_k_proj ].

    rewrite eq_k_proj;
      rewrite add_eq_o by eauto;
      symmetry; rewrite <- find_mapsto_iff;
        rewrite partition_iff_1 with (f := KeyBasedPartitioningFunction TValue k) (m := m);
        intuition (try rewrite <- KeyBasedPartitioningFunction_eq_true;
                   eauto using E.eq_refl, KeyBasedPartitioningFunction_Proper).

    rewrite add_neq_o by eauto.
    rewrite empty_o.
    destruct (find key _) eqn:eqfind';
      [ exfalso | eauto ].
    rewrite <- find_mapsto_iff in eqfind'.
    rewrite partition_iff_1 with (f := KeyBasedPartitioningFunction TValue k) (m := m) in eqfind'.
    destruct eqfind' as (maps_to & kvpf_true).
    apply neq_k_proj.
    erewrite KeyBasedPartitioningFunction_eq_true.
    rewrite KeyBasedPartitioningFunction_refl.
    eauto.
    eauto using KeyBasedPartitioningFunction_Proper.
    reflexivity.
  Qed.

  Lemma KeyBasedPartition_fst_singleton_None :
    forall {TValue} k (m: t TValue),
      ~ In k m ->
      Equal (fst (partition (KeyBasedPartitioningFunction TValue k) m)) (empty TValue).
  Proof.

    intros.
    symmetry.
    unfold Equal; intro key.
    rewrite empty_o; symmetry.
    rewrite <- not_find_in_iff; unfold not; intros.
    apply H.
    destruct H0 as [v H0]; exists v.
    unfold partition in H0; simpl in H0.
    apply filter_iff in H0; eauto.
    intuition eauto.
    unfold KeyBasedPartitioningFunction in H2;
      find_if_inside; try discriminate.
    rewrite <- e; eauto.
    eapply KeyBasedPartitioningFunction_Proper.
  Qed.

  (* If [k'] maps to a value in the first half of a map partitioned on [k],
       it is equivalent to [k]. *)
  Lemma MapsTo_KeyBasedPartition_fst :
    forall {TValue} k k' v (m: t TValue),
      MapsTo k' v (fst (partition (KeyBasedPartitioningFunction TValue k) m)) ->
      E.eq k k'.
  Proof.
    intros * maps_to.
    rewrite partition_iff_1
    with (f := KeyBasedPartitioningFunction TValue k) (m := m)
      in maps_to; eauto using KeyBasedPartitioningFunction_Proper.
    destruct maps_to as (_ & kbpf_true).
    rewrite <- KeyBasedPartitioningFunction_eq_true in kbpf_true.
    trivial.
  Qed.

  Lemma In_KeyBasedPartition_fst :
    forall {TValue} k k' (m: t TValue),
      In k' (fst (partition (KeyBasedPartitioningFunction TValue k) m)) ->
      E.eq k k'.
  Proof.
    intros * in_singleton.
    apply In_MapsTo in in_singleton.
    destruct in_singleton as [ val (maps_to & _) ].
    eapply MapsTo_KeyBasedPartition_fst; eauto.
  Qed.

  (* If [k'] maps to a value in the second half of a map partitioned on [k],
       it is *not* equivalent to [k]. *)
  Lemma MapsTo_KeyBasedPartition_snd :
    forall {TValue} k k' v (m: t TValue),
      MapsTo k' v (snd (partition (KeyBasedPartitioningFunction TValue k) m)) ->
      ~ E.eq k k'.
  Proof.
    intros * maps_to.
    rewrite partition_iff_2
    with (f := KeyBasedPartitioningFunction TValue k) (m := m)
      in maps_to; eauto using KeyBasedPartitioningFunction_Proper.
    destruct maps_to as (_ & kbpf_false).
    rewrite <- KeyBasedPartitioningFunction_eq_false in kbpf_false.
    trivial.
  Qed.

  Lemma In_KeyBasedPartition_snd :
    forall {TValue} k k' (m: t TValue),
      In k' (snd (partition (KeyBasedPartitioningFunction TValue k) m)) ->
      ~ E.eq k k'.
  Proof.
    intros * in_falses.
    apply In_MapsTo in in_falses.
    destruct in_falses as [ val ( maps_to' & _ ) ].
    eapply MapsTo_KeyBasedPartition_snd; eauto.
  Qed.

  (* Paritioning a finite map [m] augmented with a key [k] over [k]
       will produce a map containing just [k] and a map equivalent to [m]. *)
  Lemma partition_after_KeyBasedPartition_and_add :
    forall {TValue} k v' (m: t TValue),
      Partition (add k v' m)
                (add k v' (fst (partition (KeyBasedPartitioningFunction TValue k) m)))
                (snd (partition (KeyBasedPartitioningFunction TValue k) m)).
  Proof.
    unfold Partition.
    split.

    {
      unfold Disjoint.
      intros key (in_modified & in_unmodified).
      rewrite add_in_iff in in_modified.

      assert (E.eq k key)
        by (
            destruct in_modified;
            [ assumption | eapply In_KeyBasedPartition_fst; eauto ]
          ); clear in_modified.

      apply In_KeyBasedPartition_snd in in_unmodified.

      intuition.
    }

    split; intros * maps_to'.
    rewrite add_mapsto_iff in maps_to'.
    destruct maps_to' as [ (keq & veq) | (kneq & maps_to') ]; subst.

    left;
      apply add_1; eauto.
    right;
      rewrite partition_iff_2
      with (f := KeyBasedPartitioningFunction TValue k) (m := m)
      by (eauto using KeyBasedPartitioningFunction_Proper);
      rewrite <- KeyBasedPartitioningFunction_eq_false;
      intuition.

    destruct maps_to' as [ maps_to' | maps_to' ].

    rewrite add_mapsto_iff in maps_to';
      destruct maps_to' as [ (keq & veq) | (kneq & maps_to') ];
      [ subst; apply add_1; assumption | ].

    exfalso.
    apply MapsTo_KeyBasedPartition_fst in maps_to'.
    intuition.

    pose proof maps_to'.
    apply MapsTo_KeyBasedPartition_snd in maps_to'.
    apply add_2;
      [ assumption | eapply MapsTo_partition_snd; eauto using KeyBasedPartitioningFunction_Proper ].
  Qed.

  Lemma filter_false_eq_empty
    : forall m,
      Equal (filter
               (fun (_ : key) (_ : list nat) => false) m)
            (empty _).
  Proof.
    unfold filter; simpl.
    intros; rewrite fold_1;
      induction (elements m); simpl; eauto.
    reflexivity.
  Qed.

  Lemma fold_Equal_acc_ :
    forall {TValue TAcc} {eqA: TAcc -> TAcc -> Prop} {m1 : t TValue} {f} {init init': TAcc},
      eqA init init' ->
      Equivalence eqA ->
      Proper (E.eq ==> eq ==> eqA ==> eqA) f ->
      transpose_neqkey eqA f ->
      eqA (fold f m1 init) (fold f m1 init').
  Proof.
    intros.
    rewrite fold_Equal; eauto; try reflexivity.
    rewrite !fold_1.
    generalize H1 H2 init init' H; clear.
    induction (elements m1); simpl; intros; eauto.
    eapply IHl; eauto.
    eapply H1; eauto.
  Qed.

  Lemma Proper_add
        elt
    : Proper (E.eq ==> eq ==> Equal ==> Equal)
             (add (elt:=elt)).
  Proof.
    unfold Proper, respectful; intros; eauto using add_m.
  Qed.

  Lemma add_transpose_neqkey
        elt
    : transpose_neqkey (@Equal elt)
                       (@add elt )
  .
  Proof.
    unfold transpose_neqkey; intros.
    eapply Equal_mapsto_iff; split; intros.
    - rewrite add_mapsto_iff in *; intuition; subst.
      destruct (E.eq_dec k0 k'); intuition; eauto.
      rewrite e in H0; intuition.
      rewrite add_mapsto_iff in H2; intuition.
    - rewrite add_mapsto_iff in *; intuition; subst.
      destruct (E.eq_dec k0 k); intuition; eauto.
      rewrite e1 in H0; intuition.
      rewrite add_mapsto_iff in H2; intuition.
  Qed.

  Lemma map_empty
    : forall elt elt' f,
      Equal (map f (empty elt))
            (empty elt').
  Proof.
    intros; eapply Equal_mapsto_iff; split; intros.
    - destruct (map_2 (elt' := elt') (m := empty elt) (x := k)
                      (f := f)).
      + eexists; eauto.
      + apply empty_1 in H0; intuition.
    - apply empty_1 in H; intuition.
  Qed.

  Lemma Permutation_filter_elements {B} :
    forall (f : key -> B -> bool) m
           (Proper_f : Proper (E.eq ==> eq ==> eq) f),
      Permutation
        (List.map snd (elements (filter f m)))
        (List.map snd  (List.filter (fun kv => f (fst kv) (snd kv)) (elements m))).
  Proof.
    intros; apply Permutation_InA_cons; eauto using elements_3w.
    - pose proof (elements_3w m) as NoDupM.
      induction NoDupM; simpl in *; simpl; try constructor.
      case_eq (f (fst x) (snd x)); simpl; eauto.
      intros; constructor; eauto.
      unfold not; intros; apply H; clear NoDupM IHNoDupM H;
        induction l; simpl in *.
      inversion H0; subst; eauto.
      case_eq (f (fst a) (snd a)); intros; rewrite H in *; eauto.
      inversion H1; subst.
      constructor; eauto.
      constructor 2; eauto.
    - intros; rewrite <- elements_mapsto_iff, filter_iff; eauto;
        intuition.
      + rewrite elements_mapsto_iff in H0; induction H0.
        * simpl; destruct H; rewrite Proper_f in H1; eauto;
            rewrite H1; repeat constructor; eauto.
        * simpl; destruct (f (fst y) (snd y)); simpl; eauto.
      + rewrite elements_mapsto_iff; induction (elements m);
          simpl in *.
        * inversion H.
        * case_eq (f (fst a) (snd a)); intros; rewrite H0 in H.
          inversion H; subst.
          constructor; eauto.
          constructor 2; eauto.
          constructor 2; eauto.
      + induction (elements m); simpl in *.
        * inversion H.
        * case_eq (f (fst a) (snd a)); intros; rewrite H0 in H; eauto.
          inversion H; subst.
          destruct H2; rewrite Proper_f in H0; eauto.
          eauto.
  Qed.

  Global Instance eq_key_elt_Equivalence {elt} : Equivalence (@eq_key_elt elt) | 100.
  Proof.
    split; unfold eq_key_elt; repeat (intros [] || intro); simpl in *; intuition.
    etransitivity; eassumption.
  Qed.

  Local Hint Extern 1 (eq_key_elt _ _) => reflexivity.

  Lemma forall_in_eq_key_elt_snd {A} ls (P : _ -> Prop)
    : (forall x : key * A, List.In x ls -> P (snd x))
      <-> (forall x : key * A, InA (@eq_key_elt A) x ls -> P (snd x)).
  Proof.
    split; intros H x H'.
    { rewrite InA_alt in H'.
      destruct H' as [y [[H'0 ?] H'1]].
      specialize (H y); destruct y; simpl in *; subst.
      eauto. }
    { apply H.
      apply InA_In; [ exact _ | ].
      assumption. }
  Qed.

  Lemma elements_mapsto_iff'
    : forall (elt : Type) (m : t elt) (xe : key * elt),
    MapsTo (fst xe) (snd xe) m <-> InA (eq_key_elt (elt:=elt)) xe (elements m).
  Proof.
    intros; rewrite elements_mapsto_iff; destruct xe; reflexivity.
  Qed.

  Definition map2_1bis_for_rewrite (* no metavariables deep inside the beta-iota normal form *)
             elt elt' elt'' f H m m' x
    := @BasicFacts.map2_1bis elt elt' elt'' m m' x f H.

  Tactic Notation "setoid_rewrite_in_all" open_constr(lem) :=
    idtac;
    match goal with
    | _ => rewrite !lem
    | [ H : _ |- _ ] => rewrite !lem in H
    | _ => setoid_rewrite lem
    | [ H : _ |- _ ] => setoid_rewrite lem in H
    end.

  Tactic Notation "setoid_rewrite_in_all" "<-" open_constr(lem) :=
    idtac;
    match goal with
    | _ => rewrite <- !lem
    | [ H : _ |- _ ] => rewrite <- !lem in H
    | _ => setoid_rewrite <- lem
    | [ H : _ |- _ ] => setoid_rewrite <- lem in H
    end.

  Ltac FMap_convert_step should_convert_from_to :=
    idtac;
    first [ setoid_rewrite_in_all <- in_rev
          | setoid_rewrite_in_all fold_right_andb_false
          | should_convert_from_to (@find) (@MapsTo);
            setoid_rewrite_in_all <- find_mapsto_iff
          | should_convert_from_to (@MapsTo) (@find);
            setoid_rewrite_in_all find_mapsto_iff
          | should_convert_from_to (@InA) (@MapsTo);
            setoid_rewrite_in_all <- elements_mapsto_iff
          | should_convert_from_to (@MapsTo) (@InA);
            setoid_rewrite_in_all elements_mapsto_iff
          | should_convert_from_to (@InA) (@MapsTo);
            setoid_rewrite_in_all <- elements_mapsto_iff'
          | should_convert_from_to (@MapsTo) (@InA);
            setoid_rewrite_in_all elements_mapsto_iff'
          | should_convert_from_to (@find) (@add);
            setoid_rewrite_in_all add_o
          | should_convert_from_to (@add) (@find);
            setoid_rewrite_in_all <- add_o
          | should_convert_from_to (@find) (@map2);
            setoid_rewrite_in_all (@map2_1bis_for_rewrite _ _ _ _ eq_refl)
          | should_convert_from_to (@find) (@map2);
            setoid_rewrite_in_all map2_1bis_for_rewrite; [ | (reflexivity || assumption).. ]
          | should_convert_from_to (@find) (@map2);
            setoid_rewrite_in_all map2_1bis; [ | (reflexivity || assumption).. ]
          | should_convert_from_to (@find) (@In);
            setoid_rewrite_in_all <- not_find_in_iff
          | should_convert_from_to (@In) (@find);
            setoid_rewrite_in_all not_find_in_iff
          | should_convert_from_to (@InA) (@In);
            setoid_rewrite_in_all <- elements_in_iff
          | should_convert_from_to (@In) (@InA);
            setoid_rewrite_in_all elements_in_iff
          | should_convert_from_to (@fold) (@fold_left);
            setoid_rewrite_in_all fold_1
          | should_convert_from_to (@fold_left) (@fold);
            setoid_rewrite_in_all <- fold_1
          | should_convert_from_to (@fold_left) (@fold_right);
            match goal with
            | [ |- appcontext[fold_left (fun a b => @?f b && a)%bool] ]
              => rewrite (@ListFacts.fold_map _ _ _ _ (fun a b => andb b a) f), <- fold_left_rev_right, <- map_rev
            | [ H : appcontext[fold_left (fun a b => ?g (@?f b) a)] |- _ ]
              => rewrite (@ListFacts.fold_map _ _ _ _ (fun a b => g b a) f), <- fold_left_rev_right, <- map_rev in H
            end
          | should_convert_from_to (@fold_right) (@List.In);
            setoid_rewrite_in_all fold_right_andb_map_in_iff
          | should_convert_from_to (@List.In) (@InA);
            setoid_rewrite_in_all forall_in_eq_key_elt_snd
          | should_convert_from_to (@List.In) (@InA);
            setoid_rewrite_in_all (@forall_in_eq_key_elt_snd _ _ (fun k => _ k _))
          | should_convert_from_to false true;
            setoid_rewrite_in_all <- not_true_iff_false
          | setoid_rewrite_in_all empty_o
          | match goal with H : _ |- _ => revert H end;
            FMap_convert_step should_convert_from_to;
            intros ].

  Ltac FMap_convert' should_convert_from_to :=
    intros; repeat (intros; FMap_convert_step should_convert_from_to).

  Ltac default_should_convert_from_to from to :=
    match from with
    | @find
      => match to with
         | @MapsTo => idtac
         | @InA => idtac
         | @add => idtac
         | @In => idtac
         | @map2 => idtac
         end
    | @MapsTo
      => match to with
         | @InA => idtac
         end
    | @In
      => match to with
         | @InA => idtac
         end
    | @List.In
      => match to with
         | @InA => idtac
         end
    | @fold
      => match to with
         | @fold_left => idtac
         end
    | @fold_left
      => match to with
         | @fold_right => idtac
         end
    | @fold_right
      => match to with
         | @List.In => idtac
         end
    | @map2
      => match to with
         | @find => idtac
         end
    | false
      => match to with
         | true => idtac
         end
    end.

  Ltac default_should_convert_from_to_find from to :=
    match from with
    | @MapsTo
      => match to with
         | @find => idtac
         end
    | @InA
      => match to with
         | @MapsTo => idtac
         | @find => idtac
         | @In => idtac
         end
    | @In
      => match to with
         | @find => idtac
         end
    | @List.In
      => match to with
         | @InA => idtac
         end
    | @find
      => match to with
         | @add => idtac
         | @map2 => idtac
         end
    | @fold
      => match to with
         | @fold_left => idtac
         end
    | @fold_left
      => match to with
         | @fold_right => idtac
         end
    | @fold_right
      => match to with
         | @List.In => idtac
         end
    | false
      => match to with
         | true => idtac
         end
    end.

  Ltac FMap_convert := FMap_convert' default_should_convert_from_to.
  Ltac FMap_convert_to_find := FMap_convert' default_should_convert_from_to_find.

  Ltac setoid_subst_E_eq :=
    repeat match goal with
           | [ H : E.eq ?x ?y |- _ ]
             => is_var x;
                move H at top;
                revert dependent x;
                intros x H;
                setoid_rewrite H;
                clear x H;
                intros
           | [ H : E.eq ?x ?y |- _ ]
             => is_var y;
                move H at top;
                revert dependent y;
                intros y H;
                setoid_rewrite <- H;
                clear y H;
                intros
           | [ H : eq_key_elt _ _ |- _ ] => destruct H
           end.

  Ltac saturate_E_eq :=
    repeat match goal with
           | [ H : E.eq ?x ?y |- _ ]
             => lazymatch goal with
                | [ _ : E.eq y x |- _ ] => fail
                | _ => pose proof (symmetry H)
                end
           | [ H : E.eq ?x ?y, H' : E.eq ?y ?z |- _ ]
             => lazymatch goal with
                | [ _ : E.eq x z |- _ ] => fail
                | _ => pose proof (transitivity H H')
                end
           end.

  Lemma elements_correct {A} (m : t A) (i : key) (v : A)
        (H : find i m = Some v)
    : InA (eq_key_elt (elt:=A)) (i, v) (elements m).
  Proof.
    FMap_convert; assumption.
  Qed.

  Global Instance eq_key_elt_pair_Proper {elt}
    : Proper (E.eq ==> eq ==> @eq_key_elt elt) pair | 10.
  Proof.
    repeat intro; subst.
    hnf; intuition.
  Qed.

  Global Hint Extern 0 (Proper (E.eq ==> _) pair) => eapply eq_key_elt_pair_Proper : typeclass_instances.

  Lemma of_list_elements {T} (v : t T)
    : Equal (of_list (elements v)) v.
  Proof.
    unfold of_list, Equal; intro y.
    destruct (find y v) eqn:H;
      FMap_convert;
      revert H;
      generalize (elements_3w v);
      induction (elements v) as [|x xs IHxs]; clear v.
    { simpl; intros; invlist InA. }
    { intros; invlist InA; invlist NoDupA; simpl in *;
      FMap_convert_to_find;
      edestruct F.eq_dec; setoid_subst_E_eq; simpl in *; intuition (subst; setoid_subst_E_eq; eauto using (@reflexivity _ E.eq)).
      { exfalso; eauto using (@reflexivity _ E.eq). }
      { exfalso; destruct_head prod; eauto using InA_eqke_eqk. } }
    { simpl; intros; invlist InA.
      FMap_convert_to_find.
      intro; destruct_head ex; congruence. }
    { intros; invlist InA; invlist NoDupA; simpl in *;
      FMap_convert_to_find;
      edestruct F.eq_dec; setoid_subst_E_eq; simpl in *; intuition (subst; setoid_subst_E_eq; eauto using (@reflexivity _ E.eq));
      destruct_head prod;
      repeat match goal with
             | [ H : (ex _) -> _ |- _ ] => specialize (fun x pf => H (ex_intro _ x pf))
             | [ H : ((ex _) -> _) -> _ |- _ ] => specialize (fun f => H (fun xpf => match xpf with ex_intro x pf => f x pf end))
             | [ H : ?A -> ?B -> ?C, H' : ?B |- _ ] => specialize (fun pf => H pf H')
             | _ => progress simpl in *
             end;
      eauto using (@reflexivity _ (@eq_key_elt T)), InA_cons_hd. }
  Qed.

  Lemma empty_length_elements {A} (ls : t A)
        (H : Empty ls)
    : List.length (elements ls) = 0.
  Proof.
    rewrite <- M.cardinal_1.
    apply cardinal_Empty; assumption.
  Qed.

  Definition lift_brelation {A} (R : A -> A -> bool) (default : A) : t A -> t A -> bool
    := fun m1 m2
       => fold
            (fun _ => andb)
            (map2
               (fun x1 x2
                => match x1, x2 with
                   | Some x1, Some x2 => Some (R x1 x2)
                   | Some x, None => Some (R x default)
                   | None, Some x => Some (R default x)
                   | None, None => None
                   end)
               m1 m2)
            true.

  Lemma fold_andb_true v
    : fold (fun _ => andb) v true <-> forall k, find k v <> Some false.
  Proof.
    FMap_convert.
    split; intro H; [ specialize (fun k v => H (k, v)) | ];
      simpl in *;
      intuition eauto using diff_false_true.
    destruct_head prod.
    destruct_head bool; eauto.
  Qed.

  Local Ltac instance_t :=
    repeat match goal with
           | _ => congruence
           | _ => progress destruct_head prod
           | _ => progress destruct_head bool
           | _ => progress simpl in *
           | _ => progress subst
           | [ H : context[match ?e with _ => _ end] |- _ ] => destruct e eqn:?
           | _ => progress specialize_by assumption
           | _ => progress specialize_by ltac:(exact eq_refl)
           | [ H : Some _ = Some _ |- _ ] => inversion H; clear H
           | [ H : Some _ = Some _ -> _ |- _ ] => specialize (fun H' => H (f_equal (@Some _) H'))
           | [ H : ?x = false -> false = true |- _ ]
             => destruct x eqn:?; [ clear H | specialize (H eq_refl); congruence ]
           | _ => progress unfold is_true in *
           end;
    repeat match goal with
           | _ => congruence
           | _ => progress specialize_by assumption
           | _ => progress specialize_by ltac:(exact eq_refl)
           | [ H : forall x, ?R x ?y = ?v -> _, H' : ?R ?x' ?y = ?v |- _ ]
             => unique pose proof (H _ H')
           | [ H : forall y, ?R ?x y = ?v -> _, H' : ?R ?x ?y' = ?v |- _ ]
             => unique pose proof (H _ H')
           | [ H : forall x y, ?R x y = ?v -> _, H' : ?R ?x' ?y' = ?v |- _ ]
             => unique pose proof (H _ _ H')
           | [ H : forall x y z, ?R x y = ?v -> _, H' : ?R ?x' ?y' = ?v |- _ ]
             => unique pose proof (fun z => H _ _ z H')
           | [ H : forall x : ?T, ?R x x = true, x' : ?T |- _ ]
             => unique pose proof (H x')
           end.

  Lemma lift_brelation_iff {A} (R : A -> A -> bool) (default : A) (m1 m2 : t A)
    : lift_brelation R default m1 m2 <-> forall k, match find k m1, find k m2 return bool with
                                                   | Some x1, Some x2 => R x1 x2
                                                   | Some x, None => R x default
                                                   | None, Some x => R default x
                                                   | None, None => true
                                                   end.
  Proof.
    FMap_convert_to_find.
    split; intro H; [ intro k; specialize (H (k, false)) | intros [k v]; specialize (H k) ];
      instance_t.
  Qed.

  Global Instance map2_Proper_Equal {A B C} f (Hf : f None None = None)
    : Proper (Equal ==> Equal ==> Equal) (@map2 A B C f).
  Proof.
    intros ?? H' ?? H''.
    rewrite Equal_mapsto_iff.
    FMap_convert_to_find.
    setoid_subst_rel (@Equal A).
    setoid_subst_rel (@Equal B).
    reflexivity.
  Qed.

  Global Hint Extern 1 (Proper _ (@map2 ?A ?B ?C ?f))
  => refine (@map2_Proper_Equal A B C f eq_refl) : typeclass_instances.

  Global Instance lift_brelation_Reflexive {A} {R : A -> A -> bool} {HR : @Reflexive A R} {default}
    : Reflexive (lift_brelation R default).
  Proof. intro; FMap_convert_to_find; edestruct find; congruence. Qed.

  Global Instance lift_brelation_Symmetric {A} {R : A -> A -> bool} {HR : @Symmetric A R} {default}
    : Symmetric (lift_brelation R default).
  Proof.
    intro; FMap_convert_to_find.
    repeat match goal with
           | [ H : forall x : ?T, _, x' : ?T |- _ ] => specialize (H x')
           end.
    hnf in HR; instance_t.
  Qed.

  Global Instance lift_brelation_Transitive {A} {R : A -> A -> bool} {HR : @Transitive A R} {default}
    : Transitive (lift_brelation R default).
  Proof.
    intro; FMap_convert_to_find.
    repeat match goal with
           | [ H : forall x : ?T, _, x' : ?T |- _ ] => specialize (H x')
           end.
    hnf in HR; instance_t.
  Qed.

  Global Instance fold_andb_true_Proper_Equal
    : Proper (@Equal _ ==> eq ==> eq) (fold (fun _ => andb)).
  Proof.
    intros ?? H [] ??; subst;
      match goal with
      | [ |- ?x = ?y ] => destruct x eqn:?; destruct y eqn:?; trivial
      end;
      FMap_convert_to_find;
      setoid_subst_rel (@Equal bool);
      try tauto.
  Qed.

  Global Instance lift_brelation_Proper_Equal {A R default}
    : Proper (@Equal A ==> @Equal A ==> eq) (@lift_brelation A R default) | 2.
  Proof.
    intros a b H a' b' H'.
    destruct (lift_brelation R default a a') eqn:Ha;
    destruct (lift_brelation R default b b') eqn:Hb;
    unfold lift_brelation in *;
    try reflexivity;
    setoid_subst_rel (@Equal A);
    congruence.
  Qed.

  Global Instance lift_brelation_Proper_Proper_subrelation {A} {R1 R2 R : A -> A -> bool} {default}
         {R1_Reflexive : Reflexive R1}
         {R2_Reflexive : Reflexive R2}
         {R1_subrelation : subrelation R1 R}
         {R2_subrelation : subrelation R2 R}
         {R_Proper : Proper (R1 ==> R2 ==> eq) R}
    : Proper (lift_brelation R1 default ==> lift_brelation R2 default ==> eq) (lift_brelation R default) | 2.
  Proof.
    intros a b H a' b' H'.
    destruct (lift_brelation R default a a') eqn:Ha;
    destruct (lift_brelation R default b b') eqn:Hb;
    unfold lift_brelation in *;
    try reflexivity;
    FMap_convert_to_find;
    repeat match goal with
           | [ |- false = true ] => exfalso
           | [ |- true <> true ] => exfalso
           | [ H : ~_ |- False ] => apply H; clear H
           | _ => progress intros
           | [ H : forall x : ?T, _, H' : ?T |- _ ] => specialize (H H')
           end;
      specialize (fun x y H z w => R_Proper x y H z w);
      unfold Reflexive, Symmetric, Transitive, subrelation, predicate_implication, pointwise_lifting, impl in *;
      instance_t.
  Qed.

  Global Instance lift_brelation_Proper_Proper {A} {R : A -> A -> bool} {default}
         {R_Reflexive : Reflexive R}
         {R_Proper : Proper (R ==> R ==> eq) R}
    : Proper (lift_brelation R default ==> lift_brelation R default ==> eq) (lift_brelation R default) | 2.
  Proof.
    apply lift_brelation_Proper_Proper_subrelation.
  Qed.

  Global Instance lift_brelation_Equivalence
         {A} {R : A -> A -> bool}
         {R_Equiv : @Equivalence A R}
         {default}
    : Equivalence (lift_brelation R default).
  Proof.
    split; exact _.
  Qed.

  Global Instance lift_brelation_Antisymmetric
         {A} {R RE : A -> A -> bool}
         {RE_Equivalence : @Equivalence A RE}
         {AS : Antisymmetric A RE R}
         {default}
    : Antisymmetric _ (lift_brelation RE default) (lift_brelation R default).
  Proof.
    intros a b H H'.
    FMap_convert_to_find.
    repeat match goal with
           | [ H : forall x : ?T, _, H' : ?T |- _ ] => specialize (H H')
           end.
    destruct RE_Equivalence.
    do 2 edestruct find;
      unfold Reflexive, Symmetric, Transitive, Antisymmetric, subrelation, predicate_implication, pointwise_lifting, impl in *;
      instance_t.
  Qed.

  (** TODO: merge with FindWithDefault *)
  Definition find_default {elt} (default : elt) (k : key) (m : t elt) : elt
    := option_rect (fun _ => elt)
                   (fun v => v)
                   default
                   (find k m).

  Lemma find_default_map2 {elt elt' elt''} f (H : f None None = None)
        default default' default''
        (Hfl : forall v, f None (Some v) = f (Some default) (Some v))
        (Hfr : forall v, f (Some v) None = f (Some v) (Some default'))
        (Hfd : f (Some default) (Some default') = Some default'')
        (m : t elt) (m' : t elt')
        k
    : find_default default'' k (map2 f m m')
      = option_rect (fun _ => elt'')
                    (fun v => v)
                    default''
                    (f (Some (find_default default k m)) (Some (find_default default' k m'))).
  Proof.
    unfold find_default.
    rewrite map2_1bis by assumption.
    do 2 edestruct find; simpl;
      rewrite ?Hfl, ?Hfr, ?Hfd, ?H;
      try reflexivity.
  Qed.

  Definition defaulted_f {elt elt' elt''} (default : elt) (default' : elt') f
    := fun x y => match x, y return option elt'' with
                  | Some x, Some y => Some (f x y)
                  | Some x, None => Some (f x default')
                  | None, Some y => Some (f default y)
                  | None, None => None
                  end.

  Lemma find_default_map2_defaulted {elt elt' elt''} (f : elt -> elt' -> elt'')
        default default' default''
        (Hdefault'' : f default default' = default'')
        (m : t elt) (m' : t elt')
        k
    : find_default default'' k (map2 (defaulted_f default default' f) m m')
      = f (find_default default k m) (find_default default' k m').
  Proof.
    subst.
    erewrite find_default_map2 by reflexivity; reflexivity.
  Qed.

  Global Instance map2_defaulted_Proper_lift_brelation {elt elt' elt''} {default : elt} {default' : elt'} {f}
         {R1 : elt -> elt -> bool}
         {R2 : elt' -> elt' -> bool}
         {R : elt'' -> elt'' -> bool}
         {R1_Reflexive : Reflexive R1}
         {R2_Reflexive : Reflexive R2}
         {f_Proper : Proper (R1 ==> R2 ==> R) f}
    : Proper (lift_brelation R1 default ==> lift_brelation R2 default' ==> lift_brelation R (f default default'))
             (map2 (defaulted_f default default' f)).
  Proof.
    repeat intro; FMap_convert_to_find.
    repeat match goal with
           | [ H : forall x : ?T, _, H' : ?T |- _ ] => specialize (H H')
           end.
    unfold defaulted_f in *.
    unfold Proper, respectful, Reflexive in *.
    instance_t.
  Qed.

  Lemma lift_brelation_iff_false_elements {A} (R : A -> A -> bool) (default : A) (m1 m2 : t A)
        (elms := (elements (map2 (fun x1 x2 => match x1, x2 with
                                               | Some x1, Some x2 => Some (R x1 x2)
                                               | Some x, None => Some (R x default)
                                               | None, Some x => Some (R default x)
                                               | None, None => None
                                               end)
                                 m1 m2)))
    : lift_brelation R default m1 m2 = false
      <-> (exists x, InA (@eq_key_elt _) x elms /\ snd x = false).
  Proof.
    FMap_convert.
    setoid_rewrite InA_alt.
    subst elms.
    let ls := match goal with |- context[elements ?m] => constr:(elements m) end in
    induction ls as [|x xs IHxs].
    { simpl.
      split; intro H; [ exfalso; apply H | ];
        repeat intuition (tauto || congruence || simpl in * || destruct_head ex || eauto). }
    { simpl.
      setoid_rewrite_logic.
      setoid_rewrite <- IHxs; clear IHxs.
      setoid_rewrite <- InA_alt.
      repeat setoid_rewrite (and_comm _ (_ = _)).
      setoid_rewrite_logic.
      destruct x as [k []]; simpl;
        setoid_rewrite_logic.
      { reflexivity. }
      { setoid_rewrite (True_iff (ex_intro (fun y => E.eq y k) k (reflexivity _))).
        setoid_rewrite (forall_iff_nondep (ex_intro (fun y => E.eq y k) k (reflexivity _))).
        tauto. } }
  Qed.

  Lemma lift_brelation_iff_false {A} (R : A -> A -> bool) (default : A) (m1 m2 : t A)
    : lift_brelation R default m1 m2 = false <-> exists k, match find k m1, find k m2 return bool with
                                                           | Some x1, Some x2 => negb (R x1 x2)
                                                           | Some x, None => negb (R x default)
                                                           | None, Some x => negb (R default x)
                                                           | None, None => false
                                                           end.
  Proof.
    rewrite lift_brelation_iff_false_elements.
    FMap_convert_to_find.
    split;
      [ intros [[k v] H]; exists k; simpl in *
      | intros [k H]; exists (k, false); split; simpl in *; [ | congruence ] ];
      do 2 edestruct find;
      repeat match goal with
             | [ H : and _ _ |- _ ] => destruct H
             | [ H : _ <> true |- _ ] => apply not_true_iff_false in H
             | _ => progress subst
             | _ => setoid_rewrite negb_true_iff
             | [ H : context[negb _] |- _ ] => setoid_rewrite negb_true_iff in H
             | _ => congruence
             end.
  Qed.
End FMapExtensions_fun.

Module FMapExtensions (M: WS) := FMapExtensions_fun M.E M.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(** * Derived Module *)

Set Implicit Arguments.

Require Export Misc.
Require Export Mod.

Section Derived_Mod.

Implicit Type X Y Z : Set.

Variable (P : Monad) (M : Mod P).

Section Def.

Let T : Set -> Set := fun X => M (option X).

Let bT X Y (f : X -> P Y) (x : T X) : T Y :=
  x >>>= (default (fun u => (f u) >>- @Some Y) (unit P None)).

Remark bT_bT : forall X Y Z (f : X -> P Y) (g : Y -> P Z) (x : T X),
  bT Z g (bT Y f x) = bT Z (fun u : X => f u >>= g) x.
Proof.
unfold T, bT; intros; autorewrite with mod.
apply mbind_congr. reflexivity.
intros. destruct a; simpl; monad.
Qed.

Remark unit_bT : forall X (x : T X),
  bT X (unit P (X:=X)) x = x.
Proof.
unfold T, bT; intros; autorewrite with mod.
apply unit_mbind_match.
destruct a; simpl; mod.
Qed.

Definition Derived_Mod : Mod P := Build_Mod P T bT bT_bT unit_bT.

End Def.

Section Inc.

Let i X (x : M X) : Derived_Mod X := x >>>- @Some X.

Remark i_hom : forall X Y (f : X -> P Y) (x : M X),
  i Y (x >>>= f) = mbind Derived_Mod _ f (i X x).
Proof.
unfold i; simpl; mod.
Qed.

Definition derived_inc : Mod_Hom M Derived_Mod :=
  Build_Mod_Hom _ _ i i_hom.

End Inc.

End Derived_Mod.

(** * Exponetial Monads *)

Record ExpMonad : Type := {
  exp_monad :> Monad;
  exp_abs : Mod_Hom (Derived_Mod exp_monad) exp_monad;
  exp_app : Mod_Hom exp_monad (Derived_Mod exp_monad);
  exp_eta : forall X (x : exp_monad X),
    exp_abs _ (exp_app _ x) = x;
  exp_beta : forall X (x : Derived_Mod exp_monad X),
    exp_app _ (exp_abs _ x) = x
}.

Record ExpMonad_Hom (M N : ExpMonad) : Type := {
  expmonad_hom :> Monad_Hom M N;
  expmonad_hom_app : forall X (x : M X),
    expmonad_hom _ (exp_app M _ x) = exp_app N _ (expmonad_hom _ x);
  expmonad_hom_abs : forall X (x : Derived_Mod M X),
    expmonad_hom _ (exp_abs M _ x) = exp_abs N _ (expmonad_hom _ x)
}.


From iris.algebra Require Import gmap.
From iris.algebra Require Import updates local_updates.

Section stdpp_extra.
  Context `{FinMap K M}.
  Lemma map_union_difference {A} (m1 m2 : M A) :
    m1 ##ₘ m2 → (m1 ∪ m2) ∖ m1 = m2.
  Proof.
    rewrite map_disjoint_spec. intro Hm1m2. apply map_eq. intros i.
    apply option_eq. intros v. specialize (Hm1m2 i).
    unfold union, map_union, union_with, map_union_with.
    rewrite lookup_difference_Some lookup_merge.
    destruct (m1 !! i) as [x'|], (m2 !! i);
      try specialize (Hm1m2 x' v); compute; intuition congruence.
  Qed.
End stdpp_extra.

Section extra.
  Context `{Countable K} {A : cmra}.
  Implicit Types m : gmap K A.
  Implicit Types i : K.
  Implicit Types x y : A.

  Lemma insert_singleton_op_Some m i x y :
    m !! i = Some x → <[i:=y ⋅ x]> m ≡ {[ i := y ]} ⋅ m.
  Proof.
    intros Hsome; symmetry.
    rewrite -(insert_delete m i x) //.
    rewrite insert_singleton_op; last apply lookup_delete.
    rewrite assoc singleton_op.
    do 2 (rewrite -insert_singleton_op; last apply lookup_delete).
    rewrite (insert_delete m i x) //.
    by rewrite insert_delete_insert.
  Qed.

  Lemma insert_singleton_op_Some_L `{!LeibnizEquiv A} m i x y :
    m !! i = Some x → <[i:=y ⋅ x]> m = {[ i := y ]} ⋅ m.
  Proof. intros; rewrite -leibniz_equiv_iff insert_singleton_op_Some //. Qed.

  Lemma insert_singleton_op_empty i x :
    <[i:=x]> (∅ : gmap K A) = {[ i := x ]} ⋅ ∅.
  Proof. by apply insert_singleton_op. Qed.

  Lemma dom_singleton_op m i x :
    dom ({[ i := x ]} ⋅ m) = {[i]} ∪ dom m.
  Proof. rewrite dom_op; set_solver. Qed.

  Lemma dom_singleton_op_Some m i x :
    is_Some (m !! i) → dom ({[ i := x ]} ⋅ m) = dom m.
  Proof. rewrite -elem_of_dom dom_op; set_solver. Qed.
End extra.


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 Z -> list int.
  Parameter GAP: forall bits, NPeano.Nat.divide d (length (gap (bitsToBytes bits))).
  Parameter sap_gap: splitAndPad = fun bits => bytesToBits (intlist_to_Zlist (gap (bitsToBytes bits))).

  Parameter HASH: forall m, HF.Hash m = intlist_to_Zlist (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:Z := 54.
  Definition opd:Z:=92.
  Lemma isbyteZ_Ipad: isbyteZ ipd.
    unfold ipd. split; omega. Qed.
  Lemma isbyteZ_Opad: isbyteZ opd.
    unfold opd. split; omega. Qed.

  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. apply sublist.Forall_list_repeat. unfold opd. omega.
    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. apply sublist.Forall_list_repeat. unfold ipd. omega.
    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 (BtO:isbyteZ opd). unfold opd. split; omega.
  assert (FI: Forall isbyteZ (PAD.HM.sixtyfour ipd)).
      rewrite PAD.HM.SF_ByteRepr; trivial. apply isbyte_map_ByteUnsigned.
  assert (BtI:isbyteZ ipd). unfold ipd. split; omega.
  assert (FO: Forall isbyteZ (PAD.HM.sixtyfour opd)).
      rewrite PAD.HM.SF_ByteRepr; trivial. apply isbyte_map_ByteUnsigned.
  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.
  rewrite PAD.HM.SF_ByteRepr in H0; trivial.
  rewrite PAD.HM.SF_ByteRepr in H0; trivial.
  unfold PAD.HM.sixtyfour in H0. rewrite map_list_repeat in H0. rewrite map_list_repeat in H0.
  apply list_repeat_injective in H0.
    rewrite unsigned_Brepr_isbyte in H0; trivial.
    rewrite unsigned_Brepr_isbyte in H0; trivial. unfold ipd, opd in H0; omega.
  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 (Byte.repr ipd) (Byte.repr opd)
                     (bitsToBytes (HMAC_Abstract.Message2Blist m))
                     (map Integers.Byte.repr (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.
    apply PAD.HM.isbyte_hmaccore.
  eapply (PAD.HMAC_pad_concrete' _ _ EQ.B EQ.BS EQ.D EQ.ir _ EQ.GAP EQ.sap_gap EQ.HASH).
    apply isbyteZ_Ipad.
    apply isbyteZ_Opad.
    repeat rewrite map_length.
            erewrite bitsToBytes_len_gen. reflexivity.
            rewrite LK. rewrite EQ.BS; trivial.
    rewrite map_unsigned_Brepr_isbyte.
            apply bytes_bits_comp_ind.
              eapply bitsToBytes_isbyteZ. reflexivity.
              rewrite bits_bytes_bits_id; trivial.
              apply InBlocks_len. rewrite LK, <- EQ.BS. eexists; reflexivity.
            eapply bitsToBytes_isbyteZ. reflexivity.
    apply bytes_bits_comp_ind.
              eapply bitsToBytes_isbyteZ. reflexivity.
              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.