Library Apps.SerializableMergableFMapImplementation

Require Import Coq.Strings.String Coq.FSets.FMapInterface Coq.Classes.RelationPairs.
Require Import SerializableMergableFMapInterface PrefixSerializable.
Require Import Common.

Local Open Scope bool_scope.
Set Implicit Arguments.

Module MakeSerializableMergableMap (E : SerializableOrderedType) (M : Sfun E) <: SerializableMergableMapInterface E.
  Definition key := M.key.
  Definition t elt := M.t (nat × option elt).

  Local Ltac add_facts :=
    repeat match goal with
             | _progress subst
             | [ H : Some _ = None |- _ ] ⇒ solve [ inversion H ]
             | [ H : None = Some _ |- _ ] ⇒ solve [ inversion H ]
             | [ H : appcontext[M.map2 ?f _ _] |- _ ]
               ⇒ not atomic f;
                 let f' := fresh "f" in
                 set (f' := f) in ×
             | [ H : E.eq ?x ?y, H' : M.MapsTo ?x ?e ?m |- _ ]
               ⇒ unique pose proof (M.MapsTo_1 H H')
             | [ H : E.eq ?x ?y |- _ ]
               ⇒ unique pose proof (E.eq_sym H)
             | [ x : key |- _ ]
               ⇒ unique pose proof (E.eq_refl x)
             | [ H : E.eq ?x ?y, H' : E.eq ?y ?z |- _ ]
               ⇒ unique pose proof (E.eq_trans H H')
             | [ H : E.eq ?x ?y, H' : context[M.add ?x ?e ?m] |- _ ]
               ⇒ unique pose proof (M.add_1 m e H)
             | [ H : M.MapsTo ?x ?e ?m |- _ ]
               ⇒ unique pose proof (M.find_1 H)
             | [ H : M.find ?x ?m = Some ?e |- _ ]
               ⇒ unique pose proof (M.find_2 H)
             | [ H : M.MapsTo ?k ?v ?m |- _ ]
               ⇒ unique pose proof (ex_intro (fun vM.MapsTo k v m) v H : M.In k m)
             | [ H : M.In ?x (M.map2 ?f ?m ?m') |- _ ]
               ⇒ unique pose proof (M.map2_2 H)
             | [ H : ?a = ?b |- _ ]
               ⇒ unique pose proof (Logic.eq_sym H)
             | [ H : ?a = ?b, H' : ?b = ?c |- _ ]
               ⇒ unique pose proof (Logic.eq_trans H H')
             | [ H : Some ?x = Some ?y |- _ ]
               ⇒ unique pose proof (Some_inj H)
             | [ H : (?x, ?y) = (?x', ?y') :> _ × _ |- _ ]
               ⇒ unique pose proof (f_equal (@fst _ _) H : x = x')
             | [ H : (?x, ?y) = (?x', ?y') :> _ × _ |- _ ]
               ⇒ unique pose proof (f_equal (@snd _ _) H : y = y')
             | [ H : ¬E.eq ?x ?y |- _ ]
               ⇒ unique pose proof ((fun H'H (E.eq_sym H')) : ¬E.eq y x)
             | [ H : ¬E.eq ?x ?y, H' : M.MapsTo ?y ?e (M.add ?x ?e' ?m) |- _ ]
               ⇒ unique pose proof (M.add_3 H H')
             | [ H : ¬E.eq ?x ?y, H' : M.MapsTo ?y ?e ?m, H'' : appcontext[M.add ?x ?e' ?m] |- _ ]
               ⇒ unique pose proof (M.add_2 e' H H')
             | [ H : ¬E.eq ?x ?y, H' : M.MapsTo ?y ?e ?m |- appcontext[M.add ?x ?e' ?m] ]
               ⇒ unique pose proof (M.add_2 e' H H')
           end.

  Section elt.
    Variable elt : Type.

    Definition empty := M.empty (nat × option elt).
    Definition is_empty (m : t elt) :=
      M.fold (fun k v bb && match snd v with Nonetrue | Some _false end)
             m
             true.
    Definition add (k : key) (v : elt) (m : t elt) : t elt
      := M.add k
               (match M.find k m with
                  | Some (gen, v0)S gen
                  | None ⇒ 0
                end,
                Some v)
               m.

    Definition find (k : key) (m : t elt) : option elt
      := match M.find k m with
           | Some (_, Some v)Some v
           | _None
         end.

    Definition remove (k : key) (m : t elt) : t elt
      := match M.find k m with
           | Some (gen, v0)M.add k (S gen, None) m
           | Nonem
         end.

    Definition mem (k : key) (m : t elt) : bool
      := match M.find k m with
           | Some (_, Some _)true
           | _false
         end.

    Variable elt' elt'' : Type.

    Definition map (f : eltelt') (m : t elt) : t elt'
      := M.map (fun v(fst v, option_map f (snd v))) m.

    Definition mapi (f : keyeltelt') (m : t elt) : t elt'
      := M.mapi (fun k v(fst v, option_map (f k) (snd v))) m.

    Definition map2 (f : option eltoption elt'option elt'') (m : t elt) (m' : t elt') : t elt''
      := M.map2 (fun v1 v2
                   match v1, v2 with
                     | Some (gen1, None), Some (gen2, None)
                       ⇒ Some (max gen1 gen2, None)
                     | Some (gen1, v1'), Some (gen2, v2')
                       ⇒ Some (max gen1 gen2, f v1' v2')
                     | Some (gen1, None), None
                       ⇒ Some (gen1, None)
                     | Some (gen1, v1'), None
                       ⇒ Some (gen1, f v1' None)
                     | None, Some (gen2, None)
                       ⇒ Some (gen2, None)
                     | None, Some (gen2, v2')
                       ⇒ Some (gen2, f None v2')
                     | None, NoneNone
                   end)
                m m'.

    Definition garbage_collect (m : t elt) : t elt
      := M.map2 (fun v1 _
                   match v1 with
                     | Some (_, None)None
                     | Some (_, Some v)Some (0, Some v)
                     | NoneNone
                   end)
                m m.

    Fixpoint filter_some {A B} (ls : list (A × option B)) : list (A × B)
      := match ls with
           | nilnil
           | (a, Some b)::ls'(a, b)::filter_some ls'
           | (a, None)::ls'filter_some ls'
         end.

    Local Ltac InA_filter_some_t :=
      repeat match goal with
               | _intro
               | _progress subst
               | _progress simpl in ×
               | _progress destruct_head prod
               | _progress destruct_head option
               | _assumption
               | [ H : InA _ _ nil |- _ ] ⇒ solve [ inversion H ]
               | [ H : InA _ _ (_::_) |- _ ] ⇒ inversion H; clear H
               | [ H : ?A → ?B, H' : ?A |- _ ] ⇒ specialize (H H')
               | _progress unfold not in ×
               | _solve [ left; eauto ]
               | _solve [ right; eauto ]
               | _solve [ exfalso; eauto ]
             end.

    Lemma InA_filter_some1 {A B} (eqP : B', A × B'A × B'Prop)
          (H : a a' b b', eqP B (a, b) (a', b')eqP _ (a, Some b) (a', Some b'))
          ls (a : A) (b : B)
    : InA (@eqP B) (a, b) (filter_some ls)
      → InA (eqP (option B)) (a, Some b) ls.
    Proof.
      induction ls; InA_filter_some_t.
    Qed.

    Lemma InA_filter_some2 {A B} (eqP : B', A × B'A × B'Prop)
          (H : a a' b b', eqP _ (a, Some b) (a', Some b')eqP B (a, b) (a', b'))
          (H1 : a a' (b : B), ¬eqP _ (a, Some b) (a', None))
          ls (a : A) (b : B)
    : InA (eqP (option B)) (a, Some b) ls
      → InA (@eqP B) (a, b) (filter_some ls).
    Proof.
      induction ls; InA_filter_some_t.
    Qed.

    Lemma InA_filter_some {A B} (eqP : B', A × B'A × B'Prop)
          (H : a a' b b', eqP _ (a, Some b) (a', Some b') eqP B (a, b) (a', b'))
          (H1 : a a' (b : B), ¬eqP _ (a, Some b) (a', None))
          ls (a : A) (b : B)
    : InA (@eqP B) (a, b) (filter_some ls)
       InA (eqP (option B)) (a, Some b) ls.
    Proof.
      split;
      [ eapply InA_filter_some1
      | eapply InA_filter_some2 ];
      split_iff;
      eauto.
    Qed.

    Lemma InA_filter_some_fst {A B} (eqP : relation A)
          ls (a : A) (b : B)
    : InA (fun p p'eqP (fst p) (fst p')) (a, b) (filter_some ls)
      → InA (fun p p'eqP (fst p) (fst p')) (a, Some b) ls.
    Proof.
      apply (@InA_filter_some1 _ _(fun _ p p'eqP (fst p) (fst p'))); simpl; trivial.
    Qed.

    Lemma NoDupA_filter_some {A B} (f : relation A) (ls : list (A × option B))
    : NoDupA (fun p p'f (fst p) (fst p')) ls
      → NoDupA (fun p p'f (fst p) (fst p')) (filter_some ls).
    Proof.
      induction ls;
      repeat match goal with
               | _intro
               | _progress simpl in ×
               | _progress subst
               | _assumption
               | [ |- _ _ ] ⇒ split
               | [ H : NoDupA _ (_::_) |- _ ] ⇒ (inversion H; clear H)
               | [ |- NoDupA _ nil ] ⇒ constructor
               | [ |- NoDupA _ (_::_) ] ⇒ constructor
               | _progress destruct_head prod
               | _progress destruct_head option
               | [ H : (_, _) = (_, _) |- _ ] ⇒ (inversion H; clear H)
               | [ H : ?A → ?B, H' : ?A |- _ ] ⇒ specialize (H H')
               | [ H : InA _ _ (filter_some _) |- _ ] ⇒ unique pose proof (@InA_filter_some_fst _ _ _ _ _ _ H)
               | _progress unfold not in ×
               | _solve [ eauto ]
             end.
    Qed.

    Section InA_map.
      Context {A B}
              (eqPA : AAProp)
              (eqPB : BBProp)
              (f : AB).

      Lemma InA_map1 x0 x1 ls
            (H0 : a, eqPA x0 aeqPB x1 (f a))
      : InA eqPA x0 lsInA eqPB x1 (List.map f ls).
      Proof.
        induction ls as [|?? IHls]; intro H; inversion H; subst; simpl;
        solve [ left; apply H0; assumption
              | right; apply IHls; assumption ].
      Qed.

      Lemma InA_map2 x0 x1 ls
            (H0 : a, eqPB x1 (f a) → eqPA x0 a)
      : InA eqPB x1 (List.map f ls) → InA eqPA x0 ls.
      Proof.
        induction ls as [|?? IHls]; intro H; inversion H; subst; simpl;
        solve [ left; apply H0; assumption
              | right; apply IHls; assumption ].
      Qed.

      Lemma InA_map3 `{Reflexive _ eqPA} x1 ls
      : InA eqPB x1 (List.map f ls) → x0, InA eqPA x0 ls eqPB x1 (f x0).
      Proof.
        induction ls as [|?? IHls]; intro H'; inversion H'; clear H';
        repeat match goal with
                 | _progress cleanup
                 | _progress simpl in ×
                 | _progress destruct_head ex
               end;
        solve [ eexists; split; [ | eassumption ];
                first [ left; reflexivity
                      | right; eassumption ] ].
      Qed.

      Lemma InA_map3' `{Reflexive _ eqPA} x1 ls
      : InA eqPB x1 (List.map f ls) → x0, InA eqPA x0 ls.
      Proof.
        intro H'; apply InA_map3 in H'.
        destruct_head ex;
          destruct_head and;
          eexists; eassumption.
      Qed.
    End InA_map.

    Local Ltac NoDupA_map_t :=
      repeat match goal with
               | _intro
               | _progress simpl in ×
               | _progress cleanup
               | [ |- _ _ ] ⇒ split
               | [ H : NoDupA _ (_::_) |- _ ] ⇒ (inversion H; clear H)
               | [ |- NoDupA _ nil ] ⇒ constructor
               | [ |- NoDupA _ (_::_) ] ⇒ constructor
               | _progress destruct_head option
               | [ H : InA _ _ (filter_some _) |- _ ] ⇒ unique pose proof (@InA_filter_some_fst _ _ _ _ _ _ H)
               | _progress unfold not in ×
               | _solve [ eauto using InA_map1, InA_map2 ]
             end.

    Lemma NoDupA_map1 {A B} (eqA : relation A) (eqB : relation B) (f : AB)
          ls
          (H : a a', eqA a a'eqB (f a) (f a'))
    : NoDupA eqB (List.map f ls) → NoDupA eqA ls.
    Proof.
      induction ls; NoDupA_map_t.
    Qed.

    Lemma NoDupA_map2 {A B} (eqA : relation A) (eqB : relation B) (f : AB)
          ls
          (H : a a', eqB (f a) (f a') → eqA a a')
    : NoDupA eqA lsNoDupA eqB (List.map f ls).
    Proof.
      induction ls; NoDupA_map_t.
    Qed.

    Definition elements (m : t elt) : list (key × elt)
      := filter_some (List.map (fun kv(fst kv, snd (snd kv))) (M.elements m)).

    Definition cardinal (m : t elt) : nat
      := List.length (elements m).

    Definition fold {A} (f : keyeltAA) (m : t elt) (init : A) : A
      := List.fold_left (fun acc kvf (fst kv) (snd kv) acc) (elements m) init.

    Definition equal (eq : elteltbool) (m1 : t elt) (m2 : t elt) : bool
      := M.equal (fun v1 v2match snd v1, snd v2 with
                                 | None, Nonetrue
                                 | Some v1', Some v2'eq v1' v2'
                                 | _, _false
                               end)
                 (garbage_collect m1)
                 (garbage_collect m2).

    Lemma garbage_collect_1 m k gen
    : ¬M.MapsTo k (gen, None) (garbage_collect m).
    Proof.
      clear.
      unfold garbage_collect; intro H.
      add_facts; cleanup.
      subst_body.
      repeat match goal with
               | _intro
               | _progress cleanup
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ H : _ |- _ ] ⇒ rewrite M.map2_1 in H by assumption
             end.
    Qed.

    Lemma garbage_collect_2 m k v gen
    : M.MapsTo k (gen, Some v) (garbage_collect m)
      → gen = 0 gen', M.MapsTo k (gen', Some v) m.
    Proof.
      clear.
      unfold garbage_collect; intro H.
      add_facts; cleanup;
      subst_body;
      repeat match goal with
               | _intro
               | _progress cleanup
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ H : _ |- _ ] ⇒ rewrite M.map2_1 in H by assumption
               | [ H : M.find ?x ?m = Some ?e |- _ ]
                 ⇒ unique pose proof (M.find_2 H)
               | _solve [ eauto ]
             end.
    Qed.

    Lemma garbage_collect_3 m k v gen
    : M.MapsTo k (gen, Some v) m
      → M.MapsTo k (0, Some v) (garbage_collect m).
    Proof.
      clear.
      unfold garbage_collect; intro H.
      apply M.find_2.
      add_facts; cleanup.
      rewrite M.map2_1 by eauto;
        cleanup.
    Qed.

    Section Spec.
      Variable m m' m'' : t elt.
      Variable x y z : key.
      Variable e e' : elt.

      Definition MapsTo (k : key) (v : elt) (m : t elt)
        := gen, M.MapsTo k (gen, Some v) m.

      Definition In (k:key)(m: t elt) : Prop := e:elt, MapsTo k e m.

      Definition Empty m := (a : key)(e:elt) , ¬ MapsTo a e m.

      Definition eq_key (p p':key×elt) := E.eq (fst p) (fst p').

      Definition eq_key_elt (p p':key×elt) :=
          E.eq (fst p) (fst p') (snd p) = (snd p').

      Local Ltac pre_t :=
        repeat match goal with
                 | _progress unfold remove, In, MapsTo, find, elements in ×
                 | [ |- appcontext[match ?E with __ end] ] ⇒ case_eq E
                 | _progress simpl in ×
                 | _intro
                 | _progress destruct_head ex
                 | _progress destruct_head and
                 | [ H : (_, _) = (_, _) |- _ ] ⇒ inversion H; clear H
                 | _progress destruct_head prod
                 | _progress subst
               end.

      Lemma MapsTo_1 : E.eq x yMapsTo x e mMapsTo y e m.
      Proof.
        unfold MapsTo; intros; destruct_head ex.
        eexists; eapply M.MapsTo_1; eassumption.
      Qed.

      Lemma mem_1 : In x mmem x m = true.
      Proof.
        unfold mem, In, MapsTo; intros.
        destruct_head ex.
        erewrite M.find_1 by eassumption; reflexivity.
      Qed.
      Lemma mem_2 : mem x m = trueIn x m.
      Proof.
        unfold mem, In, MapsTo.
        case_eq (M.find x m); intros p H;
        repeat match goal with
                 | [ |- appcontext[match ?E with __ end] ] ⇒ case_eq E; intro
                 | _intro
                 | _progress cleanup
                 | [ H : M.find _ _ = Some _ |- _ ] ⇒ apply M.find_2 in H
                 | _repeat esplit; eassumption
               end.
      Qed.

      Lemma empty_1 : Empty empty.
      Proof.
        unfold empty, Empty, MapsTo.
        intros a e0 [gen H].
        apply M.empty_1 in H.
        assumption.
      Qed.

      Lemma fold_left_andb_true_InA {A} eqP `{Reflexive _ eqP}
            (f : Abool)
            `{Proper _ (eqP ==> Logic.eq) f}
            (ls : list A)
      : fold_left (fun b xb && f x) ls true = true
         ( x, InA eqP x lsf x = true).
      Proof.
        rewrite fold_left_andb_true; split.
        { intros H' x0 H''.
          apply InA_alt in H''.
          destruct H'' as [y0 [H'' H''']].
          rewrite H''; auto. }
        { intros H' x0 X''.
          apply H'; apply InA_alt.
          eexists; split; [ reflexivity | assumption ]. }
      Qed.

      Local Instance : Reflexive (M.eq_key_elt (elt:=nat × option elt)).
      Proof.
        intro; destruct_head prod; split; reflexivity.
      Qed.

      Local Instance
      : Proper (M.eq_key_elt (elt:=nat × option elt) ==> eq)
               (fun x0 : M.key × (nat × option elt)
                  match snd (snd x0) with
                    | Some _false
                    | Nonetrue
                  end).
      Proof.
        hnf; simpl; clear.
        intros [??] [??] **; hnf in *;
          destruct_head and;
          subst.
        reflexivity.
      Qed.

      Lemma is_empty_1 : Empty mis_empty m = true.
      Proof.
        unfold Empty, is_empty, MapsTo.
        rewrite M.fold_1.
        intro H.
        apply (@fold_left_andb_true_InA _ (@M.eq_key_elt _) _ _ _).
        intros [k [gen [v|]]] H'; try reflexivity.
        exfalso.
        specialize (fun H'H k v (ex_intro _ gen H')); simpl in ×.
        apply M.elements_2 in H'; auto.
      Qed.

      Lemma is_empty_2 : is_empty m = trueEmpty m.
      Proof.
        unfold is_empty, Empty, MapsTo.
        rewrite M.fold_1.
        intro H.
        pose proof (proj1 (fold_left_andb_true_InA _) H) as H'; clear H; simpl in ×.
        intros k v [gen H].
        specialize (H' (k, (gen, (Some v)))); simpl in ×.
        cut (false = true); [ let H := fresh in intro H; inversion H | ].
        apply H'.
        apply M.elements_1 in H; auto.
      Qed.

      Lemma add_1 : E.eq x yMapsTo y e (add x e m).
      Proof.
        unfold MapsTo, add.
        intro H'.
        case_eq (M.find x m).
        { intros [gen ?] H''.
          apply M.find_2 in H''.
           (S gen).
          apply M.add_1; trivial. }
        { intro H''.
           0.
          apply M.add_1; trivial. }
      Qed.
      Lemma add_2 : ¬ E.eq x yMapsTo y e mMapsTo y e (add x e' m).
      Proof.
        unfold MapsTo, add.
        intros H [gen H'].
         gen.
        apply M.add_2; trivial.
      Qed.
      Lemma add_3 : ¬ E.eq x yMapsTo y e (add x e' m) → MapsTo y e m.
      Proof.
        unfold MapsTo, add.
        intros H [gen H'].
         gen.
        apply M.add_3 in H'; trivial.
      Qed.

      Lemma remove_1 : E.eq x y¬ In y (remove x m).
      Proof.
        clear.
        pre_t;
        add_facts.
      Qed.

      Lemma remove_2 : ¬ E.eq x yMapsTo y e mMapsTo y e (remove x m).
      Proof.
        clear.
        pre_t.
        { eexists; eapply M.add_2; eassumption. }
        { eexists; eassumption. }
      Qed.

      Lemma remove_3 : MapsTo y e (remove x m) → MapsTo y e m.
      Proof.
        clear.
        pre_t; try solve [ eexists; eassumption ].
        eexists; eapply M.add_3; try eassumption.
        intro.
        add_facts.
      Qed.

      Lemma find_1 : MapsTo x e mfind x m = Some e.
      Proof.
        clear.
        pre_t;
        add_facts.
        reflexivity.
      Qed.

      Lemma find_2 : find x m = Some eMapsTo x e m.
      Proof.
        clear.
        pre_t;
        add_facts.
        eexists; eassumption.
      Qed.

      Lemma InA_filter_some_eq_key_elt {B : Type} ls a b
      : InA (fun p p' : E.t × BE.eq (fst p) (fst p') snd p = snd p')
            (a, b) (filter_some ls)
        InA
          (fun p p' : E.t × option BE.eq (fst p) (fst p') snd p = snd p')
          (a, Some b) ls.
      Proof.
        clear.
        apply (@InA_filter_some _ B (fun B p p'E.eq (fst p) (fst p') snd p = snd p')); simpl in ×.
        { simpl; intros; split; intros; split; destruct_head and; congruence. }
        { intros ? ? ? [? H']; simpl in *; inversion H'. }
      Qed.

      Lemma elements_1 : MapsTo x e mInA eq_key_elt (x,e) (elements m).
      Proof.
        clear.
        unfold MapsTo, elements.
        intros [gen H].
        apply M.elements_1 in H.
        apply InA_filter_some_eq_key_elt.
        eapply InA_map1; try eassumption.
        intros; hnf in *; pre_t; split; trivial.
      Qed.

      Lemma elements_2 : InA eq_key_elt (x,e) (elements m) → MapsTo x e m.
      Proof.
        clear.
        unfold MapsTo, elements.
        intro H.
        apply InA_filter_some_eq_key_elt in H.
        eapply InA_map3 in H.
        { destruct H as [[k [gen v]] H]; simpl in ×.
           gen; destruct_head and; subst.
          apply M.elements_2 in H.
          add_facts; assumption. }
        { typeclasses eauto. }
      Qed.

      Lemma elements_3w : NoDupA eq_key (elements m).
      Proof.
        clear.
        unfold elements.
        unfold eq_key.
        apply NoDupA_filter_some.
        eapply NoDupA_map2; try apply M.elements_3w; trivial.
      Qed.

      Lemma cardinal_1 : cardinal m = length (elements m).
      Proof.
        clear.
        reflexivity.
      Qed.

      Lemma fold_1 :
         (A : Type) (i : A) (f : keyeltAA),
          fold f m i = fold_left (fun a pf (fst p) (snd p) a) (elements m) i.
      Proof.
        clear.
        reflexivity.
      Qed.

      Definition Equal m m' := y, find y m = find y m'.
      Definition Equiv (eq_elt:elteltProp) m m' :=
        ( k, In k m In k m')
        ( k e e', MapsTo k e mMapsTo k e' m'eq_elt e e').
      Definition Equivb (cmp: elteltbool) := Equiv (Cmp cmp).

      Variable cmp : elteltbool.

      Lemma equal_1 : Equivb cmp m m'equal cmp m m' = true.
      Proof.
        clear.
        unfold equal, Equivb, Equiv, In, MapsTo, Cmp; simpl.
        intros.
        apply M.equal_1.
        unfold M.Equivb, M.Equiv, Cmp;
        repeat match goal with
                 | _intro
                 | [ H : (ex _) → ?T |- _ ]
                   ⇒ specialize (fun x pH (ex_intro _ x p))
                 | [ H : a, ex __ |- _ ]
                   ⇒ specialize (fun a b pH a (ex_intro _ b p))
                 | [ H : a b, ex __ |- _ ]
                   ⇒ specialize (fun a b c pH a b (ex_intro _ c p))
                 | [ H : a b c, ex __ |- _ ]
                   ⇒ specialize (fun a b c d pH a b c (ex_intro _ d p))
                 | [ H : a b c d, ex __ |- _ ]
                   ⇒ specialize (fun a b c d e pH a b c d (ex_intro _ e p))
                 | [ H : a b c d e, ex __ |- _ ]
                   ⇒ specialize (fun a b c d e f pH a b c d e (ex_intro _ f p))
                 | _progress simpl in ×
                 | _progress destruct_head_hnf ex
                 | _progress split_iff
                 | [ |- _ _ ] ⇒ split
                 | [ |- _ _ ] ⇒ split
                 | [ H : M.In _ (M.map _ _) |- _ ] ⇒ unique pose proof (M.map_2 H)
               end;
        repeat match goal with
                 | _progress cleanup
                 | _progress destruct_head option
                 | _progress destruct_head ex
                 | [ H : M.MapsTo _ (_, None) (garbage_collect _) |- _ ]
                   ⇒ apply garbage_collect_1 in H
                 | [ H : M.MapsTo _ (_, Some _) (garbage_collect _) |- _ ]
                   ⇒ apply garbage_collect_2 in H
               end;
        repeat match goal with
                 | [ H : a b c, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _ ]
                   ⇒ unique pose proof (H _ _ _ H')
               end;
        repeat match goal with
                 | _progress cleanup
                 | _progress destruct_head option
                 | _progress destruct_head ex
                 | [ H : M.MapsTo _ (_, None) (garbage_collect _) |- _ ]
                   ⇒ apply garbage_collect_1 in H
                 | [ H : M.MapsTo _ (_, Some _) (garbage_collect _) |- _ ]
                   ⇒ apply garbage_collect_2 in H
                 | _solve [ esplit; eauto using garbage_collect_3
                              | eauto ]
               end.
      Qed.

      Lemma equal_2 : equal cmp m m' = trueEquivb cmp m m'.
      Proof.
        clear.
        unfold equal.
        intro H; apply M.equal_2 in H.
        unfold Equivb, M.Equivb, Equiv, M.Equiv, Cmp, In, M.In, MapsTo in ×.
        repeat match goal with
                 | _intro
                 | _progress cleanup
                 | _progress simpl in ×
                 | _progress destruct_head ex
                 | [ |- _ _ ] ⇒ split
                 | _progress split_iff
                 | [ H : (ex _) → ?T |- _ ]
                   ⇒ specialize (fun x pH (ex_intro _ x p))
                 | [ H : a, ex __ |- _ ]
                   ⇒ specialize (fun a b pH a (ex_intro _ b p))
                 | [ H : a b, ex __ |- _ ]
                   ⇒ specialize (fun a b c pH a b (ex_intro _ c p))
                 | [ H : a b c, ex __ |- _ ]
                   ⇒ specialize (fun a b c d pH a b c (ex_intro _ d p))
                 | [ H : a b c d, ex __ |- _ ]
                   ⇒ specialize (fun a b c d e pH a b c d (ex_intro _ e p))
                 | [ H : a b c d e, ex __ |- _ ]
                   ⇒ specialize (fun a b c d e f pH a b c d e (ex_intro _ f p))
               end;
        repeat match goal with
                 | [ H : M.MapsTo _ (_, Some _) ?m |- _ ]
                   ⇒ atomic m; unique pose proof (garbage_collect_3 H)
                 | [ H : a b, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _ ]
                   ⇒ unique pose proof (H _ _ H')
               end;
        destruct_head ex;
        cleanup;
        destruct_head option;
        repeat match goal with
                 | [ H : M.MapsTo _ (_, Some _) (garbage_collect _) |- _ ]
                   ⇒ unique pose proof (garbage_collect_2 H)
               end;
        repeat match goal with
                 | _intro
                 | _progress cleanup
                 | _progress simpl in ×
                 | _progress destruct_head option
                 | _progress destruct_head ex
                 | [ H : M.MapsTo _ (_, None) (garbage_collect _) |- _ ]
                   ⇒ apply garbage_collect_1 in H
                 | _solve [ eauto ]
               end.
        repeat match goal with
                 | [ H : a, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _ ]
                   ⇒ unique pose proof (H _ H')
                 | [ H : a b c, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _ ]
                   ⇒ unique pose proof (fun cH _ _ c H')
               end.
        simpl in ×.
        eauto.
      Qed.
    End Spec.
  End elt.

  Lemma map_1 : (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:eltelt'),
                  MapsTo x e mMapsTo x (f e) (map f m).
  Proof.
    unfold MapsTo, map.
    intros; destruct_head ex.
    eexists.
    apply (fun g ⇒ @M.map_1 _ (nat × option elt') m x (g, Some e) (fun v(fst v, option_map f (snd v))));
      eassumption.
  Qed.

  Lemma map_2 : (elt elt':Type)(m: t elt)(x:key)(f:eltelt'),
                  In x (map f m) → In x m.
  Proof.
    unfold map, In, MapsTo.
    intros; destruct_head ex.
    pose proof (@M.map_2) as H'.
    specialize (fun a b c d e f gH' a b c d e (ex_intro _ f g)); simpl in ×.
    specialize (H' _ _ _ _ _ _ H).
    destruct_head_hnf ex.
    destruct_head_hnf prod.
    destruct_head_hnf option.
    { repeat eexists; eassumption. }
    { exfalso.
      match goal with
        | [ H : M.MapsTo ?x (_, None) ?m, H' : M.MapsTo ?x (?g, Some ?v) (M.map ?f ?m) |- _ ]
          ⇒ apply (M.map_1 f) in H
      end.
      add_facts.
      simpl in ×.
      congruence. }
  Qed.

  Lemma mapi_1 : (elt elt':Type)(m: t elt)(x:key)(e:elt)
                            (f:keyeltelt'), MapsTo x e m
                                                 y, E.eq y x MapsTo x (f y e) (mapi f m).
  Proof.
    unfold key, t, mapi, In, MapsTo.
    intros ? ? ? ? ? ? [gen H].
    let f := match goal with |- appcontext[M.mapi ?f] ⇒ constr:f end in
    pose proof (M.mapi_1 f H) as H'; simpl in ×.
    destruct_head_hnf ex.
    destruct_head_hnf prod.
    destruct_head_hnf and.
    destruct_head_hnf option.
    repeat esplit; eassumption.
  Qed.

  Lemma mapi_2 : (elt elt':Type)(m: t elt)(x:key)
                        (f:keyeltelt'), In x (mapi f m) → In x m.
  Proof.
    unfold key, t, mapi, In, MapsTo.
    intros ? ? ? ? ? [v [gen H]].
    pose proof (fun a b c d e f g ⇒ @M.mapi_2 a b c d e (ex_intro _ f g)) as H'; simpl in H'.
    specialize (H' _ _ _ _ _ _ H).
    destruct_head_hnf ex.
    destruct_head_hnf prod.
    destruct_head_hnf and.
    destruct_head_hnf option.
    { repeat esplit; eassumption. }
    { exfalso.
      match goal with
        | [ H : M.MapsTo ?x (_, None) ?m, H' : M.MapsTo ?x (?g, Some ?v) (M.mapi ?f ?m) |- _ ]
          ⇒ apply (M.mapi_1 f) in H
      end.
      destruct_head ex.
      destruct_head and.
      add_facts. }
  Qed.

  Lemma map2_1 : (elt elt' elt'':Type)(m: t elt)(m': t elt')
                        (x:key)(f:option eltoption elt'option elt''),
                   In x m In x m'
                   find x (map2 f m m') = f (find x m) (find x m').
  Proof.
    unfold key, t, map2, In, MapsTo, find.
    intros; rewrite M.map2_1.
    { destruct_head or;
      destruct_head ex;
      add_facts; cleanup;
      do 2 edestruct @M.find;
      cleanup;
      destruct_head option;
      match goal with
        | [ |- appcontext[match ?E with __ end] ] ⇒ destruct E; reflexivity
      end. }
    { destruct_head or; [ left | right ];
      unfold M.In;
      destruct_head ex;
      repeat esplit; eassumption. }
  Qed.

  Lemma map2_2 : (elt elt' elt'':Type)(m: t elt)(m': t elt')
                        (x:key)(f:option eltoption elt'option elt''),
                   In x (map2 f m m') → In x m In x m'.
  Proof.
    unfold key, t, map2, In, MapsTo, find.
    intros ? ? ? ? ? ? ? [v [gen H]].
    pose proof (fun a b c d e f g h i ⇒ @M.map2_2 a b c d e f g (ex_intro _ h i)) as H'; simpl in H'.
    specialize (H' _ _ _ _ _ _ _ _ H).
    match goal with
      | [ H : M.In ?x ?m M.In ?x ?m' |- _ ] ⇒
        case_eq (M.find x m);
          case_eq (M.find x m');
          intros
    end;
      destruct_head or;
      destruct_head_hnf ex;
      destruct_head prod;
      destruct_head option;
      try solve [ left; repeat esplit; eassumption
                | right; repeat esplit; eassumption ];
      (lazymatch goal with
      | [ H : M.MapsTo ?x (_, None) ?m, H' : M.find ?x ?m = Some (_, Some _) |- _ ]
        ⇒ (exfalso; revert H H'; clear;
            intros;
            add_facts;
            congruence)
      | [ H : M.MapsTo ?x (_, _) ?m, H' : M.find ?x ?m = None |- _ ]
        ⇒ (exfalso; revert H H'; clear;
            intros;
            add_facts;
            congruence)
      | _idtac
       end);
      try solve [ left; repeat esplit; apply M.find_2; eassumption
                | right; repeat esplit; apply M.find_2; eassumption ];
      try match goal with
            | [ H : M.MapsTo _ _ (M.map2 _ _ _) |- _ ]
              ⇒ apply M.find_1 in H;
                rewrite M.map2_1 in H by constructor (repeat esplit; apply M.find_2; eassumption)
          end;
      cleanup.
  Qed.

  Definition lt_key := M.lt_key.

  Lemma Forall_filter_some {A B} (P : AProp) ls
  : List.Forall (fun pP (fst p)) ls
    → List.Forall (fun pP (fst p)) (filter_some (B := B) ls).
  Proof.
    induction ls; intro H; destruct_head prod; destruct_head option; inversion H; subst;
    try constructor; eauto.
  Qed.

  Lemma Sorted_filter_some {A} f `{Transitive A f} {B} ls
  : Sorted (fun p p' : A × option Bf (fst p) (fst p')) ls
    → Sorted (fun p p'f (fst p) (fst p')) (filter_some ls).
  Proof.
    intro H'.
    apply Sorted_StronglySorted in H'; try solve [ repeat intro; etransitivity; eassumption ].
    apply StronglySorted_Sorted; try solve [ repeat intro; etransitivity; eassumption ].
    induction H'; try solve [ constructor ].
    destruct_head prod; destruct_head option; simpl; trivial;
    constructor; trivial.
    apply Forall_filter_some; trivial.
  Qed.

  Lemma Sorted_map {A B} (lt : relation A) (lt' : relation B) (f : AB)
        (H : x y, lt x ylt' (f x) (f y)) ls
  : Sorted lt lsSorted lt' (List.map f ls).
  Proof.
    induction ls; intro H'; simpl; constructor;
    inversion H'; subst; eauto.
    destruct_head HdRel; constructor; eauto.
  Qed.

  Lemma elements_3 : (elt : Type) (m : t elt),
                       Sorted (lt_key (elt:=elt)) (elements m).
  Proof.
    unfold elements; intros.
    unfold lt_key.
    unfold M.lt_key.
    apply Sorted_filter_some; try solve [ hnf; apply E.lt_trans ].
    eapply Sorted_map; try apply M.elements_3.
    unfold M.lt_key; simpl; trivial.
  Qed.

  Section merge.
    Variable elt : Type.

    Definition merge (m1 : t elt) (m2 : t elt) : t elt
      := M.map2
           (fun a b
            ⇒ match a, b with
                 | Some (gen0, v0), Some (gen1, v1)
                   ⇒ Some (if (Compare_dec.leb gen0 gen1 : bool)%nat
                            then (gen1, v1)
                            else (gen0, v0))
                 | Some gv, NoneSome gv
                 | None, Some gvSome gv
                 | None, NoneNone
               end)
           m1 m2.

    Lemma merge_In_1 : k m1 m2, In k m1In k m2In k (merge m1 m2).
    Proof.
      unfold In, merge, MapsTo.
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress destruct_head ex
               | [ H : M.MapsTo _ _ _ |- _ ] ⇒ unique pose proof (M.find_1 H)
               | _setoid_rewrite <- (@M.find_2 : a b c d, impl _ _)
               | _rewrite M.map2_1
               | [ |- appcontext[match ?E with __ end] ] ⇒ case_eq E
               | _solve [ repeat esplit
                            | left; repeat esplit; eassumption
                            | right; repeat esplit; eassumption ]
             end.
    Qed.

    Lemma merge_In_2 : k m1 m2, In k (merge m1 m2) → In k m1 In k m2.
    Proof.
      unfold In, merge, MapsTo.
      intros; destruct_head ex.
      (lazymatch goal with
        | [ H : M.MapsTo ?k ?v (M.map2 ?f ?m1 ?m2) |- _ ]
          ⇒ (idtac;
              let T := constr:(fun a b c d e f' g h i ⇒ @M.map2_2 a b c d e f' g (ex_intro _ h i)) in
              let H' := fresh in
              pose proof (M.map2_1 f (T _ _ _ _ _ _ _ _ H)) as H';
              apply M.find_1 in H;
              simpl in *;
                rewrite H' in H)
       end).
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress destruct_head_hnf ex
               | _progress destruct_head or
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | _setoid_rewrite <- (@M.find_2 : a b c d, impl _ _)
               | _solve [ repeat esplit
                            | left; repeat esplit; eassumption
                            | right; repeat esplit; eassumption ]
             end.
    Qed.

    Lemma merge_find_1 : k v m1 m2, find k m1 = Some vfind k m2 = Some vfind k (merge m1 m2) = Some v.
    Proof.
      unfold find, merge.
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress destruct_head_hnf ex
               | _progress destruct_head or
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
               | _setoid_rewrite <- (@M.find_2 : a b c d, impl _ _)
               | _rewrite M.map2_1
               | _solve [ repeat esplit
                            | left; repeat esplit; eassumption
                            | right; repeat esplit; eassumption ]
             end;
      repeat match goal with
               | [ H : M.find ?x ?m = Some ?e |- _ ]
                 ⇒ unique pose proof (M.find_2 H)
               | [ H : M.MapsTo ?k ?v ?m |- _ ]
                 ⇒ unique pose proof (ex_intro (fun vM.MapsTo k v m) v H : M.In k m)
               | [ H : context[M.map2 ?f ?m1 ?m2], H' : M.In ?k ?m1 |- _ ]
                 ⇒ unique pose proof (M.map2_1 (m := m1) (m' := m2) f (or_introl H'))
               | [ H : context[M.map2 ?f ?m1 ?m2], H' : M.In ?k ?m2 |- _ ]
                 ⇒ unique pose proof (M.map2_1 (m := m1) (m' := m2) f (or_intror H'))
             end;
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress simpl in ×
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
             end.
    Qed.

    Lemma merge_find_2 : k v m1 m2, find k m1 = Nonefind k (merge m1 m2) = Some vfind k m2 = Some v.
    Proof.
      unfold find, merge.
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress destruct_head_hnf ex
               | _progress destruct_head or
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
               | _setoid_rewrite <- (@M.find_2 : a b c d, impl _ _)
               | _rewrite M.map2_1
               | _solve [ repeat esplit
                            | left; repeat esplit; eassumption
                            | right; repeat esplit; eassumption ]
             end;
      repeat match goal with
               | [ H : M.find ?x ?m = Some ?e |- _ ]
                 ⇒ unique pose proof (M.find_2 H)
               | [ H : M.MapsTo ?k ?v ?m |- _ ]
                 ⇒ unique pose proof (ex_intro (fun vM.MapsTo k v m) v H : M.In k m)
               | [ H : context[M.map2 ?f ?m1 ?m2], H' : M.In ?k ?m1 |- _ ]
                 ⇒ unique pose proof (M.map2_1 (m := m1) (m' := m2) f (or_introl H'))
               | [ H' : M.In ?k (M.map2 ?f ?m1 ?m2) |- _ ]
                 ⇒ unique pose proof (M.map2_2 H')
               | [ H : context[M.map2 ?f ?m1 ?m2], H' : M.In ?k ?m2 |- _ ]
                 ⇒ unique pose proof (M.map2_1 (m := m1) (m' := m2) f (or_intror H'))
             end;
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress simpl in ×
               | _progress destruct_head or
               | _progress destruct_head_hnf ex
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
             end;
      repeat match goal with
               | [ H : appcontext[M.map2] |- _ ] ⇒ clear H
             end;
      add_facts; cleanup.
    Qed.

    Lemma merge_find_3 : k v m1 m2, find k m2 = Nonefind k (merge m1 m2) = Some vfind k m1 = Some v.
      unfold find, merge.
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress destruct_head_hnf ex
               | _progress destruct_head or
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
               | _setoid_rewrite <- (@M.find_2 : a b c d, impl _ _)
               | _rewrite M.map2_1
               | _solve [ repeat esplit
                            | left; repeat esplit; eassumption
                            | right; repeat esplit; eassumption ]
             end;
      repeat match goal with
               | [ H : M.find ?x ?m = Some ?e |- _ ]
                 ⇒ unique pose proof (M.find_2 H)
               | [ H : M.MapsTo ?k ?v ?m |- _ ]
                 ⇒ unique pose proof (ex_intro (fun vM.MapsTo k v m) v H : M.In k m)
               | [ H : context[M.map2 ?f ?m1 ?m2], H' : M.In ?k ?m1 |- _ ]
                 ⇒ unique pose proof (M.map2_1 (m := m1) (m' := m2) f (or_introl H'))
               | [ H' : M.In ?k (M.map2 ?f ?m1 ?m2) |- _ ]
                 ⇒ unique pose proof (M.map2_2 H')
               | [ H : context[M.map2 ?f ?m1 ?m2], H' : M.In ?k ?m2 |- _ ]
                 ⇒ unique pose proof (M.map2_1 (m := m1) (m' := m2) f (or_intror H'))
             end;
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress simpl in ×
               | _progress destruct_head or
               | _progress destruct_head_hnf ex
               | [ H : appcontext[match ?E with __ end] |- _ ]
                 ⇒ revert H; case_eq E
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
             end;
      repeat match goal with
               | [ H : appcontext[M.map2] |- _ ] ⇒ clear H
             end;
      add_facts; cleanup.
    Qed.
  End merge.

  Definition from_internal_elements {elt} (elements : list (M.key × (nat × option elt)))
  : t elt
    := fold_right
         (fun kv accM.add (fst kv) (snd kv) acc)
         (@M.empty _)
         elements.

  Lemma not_eq_InA {A B} (k k' : A) (v v' : B) (RA : relation A) (R R' : relation (A × B))
        (ls : list (A × B))
        (H0 : InA R (k, v) ls)
        (H1 : ¬InA R' (k', v') ls)
        (HR : a, R (k, v) aRA k' kR' (k', v') a)
  : ¬RA k' k.
  Proof.
    induction ls; inversion H0; clear H0; subst.
    { intro H'; apply H1; left; eauto. }
    { apply IHls; eauto. }
  Qed.

  Local Ltac split_ex_in_hyps :=
    repeat match goal with
             | [ H : (ex _) → ?T |- _ ]
               ⇒ specialize (fun x pH (ex_intro _ x p))
             | [ H : a, ex __ |- _ ]
               ⇒ specialize (fun a b pH a (ex_intro _ b p))
             | [ H : a b, ex __ |- _ ]
               ⇒ specialize (fun a b c pH a b (ex_intro _ c p))
             | [ H : a b c, ex __ |- _ ]
               ⇒ specialize (fun a b c d pH a b c (ex_intro _ d p))
             | [ H : a b c d, ex __ |- _ ]
               ⇒ specialize (fun a b c d e pH a b c d (ex_intro _ e p))
             | [ H : a b c d e, ex __ |- _ ]
               ⇒ specialize (fun a b c d e f pH a b c d e (ex_intro _ f p))
             | [ H : a, and _ __ |- _ ]
               ⇒ specialize (fun a c dH a (conj c d))
             | [ H : a b, and _ __ |- _ ]
               ⇒ specialize (fun a b c dH a b (conj c d))
             | [ H : a b c d, and _ __ |- _ ]
               ⇒ specialize (fun a b c d x yH a b c d(conj x y))
             | [ H : a b c d e f, and _ __ |- _ ]
               ⇒ specialize (fun a b c d e f x yH a b c d e f (conj x y))
             | [ H : (z : prod _ _), _ |- _ ]
               ⇒ specialize (fun x yH (x, y))
             | [ H : a (z : prod _ _), _ |- _ ]
               ⇒ specialize (fun a x yH a (x, y))
             | [ H : a b (z : prod _ _), _ |- _ ]
               ⇒ specialize (fun a b x yH a b (x, y))
             | [ H : a b c (z : prod _ _), _ |- _ ]
               ⇒ specialize (fun a b c x yH a b c (x, y))
             | [ H : a b c d (z : prod _ _), _ |- _ ]
               ⇒ specialize (fun a b c d x yH a b c d (x, y))
             | _progress simpl in ×
           end.

  Lemma InA_NoDupA_eq {A R R'} `{Symmetric A R, Transitive A R, Equivalence A R'}
        (x y : A)
        (ls : list A)
        (H_0 : InA R x ls)
        (H_1 : InA R y ls)
        (H_D : NoDupA R' ls)
        (HRR' : a b, R a bR' a b)
        (HR' : R' x y)
  : R x y.
  Proof.
    induction ls;
    inversion H_0; clear H_0; subst;
    inversion H_1; clear H_1; subst;
    inversion H_D; clear H_D; subst;
    eauto.
    { match goal with
        | [ H : ¬_ |- _ ] ⇒ exfalso; apply H; clear H
      end.
      erewrite <- HRR' by eassumption.
      rewrite HR'; eauto.
      apply InA_alt.
      match goal with
        | [ H : InA _ _ _ |- _ ] ⇒ apply InA_alt in H
      end.
      destruct_head ex.
      destruct_head and.
      eauto. }
    { match goal with
        | [ H : ¬_ |- _ ] ⇒ exfalso; apply H
      end.
      erewrite <- HRR' by eassumption.
      rewrite <- HR'; eauto.
      apply InA_alt.
      match goal with
        | [ H : InA _ _ _ |- _ ] ⇒ apply InA_alt in H
      end.
      destruct_head ex.
      destruct_head and.
      eauto. }
  Qed.

  Lemma InA_NoDupA_eq_fine_0 {A R0 R1 R'} `{Transitive A R', Symmetric A R'}
        (x y : A)
        (ls : list A)
        (H_0 : InA R0 x ls)
        (H_1 : InA R1 y ls)
        (H_D : NoDupA R' ls)
        (HR0R' : a b, R0 a bR' b a)
        (HR1R' : a b, R1 a bR' b a)
        (HR' : R' x y)
  : a, R0 x a R1 y a.
  Proof.
    induction ls;
    inversion H_0; clear H_0; subst;
    inversion H_1; clear H_1; subst;
    inversion H_D; clear H_D; subst;
    eauto.
    { match goal with
        | [ H : ¬_ |- _ ] ⇒ exfalso; apply H; clear H
      end.
      repeat match goal with
               | [ H : _ |- _ ] ⇒ setoid_rewrite InA_alt in H
               | _setoid_rewrite InA_alt
               | _progress destruct_head ex
               | _progress destruct_head and
               | _progress unfold Basics.flip in ×
               | _solve [ repeat esplit; try eassumption; etransitivity; eauto ]
             end. }
    { match goal with
        | [ H : ¬_ |- _ ] ⇒ exfalso; apply H; clear H
      end.
      repeat match goal with
               | [ H : _ |- _ ] ⇒ setoid_rewrite InA_alt in H
               | _setoid_rewrite InA_alt
               | _progress destruct_head ex
               | _progress destruct_head and
               | _progress unfold Basics.flip in ×
               | _solve [ repeat esplit; try eassumption; etransitivity; eauto ]
             end. }
  Qed.

  Lemma InA_NoDupA_eq_fine_1 {A R R'} `{Transitive A R', Symmetric A R'}
        (x y : A)
        (ls : list A)
        (H_0 : InA R x ls)
        (H_1 : InA (Basics.flip R) y ls)
        (H_D : NoDupA R' ls)
        (HRR' : a b, R a bR' b a)
        (HR' : R' x y)
        (HRT : a, R x aR a yR x y)
  : R x y.
  Proof.
    induction ls;
    inversion H_0; clear H_0; subst;
    inversion H_1; clear H_1; subst;
    inversion H_D; clear H_D; subst;
    eauto.
    { match goal with
        | [ H : ¬_ |- _ ] ⇒ exfalso; apply H; clear H
      end.
      repeat match goal with
               | [ H : _ |- _ ] ⇒ setoid_rewrite InA_alt in H
               | _setoid_rewrite InA_alt
               | _progress destruct_head ex
               | _progress destruct_head and
               | _progress unfold Basics.flip in ×
               | _solve [ repeat esplit; try eassumption; eauto ]
             end. }
    { match goal with
        | [ H : ¬_ |- _ ] ⇒ exfalso; apply H; clear H
      end.
      repeat match goal with
               | [ H : _ |- _ ] ⇒ setoid_rewrite InA_alt in H
               | _setoid_rewrite InA_alt
               | _progress destruct_head ex
               | _progress destruct_head and
               | _progress unfold Basics.flip in ×
               | _solve [ repeat esplit; try eassumption; etransitivity; eauto ]
             end. }
  Qed.

  Lemma InA_from_internal_elements_1 {elt} (elements : list (M.key × (nat × option elt)))
        k v
        (H0 : NoDupA (@eq_key _) elements)
        (H1 : InA (@M.eq_key_elt _) (k, v) elements)
  : M.MapsTo k v (from_internal_elements elements).
  Proof.
    unfold from_internal_elements.
    induction elements;
    repeat match goal with
             | _progress destruct_head_hnf and
             | _progress cleanup
             | _progress simpl in ×
             | [ H : InA _ _ nil |- _ ] ⇒ solve [ inversion H ]
             | [ H : InA _ _ (_::_) |- _ ] ⇒ (inversion H; clear H)
             | [ H : NoDupA _ nil |- _ ] ⇒ clear H
             | [ H : NoDupA _ (_::_) |- _ ] ⇒ (inversion H; clear H)
             | _apply M.add_1; solve [ assumption | apply E.eq_sym; assumption ]
           end.
    { apply M.add_2; eauto.
      eapply not_eq_InA; try eassumption; [].
      unfold M.eq_key_elt, eq_key; simpl; intros; cleanup.
      eapply E.eq_trans; eassumption. }
  Qed.

  Lemma InA_from_internal_elements_2 {elt} (elements : list (M.key × (nat × option elt)))
        k v
        (H : M.MapsTo k v (from_internal_elements elements))
  : InA (@M.eq_key_elt _) (k, v) elements.
  Proof.
    unfold from_internal_elements in ×.
    induction elements;
    repeat match goal with
             | _progress destruct_head_hnf and
             | _progress cleanup
             | _progress simpl in ×
             | [ H : InA _ _ nil |- _ ] ⇒ solve [ inversion H ]
             | [ H : InA _ _ (_::_) |- _ ] ⇒ (inversion H; clear H)
             | [ H : NoDupA _ nil |- _ ] ⇒ clear H
             | [ H : NoDupA _ (_::_) |- _ ] ⇒ (inversion H; clear H)
             | _apply M.add_1; solve [ assumption | apply E.eq_sym; assumption ]
             | [ H : M.MapsTo _ _ (M.empty _) |- _ ] ⇒ apply M.empty_1 in H
           end.
    match goal with
      | [ H : M.MapsTo ?k ?v (M.add ?k' ?v' ?m) |- _ ]
        ⇒ let H' := fresh in
           destruct (E.eq_dec k' k) as [H'|H'];
             [ left; unique pose proof (M.add_1 m v' H')
             | right; unique pose proof (M.add_3 H' H); eauto ]
    end.
    repeat match goal with
             | [ H : M.MapsTo ?x ?e ?m |- _ ]
               ⇒ unique pose proof (M.find_1 H)
           end;
      cleanup.
    split; simpl; eauto.
  Qed.

  Lemma from_internal_elements_Equal {elt} (m : t elt)
  : Equal m (from_internal_elements (M.elements m)).
  Proof.
    unfold Equal, find.
    intro k.
    repeat match goal with
             | _intro
             | _progress cleanup
             | [ |- appcontext[match ?E with __ end] ] ⇒ case_eq E
           end;
    repeat match goal with
             | [ H : M.find ?x ?m = Some ?e |- _ ]
               ⇒ unique pose proof (M.find_2 H)
             | [ H : M.MapsTo ?k ?v ?m |- _ ]
               ⇒ unique pose proof (M.elements_1 H)
             | [ H : InA _ _ (M.elements ?m) |- _ ]
               ⇒ atomic m; unique pose proof (InA_from_internal_elements_1 (@M.elements_3w _ _) H)
             | [ H : M.MapsTo ?x ?e ?m |- _ ]
               ⇒ unique pose proof (M.find_1 H)
             | [ H : M.MapsTo ?x ?e (from_internal_elements ?ls) |- _ ]
               ⇒ unique pose proof (InA_from_internal_elements_2 _ H)
             | [ H : InA _ _ (M.elements ?m) |- _ ]
               ⇒ unique pose proof (M.elements_2 H)
           end;
      cleanup.
  Qed.

  Lemma from_internal_elements_equiv_refl {elt} R `{Reflexive elt R} (m : t elt)
  : Equiv R m (from_internal_elements (M.elements m)).
  Proof.
    generalize (from_internal_elements_Equal m).
    generalize (from_internal_elements (M.elements m)); intro.
    unfold Equal, Equiv, In.
    intro H'.
    split.
    { intro k; specialize (H' k).
      split; intros [e H''];
      apply find_1 in H'';
      eexists; apply find_2; cleanup; eauto. }
    { intros k e e' H'' H'''.
      specialize (H' k).
      apply find_1 in H''; apply find_1 in H'''.
      cleanup. }
  Qed.

  Fixpoint is_sorted {elt} (elements : list (M.key × (nat × option elt)))
  : bool
    := match elements with
         | niltrue
         | x::xsmatch xs with
                      | niltrue
                      | y::ysmatch E.compare (fst x) (fst y) with
                                   | LT _is_sorted xs
                                   | EQ _false
                                   | GT _false
                                 end
                    end
       end.

  Lemma Sorted_is_sorted {elt} ls
  : @is_sorted elt ls = true Sorted (@M.lt_key _) ls.
  Proof.
    rewrite Sorted_LocallySorted_iff.
    induction ls; simpl; split; intros; try constructor; simpl in *;
    split_iff;
    generalize dependent (is_sorted ls); intros;
    destruct ls; simpl in *; try constructor;
    repeat match goal with
             | [ H : LocallySorted _ (_::_::_) |- _ ] ⇒ (inversion H; clear H)
             | _progress intuition subst
             | _progress hnf in ×
             | [ H : E.lt ?a ?b |- _ ] ⇒ unique pose proof (E.lt_not_eq H : _False)
             | [ H : E.lt ?a ?b, H' : E.lt ?b ?c |- _ ] ⇒ unique pose proof (E.lt_trans H H')
           end;
    edestruct E.compare;
    repeat match goal with
             | _progress subst
             | [ H : E.lt ?a ?b |- _ ] ⇒ unique pose proof (E.lt_not_eq H : _False)
             | [ H : E.lt ?a ?b, H' : E.lt ?b ?c |- _ ] ⇒ unique pose proof (E.lt_trans H H')
             | [ H : False |- _ ] ⇒ destruct H
             | [ H : E.eq ?a ?aFalse |- _ ] ⇒ unique pose proof (H (E.eq_refl _))
             | _eauto; congruence
           end.
  Qed.

  Lemma not_Sorted_is_sorted {elt} ls
  : @is_sorted elt ls = false ¬Sorted (@M.lt_key _) ls.
  Proof.
    rewrite <- Sorted_is_sorted.
    destruct (is_sorted ls); split; congruence.
  Qed.

  Local Instance eq_prod_lt_compat {A R}
  : Proper
      (E.eq × R ==> E.eq × R ==> iff)
      (@M.lt_key A).
  Proof.
    lazy; intros; destruct_head prod; split; destruct_head and; intros;
    match goal with
      | [ H : E.eq ?b ?a, H' : E.lt ?b ?c, H'' : E.eq ?c ?d |- E.lt ?a ?d ]
        ⇒ destruct (E.compare a d); trivial; destruct (E.compare a c); destruct (E.compare b d)
      | [ H : E.eq ?a ?b, H' : E.lt ?b ?c, H'' : E.eq ?d ?c |- E.lt ?a ?d ]
        ⇒ destruct (E.compare a d); trivial; destruct (E.compare a c); destruct (E.compare b d)
    end;
    repeat match goal with
             | [ H : False |- _ ] ⇒ destruct H
             | [ H : E.eq ?x ?y |- _ ]
               ⇒ unique pose proof (E.eq_sym H)
             | [ x : key |- _ ]
               ⇒ unique pose proof (E.eq_refl x)
             | [ H : E.eq ?x ?y, H' : E.eq ?y ?z |- _ ]
               ⇒ unique pose proof (E.eq_trans H H')
             | [ H : E.lt ?x ?y, H' : E.lt ?y ?z |- _ ]
               ⇒ unique pose proof (E.lt_trans H H')
             | [ H : E.lt ?x ?y, H' : E.eq ?x ?y |- _ ]
               ⇒ unique pose proof (E.lt_not_eq H H')
           end.
  Qed.

  Local Instance eq_lt_compat {A}
  : Proper
      (@eq_key A ==> @eq_key A ==> iff)
      (@M.lt_key A).
  Proof.
    lazy; intros; destruct_head prod; split; intros;
    match goal with
      | [ H : E.eq ?b ?a, H' : E.lt ?b ?c, H'' : E.eq ?c ?d |- E.lt ?a ?d ]
        ⇒ destruct (E.compare a d); trivial; destruct (E.compare a c); destruct (E.compare b d)
      | [ H : E.eq ?a ?b, H' : E.lt ?b ?c, H'' : E.eq ?d ?c |- E.lt ?a ?d ]
        ⇒ destruct (E.compare a d); trivial; destruct (E.compare a c); destruct (E.compare b d)
    end;
    repeat match goal with
             | [ H : False |- _ ] ⇒ destruct H
             | [ H : E.eq ?x ?y |- _ ]
               ⇒ unique pose proof (E.eq_sym H)
             | [ x : key |- _ ]
               ⇒ unique pose proof (E.eq_refl x)
             | [ H : E.eq ?x ?y, H' : E.eq ?y ?z |- _ ]
               ⇒ unique pose proof (E.eq_trans H H')
             | [ H : E.lt ?x ?y, H' : E.lt ?y ?z |- _ ]
               ⇒ unique pose proof (E.lt_trans H H')
             | [ H : E.lt ?x ?y, H' : E.eq ?x ?y |- _ ]
               ⇒ unique pose proof (E.lt_not_eq H H')
           end.
  Qed.

  Lemma Sorted_eqlistA {elt} {R'} `{Transitive elt R'} {R : relation elt} ls ls'
        `{Proper _ (R ==> R ==> iff)%signature R'}
  : eqlistA R ls ls' → (Sorted R' ls Sorted R' ls').
  Proof.
    rewrite !Sorted_LocallySorted_iff.
    revert ls'; induction ls; intros ls' HE.
    { inversion HE; subst; reflexivity. }
    { split; intro Hls; inversion Hls; clear Hls; subst;
      inversion HE; clear HE; subst;
      repeat match goal with
               | _progress subst
               | _progress split_iff
               | [ H : eqlistA _ _ nil |- _ ] ⇒ (inversion H; clear H)
               | [ H : eqlistA _ nil _ |- _ ] ⇒ (inversion H; clear H)
               | [ H : eqlistA _ (_::_) ?x |- _ ] ⇒ (atomic x; inversion H)
               | [ H : eqlistA _ ?x (_::_) |- _ ] ⇒ (atomic x; inversion H)
               | _solve [ constructor | eauto ]
               | [ |- LocallySorted _ (_::_::_) ] ⇒ constructor; eauto
               | _progress unfold Proper, respectful, impl in ×
             end. }
  Qed.

  Local Instance eq_key_Equivalence {A} : Equivalence (@eq_key A).
  Proof.
    split; typeclasses eauto.
  Qed.

  Local Instance lt_key_StrictOrder {A} : StrictOrder (@M.lt_key A).
  Proof.
    split.
    { intros x H'.
      apply E.lt_not_eq in H'.
      apply H', E.eq_refl. }
    { intros ???; apply E.lt_trans. }
  Qed.

  Lemma is_sorted_NoDupA {elt} ls
        (H : @is_sorted elt ls = true)
  : NoDupA (@eq_key _) ls.
  Proof.
    apply Sorted_is_sorted in H.
    eapply SortA_NoDupA; eauto; typeclasses eauto.
  Qed.

  Definition sorted_from_internal_elements {elt} (ls : option (list _))
    := match ls with
         | Some ls'if @is_sorted elt ls'
                       then Some (from_internal_elements ls')
                       else None
         | NoneNone
       end.

  Local Instance Serializable_map {elt} `{Serializable elt} : Serializable (t elt)
    := {| to_string x := to_string (M.elements x) |}.

  Local Instance Deserializable_map {elt} `{Deserializable elt} : Deserializable (t elt)
    := {| from_string s := prod_map
                             (sorted_from_internal_elements)
                             id
                             (from_string (A := list (M.key × (nat × option elt))) s) |}.

  Local Opaque Serializable_list.
  Local Opaque Deserializable_list.

  Lemma eqlistA_nil {A R'} `{Reflexive A R'} {R} (ls : list A)
  : eqlistA R nil ls x, ¬InA R' x ls.
  Proof.
    destruct ls; split; auto.
    { intros H0 x H'; inversion H'. }
    { intro H0; inversion H0. }
    { intro H'; exfalso; eapply H'; left; reflexivity. }
  Qed.

  Local Instance MEquiv_Reflexive {elt eq_elt} `{Reflexive elt eq_elt}
  : Reflexive (@M.Equiv elt eq_elt).
  Proof.
    lazy; firstorder.
    add_facts; reflexivity.
  Qed.

  Local Instance Equiv_Transitive {elt eq_elt} `{Transitive elt eq_elt}
  : Transitive (@Equiv elt eq_elt).
  Proof.
    lazy.
    repeat match goal with
             | _intro
             | _progress cleanup
             | _progress destruct_head ex
             | _progress simpl in ×
             | _solve [ eauto ]
             | [ H : (ex _) → ?T |- _ ]
               ⇒ specialize (fun x pH (ex_intro _ x p))
             | [ H : a, ex __ |- _ ]
               ⇒ specialize (fun a b pH a (ex_intro _ b p))
             | [ H : a b, ex __ |- _ ]
               ⇒ specialize (fun a b c pH a b (ex_intro _ c p))
             | [ H : a b c, ex __ |- _ ]
               ⇒ specialize (fun a b c d pH a b c (ex_intro _ d p))
             | [ H : a b c d, ex __ |- _ ]
               ⇒ specialize (fun a b c d e pH a b c d (ex_intro _ e p))
             | [ H : a b c d e, ex __ |- _ ]
               ⇒ specialize (fun a b c d e f pH a b c d e (ex_intro _ f p))
           end.
    repeat match goal with
             | [ H : a b c d, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _]
               ⇒ unique pose proof (fun cH _ _ c _ H')
             | [ H : a b c, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _]
               ⇒ unique pose proof (H _ _ _ H')
           end;
      destruct_head ex.
    eauto.
  Qed.

  Lemma InA_impl {A} (R1 R2 : relation A) x ls
        (H' : InA R1 x ls)
        (H : a, R1 x aR2 x a)
  : InA R2 x ls.
  Proof.
    induction ls; inversion H'; clear H'; subst.
    { left; eauto. }
    { right; eauto. }
  Qed.

  Lemma adj_elements_helper {elt} eq_elt `{Equivalence elt eq_elt} ls (m : t elt)
        (R0 := eq)
        (R1 := @M.eq_key_elt _)
        (HND : NoDupA (@eq_key _) ls)
  : ( x, InA R1 x ls InA R1 x (M.elements m))
     M.Equiv R0 (from_internal_elements ls) m.
  Proof.
    unfold M.Equiv, M.In; subst R0 R1.
    repeat (split || intro);
      repeat match goal with
               | [ H : _ |- _ ]
                 ⇒ setoid_rewrite (@InA_from_internal_elements_2 : a b c d, impl _ _) in H
               | [ H : appcontext[M.MapsTo _ _ (from_internal_elements ?ls)] |- _ ]
                 ⇒ setoid_rewrite <- (@InA_from_internal_elements_1 _ ls _ _ HND : impl _ _) in H
               | _progress split_iff
               | _progress destruct_head ex
               | _progress destruct_head prod
               | [ H : a : prod _ _, _ |- _ ] ⇒ specialize (fun a bH (a, b))
               | [ H : _ |- _ ] ⇒ setoid_rewrite <- (M.elements_1 : a b c d, impl _ _) in H
               | [ H : _ |- _ ] ⇒ setoid_rewrite (M.elements_2 : a b c d, impl _ _) in H
               | [ |- e, M.MapsTo ?k e (from_internal_elements ?ls) ]
                 ⇒ setoid_rewrite <- (@InA_from_internal_elements_1 _ ls k _ HND : impl _ _)
               | [ |- InA _ _ (M.elements _) ]
                 ⇒ apply M.elements_1
             end;
      eauto;
      split_ex_in_hyps;
      repeat match goal with
               | [ H : a b c, InA _ _ __, H' : InA _ _ _ |- _ ]
                 ⇒ specialize (H _ _ _ H')
               | [ H : a b c d e, InA _ _ __, H' : InA _ _ _ |- _ ]
                 ⇒ specialize (fun x yH _ _ _ x y H')
               | [ H : a b, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _ ]
                 ⇒ specialize (H _ _ H')
               | [ H : a b c, M.MapsTo _ _ __, H' : M.MapsTo _ _ _ |- _ ]
                 ⇒ specialize (H _ _ _ H')
               | _progress destruct_head ex
               | _progress destruct_head prod
             end;
      try match goal with
            | [ H : InA ?R ?k ?ls, H' : InA ?R' ?k' ?ls |- _ ]
              ⇒ unique pose proof (@InA_NoDupA_eq_fine_0 _ R R' _ _ _ _ _ _ H H' HND)
          end;
      repeat match goal with
               | [ H : ( a b, __) → _ |- _ ] ⇒ specialize (H (fun a b H'E.eq_sym (proj1 H')))
               | [ H : ( a b, __) → _ |- _ ] ⇒ specialize (H (fun a b H'proj1 H'))
               | [ H : __ |- _ ] ⇒ specialize (H (reflexivity _))
               | _progress destruct_head ex
               | _progress unfold M.eq_key_elt in ×
               | _progress simpl in ×
               | _cleanup
             end.
  Qed.

  Local Ltac t_adj_misc_end :=
    eexists; split; [ | eassumption ];
    repeat esplit; simpl;
    eauto.

  Local Ltac t_adj_misc :=
    repeat esplit;
    eapply M.elements_2;
    apply InA_alt;
    t_adj_misc_end.

  Local Ltac t_adj_misc' :=
    repeat match goal with
             | [ H : E.eq ?x ?y |- _ ]
               ⇒ unique pose proof (E.eq_sym H)
             | [ x : key |- _ ]
               ⇒ unique pose proof (E.eq_refl x)
             | [ H : E.eq ?x ?y, H' : E.eq ?y ?z |- _ ]
               ⇒ unique pose proof (E.eq_trans H H')
             | [ H : E.eq ?k' ?k, H' : List.In (?k, ?v) ?ls |- _ ]
               ⇒ unique pose proof (proj2 (@InA_alt _ (@M.eq_key_elt _) (k', v) ls) (ex_intro _ (k, v) (conj (conj H (reflexivity _)) H')))
             | [ H : InA _ _ (M.elements _) |- _ ]
               ⇒ unique pose proof (M.elements_2 H)
             | [ H : M.MapsTo ?x ?e ?m |- _ ]
               ⇒ unique pose proof (M.find_1 H)
           end;
    cleanup.

  Local Ltac t_adj_destruct :=
    repeat match goal with
             | [ H : _ |- _ ] ⇒ setoid_rewrite InA_alt in H
             | _setoid_rewrite InA_alt
             | _progress split_ex_in_hyps
             | _progress destruct_head ex
             | _progress destruct_head_hnf and
             | _progress destruct_head prod
             | _progress destruct_head False
             | _progress subst
             | _progress hnf in ×
             | _progress simpl in ×
             | [ H : (_, _) = (_, _) |- _ ] ⇒ (inversion H; clear H)
             | [ H : appcontext[_ List.In _ _] |- _ ]
               ⇒ edestruct H; clear H; [ repeat ; hnf; simpl | eassumption | ]; simpl; try reflexivity; []
             | [ H : appcontext[ e, M.MapsTo _ _ _] |- _ ]
               ⇒ edestruct H; clear H; [ repeat ; hnf; simpl | eassumption | ]; simpl; try reflexivity; []
             | [ H : appcontext[_ List.In _ _] |- _ ]
               ⇒ edestruct H; clear H; [ solve [ t_adj_misc ] | ]
           end.

  Local Ltac t_adj_specialize :=
    repeat match goal with
             | [ H : a b c d e f, _ → ?T _ _ __, H' : ?T _ _ _ |- _ ]
               ⇒ specialize (fun a b c d e kH a b c d e _ k H')
             | [ H : a b c d e f, _ → ?T _ _ __, H' : ?T _ _ _ |- _ ]
               ⇒ specialize (fun a b c kH a b c _ _ _ k H')
             | [ H : a b c d e, _ → ?T _ _ __, H' : ?T _ _ _ |- _ ]
               ⇒ specialize (fun b c kH _ b c _ _ k H')
             | [ H : a b c, ?T _ _ __, H' : ?T _ _ _ |- _ ]
               ⇒ specialize (H _ _ _ H')
             | [ H : b c, __ |- _ ]
               ⇒ specialize (H _ _ (reflexivity _))
             | [ H : a b c, __ |- _ ]
               ⇒ specialize (H _ _ _ (reflexivity _))
           end.

  Lemma adj_elements' {elt} eq_elt `{Equivalence elt eq_elt} ls (m : t elt)
        (R0 := (eq × option_lift_relation eq_elt)%signature)
        (R1 := (E.eq × R0)%signature)
        (HND : NoDupA (@eq_key _) ls)
  : ( x, InA R1 x ls InA R1 x (M.elements m))
     M.Equiv R0 (from_internal_elements ls) m.
  Proof.
    unfold M.Equiv, M.In; subst R0 R1.
    repeat (split || intro);
      repeat match goal with
               | [ H : _ |- _ ]
                 ⇒ setoid_rewrite (@InA_from_internal_elements_2 : a b c d, impl _ _) in H
               | [ H : appcontext[M.MapsTo _ _ (from_internal_elements ?ls)] |- _ ]
                 ⇒ setoid_rewrite <- (@InA_from_internal_elements_1 _ ls _ _ HND : impl _ _) in H
               | _progress split_iff
               | _progress destruct_head ex
               | _progress destruct_head prod
               | [ H : a : prod _ _, _ |- _ ] ⇒ specialize (fun a bH (a, b))
               | [ H : _ |- _ ] ⇒ setoid_rewrite <- (M.elements_1 : a b c d, impl _ _) in H
               | [ H : _ |- _ ] ⇒ setoid_rewrite (M.elements_2 : a b c d, impl _ _) in H
               | [ |- e, M.MapsTo ?k e (from_internal_elements ?ls) ]
                 ⇒ setoid_rewrite <- (@InA_from_internal_elements_1 _ ls k _ HND : impl _ _)
               | [ |- InA _ _ (M.elements _) ]
                 ⇒ apply M.elements_1
             end;
      eauto;
      t_adj_destruct.
    { repeat first [ progress t_adj_specialize
                   | progress t_adj_destruct ].
      t_adj_misc. }
    { match goal with
        | [ H : M.MapsTo ?x ?e ?m |- _ ]
          ⇒ atomic m; unique pose proof (M.elements_1 H)
      end;
      repeat first [ progress t_adj_specialize
                   | progress t_adj_destruct ].
      eexists; t_adj_misc_end. }
    { repeat first [ progress t_adj_specialize
                   | progress t_adj_destruct ].
      t_adj_misc'. }
    { t_adj_specialize.
      t_adj_destruct.
      t_adj_misc'. }
    { match goal with
        | [ H : M.MapsTo ?x ?e ?m |- _ ]
          ⇒ atomic m; unique pose proof (M.elements_1 H)
      end;
      repeat first [ progress t_adj_specialize
                   | progress t_adj_destruct ].
      t_adj_misc_end.
      t_adj_destruct; destruct_head option;
      trivial; t_adj_destruct.
      { etransitivity; eauto. }
      { etransitivity; eauto. } }
    { match goal with
        | [ H : M.MapsTo ?x ?e ?m |- _ ]
          ⇒ atomic m; unique pose proof (M.elements_1 H)
      end;
      repeat first [ progress t_adj_specialize
                   | progress t_adj_destruct ];
      t_adj_misc'.
      repeat match goal with
               | [ H : ?x = ?y, H' : ?y = ?x |- _ ] ⇒ atomic y; clear H
               | _progress subst
             end.
      t_adj_misc_end.
      lazy.
      destruct_head option; trivial;
      destruct_head False.
      { etransitivity; eauto.
        symmetry; eauto. } }
  Qed.

  Lemma adj_elements_equiv {elt} eq_elt `{Equivalence elt eq_elt} ls (m : t elt)
        (HND : NoDupA (@eq_key _) ls)
  : equivlistA (E.eq × (eq × option_lift_relation eq_elt))%signature
                     ls
                     (M.elements m)
     M.Equiv (eq × option_lift_relation eq_elt)%signature (from_internal_elements ls) m.
  Proof.
    apply adj_elements'; eauto.
  Qed.

  Lemma eqlistA_equivlistA {A} {R R' : relation A} `{Transitive A R'}
        (H0 : x y, R x yR' x y)
        (H1 : x y, R x yR' y x)
        (ls ls' : list A)
  : eqlistA R ls ls'equivlistA R' ls ls'.
  Proof.
    unfold equivlistA in ×.
    revert ls'.
    induction ls; intros ls' H'; inversion H'; subst; clear H';
    hnf; intro x; split; try tauto;
    intro H''; inversion H''; subst; clear H'';
    try solve [ left; etransitivity; eauto
              | split_iff; right; eauto ].
  Qed.

  Lemma NoDupA_eqlistA {A} {R R' : relation A} `{Equivalence A R'} ls ls'
        (H' : x y : A, R x yR' x y)
        (H'' : x y : A, R x yR' y x)
        (HD : NoDupA R' ls')
        (HE : eqlistA R ls ls')
  : NoDupA R' ls.
  Proof.
    revert ls HE; induction ls'; intros ls HE;
    inversion HE; subst; clear HE;
    inversion HD; subst; clear HD;
    trivial.
    constructor; eauto.
    repeat match goal with
             | _intro
             | [ H : ¬_ |- _ ] ⇒ apply H; clear H
             | _eassumption
             | [ H : _ |- _ ] ⇒ rewrite <- H; []
             | [ H : _ |- _ ] ⇒ rewrite (H'' _ _ H); []
             | [ H : _ |- _ ] ⇒ apply eqlistA_equivlistA in H4; unfold Equivalence.equiv in *; eauto; []
           end.
  Qed.

  Lemma adj_elements_1 {elt} eq_elt `{Equivalence elt eq_elt} ls (m : t elt)
  : eqlistA (E.eq × (eq × option_lift_relation eq_elt))%signature
                     ls
                     (M.elements m)
    → M.Equiv (eq × option_lift_relation eq_elt)%signature (from_internal_elements ls) m.
  Proof.
    intro H'.
    rewrite <- adj_elements_equiv; trivial.
    { intros; eapply eqlistA_equivlistA; eauto.
      intros; symmetry; trivial. }
    { assert (Equivalence
                (E.eq ×
                 (@eq nat × option_lift_relation eq_elt)%signature))
        by (split; typeclasses eauto).
      assert (Equivalence (eq_key (elt:=nat × option elt)))
        by (split; typeclasses eauto).
      eapply NoDupA_eqlistA;
        try first [ eassumption
                  | apply M.elements_3w ];
      unfold eq_key; intros; destruct_head_hnf and; hnf in *;
      destruct_head prod;
      eauto. }
  Qed.

  Lemma adj_elements_2 {elt} eq_elt `{Equivalence elt eq_elt} ls (m : t elt)
        (H' : Sorted (@M.lt_key _) ls)
  : M.Equiv (eq × option_lift_relation eq_elt)%signature (from_internal_elements ls) m
    → eqlistA (E.eq × (eq × option_lift_relation eq_elt))%signature
               ls
               (M.elements m).
  Proof.
    pose proof (SortA_NoDupA _ _ _ H') as HND.
    rewrite <- adj_elements_equiv; trivial.
    pose proof (M.elements_3 m).
    eapply SortA_equivlistA_eqlistA;
      try eassumption;
      try typeclasses eauto.
    { split; typeclasses eauto. }
  Qed.

  Lemma MEquiv_Equiv {elt} (eq_elt : relation elt) m1 m2
  : M.Equiv (eq × option_lift_relation eq_elt)%signature m1 m2
    → Equiv eq_elt m1 m2.
  Proof.
    unfold Equiv, M.Equiv, In, M.In, MapsTo.
    repeat match goal with
             | _intro
             | _progress cleanup
             | _progress simpl in ×
             | _progress split_iff
             | _progress destruct_head ex
             | _progress destruct_head option
             | _progress destruct_head_hnf and
             | _progress split_ex_in_hyps
             | _progress hnf in ×
             | _solve [ repeat esplit; eassumption ]
             | [ H : M.MapsTo _ _ _, H' : a b, M.MapsTo _ _ __ |- _ ]
               ⇒ specialize (H' _ _ H)
             | [ H : M.MapsTo _ _ _, H' : a b c, M.MapsTo _ _ __ |- _ ]
               ⇒ specialize (H' _ _ _ H)
             | [ H : M.MapsTo _ _ _, H' : a b c d e, M.MapsTo _ _ __ |- _ ]
               ⇒ specialize (fun d eH' _ _ _ d e H)
             | [ H : M.MapsTo _ _ _, H' : a b c d e f, M.MapsTo _ _ __ |- _ ]
               ⇒ specialize (fun d e fH' _ _ _ d e f H)
           end;
    add_facts; cleanup.
  Qed.

  Lemma from_to_string_map {elt}
        (eq_elt : relation elt)
        `{Equivalence elt eq_elt, PrefixSerializable elt eq_elt}
  : x : t elt,
      option_lift_relation (Equiv eq_elt) (fst (from_string (A := t elt) (to_string x))) (Some x)
       snd (from_string (A := t elt) (to_string x)) = ""%string.
  Proof.
    intros; simpl; unfold id.
    set (R := (eqlistA (E.eq × (eq × (option_lift_relation eq_elt)))%signature) : relation (list (M.key × (nat × option elt)))).
    split.
    { unfold sorted_from_internal_elements.
      simpl.
      pose proof (@from_to_string_1 _ R _ (M.elements x)).
      pose proof (M.elements_3 x).
      repeat match goal with
               | _intro
               | _progress cleanup
               | _progress unfold option_map in ×
               | _progress simpl in ×
               | [ H : is_sorted _ = false |- _ ] ⇒ apply not_Sorted_is_sorted in H
               | [ H : R ?x ?y, H' : Sorted _ ?y |- _ ]
                 ⇒ unique pose proof (proj2 (Sorted_eqlistA H) H')
               | [ H : R ?x ?y, H' : Sorted _ ?x |- _ ]
                 ⇒ unique pose proof (proj1 (Sorted_eqlistA H) H')
               | [ |- appcontext[match ?E with __ end] ]
                 ⇒ case_eq E
               | [ H : ?x = @None ?T, H' : appcontext G[?x] |- _ ]
                 ⇒ let G' := context G[@None T] in
                    assert G' by (rewrite <- H; exact H');
                      clear H'
               | [ H : ?x = Some ?y, H' : appcontext G[?x] |- _ ]
                 ⇒ let G' := context G[Some y] in
                    assert G' by (rewrite <- H; exact H');
                      clear H'
               | _solve [ eauto using MEquiv_Equiv, adj_elements_1 ]
             end. }
    { assert (H' := @from_to_string_2 _ R _).
      apply H'. }
  Qed.

  Lemma prefix_closed_map_strict {elt}
        (eq_elt : relation elt)
        `{Equivalence elt eq_elt, PrefixSerializable elt eq_elt}
        (R0 := (eq × (option_lift_relation eq_elt))%signature)
  : s1 s2 x,
      option_lift_relation (M.Equiv R0) (fst (from_string (A := t elt) s1)) (Some x)
      → option_lift_relation (M.Equiv R0) (fst (from_string (A := t elt) (s1 ++ s2))) (Some x)
          snd (from_string (A := t elt) (s1 ++ s2)) = (snd (from_string (A := t elt) s1) ++ s2)%string.
  Proof.
    simpl; unfold id.
    set (R := eqlistA (E.eq × R0)%signature).
    assert (Reflexive R) by (subst R; typeclasses eauto).
    intros s1 s2 x; split; simpl in *;
    [ assert (H' := @prefix_closed_1 _ R _ s1 s2)
    | assert (H' := @prefix_closed_2 _ R _ s1 s2 (M.elements x)) ];
    repeat match goal with
             | _progress unfold option_map, option_lift_relation in ×
             | _progress cleanup
             | _progress simpl in ×
             | [ H : appcontext[match ?E with __ end] |- _ ]
               ⇒ revert H; case_eq E; intros
             | [ |- appcontext[match ?E with __ end] ]
               ⇒ case_eq E; intros
             | [ H : ?x = @None ?T, H' : appcontext G[?x] |- _ ]
               ⇒ let G' := context G[@None T] in
                  assert G' by (rewrite <- H; exact H');
                    clear H'
             | [ H : ?x = Some ?y, H' : appcontext G[?x] |- _ ]
               ⇒ let G' := context G[Some y] in
                  assert G' by (rewrite <- H; exact H');
                    clear H'
             | [ H : ?x = Some ?y |- appcontext G[?x] ]
               ⇒ let G' := context G[Some y] in
                  let H' := fresh in
                  assert (H' : G');
                    [ | rewrite <- H in H'; exact H' ];
                    simpl
             | _eapply H'; clear H'
             | _solve [ subst R; eauto ]
             | _solve [ subst R; eauto using adj_elements_2, adj_elements_1 ]
             | [ H : is_sorted _ = false |- _ ] ⇒ apply not_Sorted_is_sorted in H
             | [ H : is_sorted _ = true |- _ ] ⇒ apply Sorted_is_sorted in H
             | [ H : R ?x ?y, H' : Sorted _ ?y |- _ ]
               ⇒ unique pose proof (proj2 (Sorted_eqlistA H) H')
             | [ H : R ?x ?y, H' : Sorted _ ?x |- _ ]
               ⇒ unique pose proof (proj1 (Sorted_eqlistA H) H')
             | [ H : _, R _ _R _ _ |- _ ]
               ⇒ unique pose proof (H' _ (reflexivity _))
             | [ H : ?T, H' : ~?T |- _ ] ⇒ destruct (H' H)
           end.
  Qed.

  Lemma prefix_closed_map {elt}
        (eq_elt : relation elt)
        `{Equivalence elt eq_elt, PrefixSerializable elt eq_elt}
  : s1 s2 x,
      option_lift_relation (Equiv eq_elt) (fst (from_string (A := t elt) s1)) (Some x)
      → option_lift_relation (Equiv eq_elt) (fst (from_string (A := t elt) (s1 ++ s2))) (Some x)
          snd (from_string (A := t elt) (s1 ++ s2)) = (snd (from_string (A := t elt) s1) ++ s2)%string.
  Proof.
    intros s1 s2 x.
    pose proof (@prefix_closed_map_strict elt eq_elt _ _ s1 s2).
    repeat match goal with
             | _progress unfold option_lift_relation
             | _progress unfold id in ×
             | [ H : ?x = Some _, H' : appcontext[?x] |- _ ] ⇒ rewrite H in H'
             | [ H : ?x = None, H' : appcontext[?x] |- _ ] ⇒ rewrite H in H'
             | _progress simpl in ×
             | [ H : appcontext[match ?E with __ end] |- _ ]
               ⇒ revert H; case_eq E; intros
             | [ |- appcontext[match ?E with __ end] ]
               ⇒ case_eq E; intros
             | [ H : x, M.Equiv _ _ __ |- _ ]
               ⇒ specialize (H _ (reflexivity _))
             | _progress split_and
             | [ H : False |- _ ] ⇒ destruct H
             | [ H : M.Equiv _ _ _ |- _ ] ⇒ apply MEquiv_Equiv in H
             | [ |- _ _ ] ⇒ split; eauto; []
             | _solve [ etransitivity; eauto ]
           end.
  Qed.

  Definition PrefixSerializable_map {elt} {eq_elt} `{Equivalence elt eq_elt, PrefixSerializable elt eq_elt}
  : PrefixSerializable (t elt) (Equiv eq_elt)
    := {| serialize := _;
          deserialize := _;
          from_to_string := @from_to_string_map elt eq_elt _ _;
          prefix_closed := @prefix_closed_map elt eq_elt _ _ |}.
End MakeSerializableMergableMap.