Library Apps.LabelMap


Require Import Ascii NArith String OrderedType FMapAVL.

Require Import Nomega Labels.

Local Open Scope string_scope.
Local Open Scope N_scope.

Definition ascii_lt (a1 a2 : ascii) := N_of_ascii a1 < N_of_ascii a2.

Fixpoint string_lt (s1 s2 : string) : bool :=
  match s1, s2 with
    | "", String _ _true
    | String _ _, "" ⇒ false
    | String a1 s1', String a2 s2'match (N_of_ascii a1) ?= (N_of_ascii a2) with
                                        | Datatypes.Lttrue
                                        | Gtfalse
                                        | Datatypes.Eqstring_lt s1' s2'
                                      end
    | _, _false
  end.

Section CompSpec.
  Variables (A : Type) (eq lt : AAProp)
    (x y : A) (c : comparison).

  Hypothesis H : CompSpec eq lt x y c.

  Theorem Comp_eq : ( z, lt z zFalse)
    → x = yc = Datatypes.Eq.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.

  Theorem Comp_lt : ( z z', lt z z'eq z z'False)
    → ( z z', lt z z'lt z' zFalse)
    → lt x yc = Datatypes.Lt.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.

  Theorem Comp_gt : ( z z', lt z' zeq z z'False)
    → ( z z', lt z z'lt z' zFalse)
    → lt y xc = Datatypes.Gt.
    inversion H; intros; subst; auto; elimtype False; eauto.
  Qed.
End CompSpec.

Implicit Arguments Comp_eq [A eq0 lt x y c].
Implicit Arguments Comp_lt [A eq0 lt x y c].
Implicit Arguments Comp_gt [A eq0 lt x y c].

Theorem Nlt_irrefl' : n : N, n < nFalse.
  exact Nlt_irrefl.
Qed.

Theorem Nlt_irrefl'' : n n' : N, n = n'n < n'False.
  intros; subst; eapply Nlt_irrefl'; eauto.
Qed.

Theorem Nlt_notboth : x y, x < yy < xFalse.
  intros; eapply Nlt_irrefl'; eapply Nlt_trans; eauto.
Qed.

Hint Immediate Nlt_irrefl' Nlt_irrefl'' Nlt_notboth.

Ltac rewr' := eauto; congruence || eapply Nlt_trans; eassumption.

Ltac rewr := repeat match goal with
                      | [ _ : context[?X ?= ?Y] |- _ ] ⇒ specialize (Ncompare_spec X Y); destruct (X ?= Y); inversion 1
                    end; simpl in *; (rewrite (Comp_eq (@Ncompare_spec _ _)); rewr')
  || (rewrite (Comp_lt (@Ncompare_spec _ _)); rewr')
    || (rewrite (Comp_gt (@Ncompare_spec _ _)); rewr').

Theorem string_lt_trans : s1 s2 s3, string_lt s1 s2 = true
  → string_lt s2 s3 = true
  → string_lt s1 s3 = true.
  induction s1; simpl; intuition; destruct s2; destruct s3; simpl in *; try congruence; rewr.
Qed.

Section hide_hints.
  Hint Resolve string_lt_trans.

  Theorem string_lt_irrel : s, string_lt s s = false.
    induction s; simpl; intuition rewr.
  Qed.

  Hint Rewrite string_lt_irrel : LabelMap.

  Lemma string_tail_neq : a1 a2 s1 s2,
    N_of_ascii a1 = N_of_ascii a2
    → (String a1 s1 = String a2 s2False)
    → (s1 = s2False).
    intros.
    apply (f_equal ascii_of_N) in H.
    repeat rewrite ascii_N_embedding in H.
    congruence.
  Qed.

  Hint Immediate string_tail_neq.

  Theorem string_lt_sym : s1 s2, s1 s2
    → string_lt s1 s2 = false
    → string_lt s2 s1 = true.
    induction s1; destruct s2; simpl; intuition; rewr.
  Qed.

  Hint Resolve string_lt_sym.


  Definition label'_lt (l1 l2 : label') : bool :=
    match l1, l2 with
      | Global _, Local _true
      | Local _, Global _false
      | Global s1, Global s2string_lt s1 s2
      | Local n1, Local n2match n1 ?= n2 with
                                | Datatypes.Lttrue
                                | _false
                              end
    end.

  Theorem label'_lt_trans : l1 l2 l3, label'_lt l1 l2 = true
    → label'_lt l2 l3 = true
    → label'_lt l1 l3 = true.
    induction l1; simpl; intuition; destruct l2; destruct l3; simpl in *; try congruence; eauto; rewr.
  Qed.

  Hint Immediate label'_lt_trans.

  Theorem label'_lt_irrel : l, label'_lt l l = false.
    induction l; simpl; intuition; autorewrite with LabelMap; auto; rewr.
  Qed.

  Hint Rewrite label'_lt_irrel : LabelMap.

  Theorem label'_lt_sym : l1 l2, l1 l2
    → label'_lt l1 l2 = false
    → label'_lt l2 l1 = true.
    induction l1; destruct l2; simpl; intuition.
    eapply string_lt_sym; eauto; congruence.
    rewr.
  Qed.

  Hint Resolve label'_lt_sym.

  Definition label'_eq : x y : label', {x = y} + {x y}.
    decide equality; apply string_dec || apply N_eq_dec.
  Defined.
End hide_hints.

Module LabelKey.
  Definition t := label.

  Definition eq := @eq t.
  Definition lt (l1 l2 : label) := string_lt (fst l1) (fst l2) = true
     (fst l1 = fst l2 label'_lt (snd l1) (snd l2) = true).

  Theorem eq_refl : x : t, eq x x.
    congruence.
  Qed.

  Theorem eq_sym : x y : t, eq x yeq y x.
    congruence.
  Qed.

  Theorem eq_trans : x y z : t, eq x yeq y zeq x z.
    congruence.
  Qed.

  Section hide_hints.
    Hint Resolve string_lt_trans.
    Hint Rewrite string_lt_irrel : LabelMap.
    Hint Immediate string_tail_neq.
    Hint Resolve string_lt_sym.
    Hint Immediate label'_lt_trans.
    Hint Rewrite label'_lt_irrel : LabelMap.
    Hint Resolve label'_lt_sym.
    Hint Rewrite string_lt_irrel label'_lt_irrel : LabelMap.

    Theorem lt_trans : x y z : t, lt x ylt y zlt x z.
      unfold lt; intuition (congruence || eauto).
    Qed.

    Theorem lt_not_eq : x y : t, lt x y¬ eq x y.
      unfold lt, eq; intuition; subst; autorewrite with LabelMap in *; discriminate.
    Qed.

    Definition compare' (x y : t) : comparison :=
      if string_lt (fst x) (fst y)
        then Datatypes.Lt
        else if string_dec (fst x) (fst y)
          then if label'_lt (snd x) (snd y)
            then Datatypes.Lt
            else if label'_eq (snd x) (snd y)
              then Datatypes.Eq
              else Gt
          else Gt.

    Lemma label_eq : x y : label, fst x = fst y
      → snd x = snd y
      → x = y.
      destruct x; destruct y; simpl; congruence.
    Qed.

    Hint Immediate label_eq.

    Definition compare (x y : t) : Structures.OrderedType.Compare lt eq x y.
      refine (match compare' x y as c return c = compare' x yStructures.OrderedType.Compare lt eq x y with
                | Datatypes.Ltfun _Structures.OrderedType.LT _
                | Datatypes.Eqfun _Structures.OrderedType.EQ _
                | Gtfun _Structures.OrderedType.GT _
              end (refl_equal _)); abstract (unfold compare', eq, lt in *;
                repeat match goal with
                         | [ H : context[if ?E then _ else _] |- _ ] ⇒ let Heq := fresh "Heq" in case_eq E; (intros ? Heq || intro Heq);
                           rewrite Heq in H; try discriminate
                       end; intuition).
    Defined.

    Definition eq_dec x y : { eq x y } + { ¬ eq x y }.
      refine (if string_dec (fst x) (fst y)
        then if label'_eq (snd x) (snd y)
          then left _ _
          else right _ _
        else right _ _); abstract (unfold eq in *; destruct x; destruct y; simpl in *; congruence).
    Defined.
  End hide_hints.
End LabelKey.

Module LabelMap := FMapAVL.Make(LabelKey).

Remove Hints LabelMap.E.eq_sym LabelMap.E.eq_refl LabelMap.E.eq_trans LabelMap.E.lt_not_eq LabelMap.E.lt_trans
  LabelMap.Raw.Proofs.L.PX.eqk_refl LabelMap.Raw.Proofs.L.PX.eqk_sym
  LabelMap.Raw.Proofs.L.PX.eqk_trans
  LabelMap.Raw.Proofs.PX.eqk_refl LabelMap.Raw.Proofs.PX.eqk_sym LabelMap.Raw.Proofs.PX.eqk_trans
  LabelMap.Raw.Proofs.L.PX.eqke_refl LabelMap.Raw.Proofs.L.PX.eqke_sym LabelMap.Raw.Proofs.L.PX.eqke_trans
  LabelMap.Raw.Proofs.PX.eqke_refl LabelMap.Raw.Proofs.PX.eqke_sym LabelMap.Raw.Proofs.PX.eqke_trans
  LabelMap.Raw.Proofs.L.PX.MO.lt_eq LabelMap.Raw.Proofs.L.PX.MO.eq_lt LabelMap.Raw.Proofs.L.MX.lt_eq
  LabelMap.Raw.Proofs.L.MX.eq_lt LabelMap.Raw.Proofs.PX.MO.lt_eq LabelMap.Raw.Proofs.PX.MO.eq_lt
  LabelMap.Raw.Proofs.MX.lt_eq LabelMap.Raw.Proofs.MX.eq_lt
  LabelMap.Raw.Proofs.L.PX.eqk_ltk LabelMap.Raw.Proofs.L.PX.ltk_eqk LabelMap.Raw.Proofs.L.PX.ltk_trans
  LabelMap.Raw.Proofs.PX.eqk_ltk LabelMap.Raw.Proofs.PX.ltk_eqk LabelMap.Raw.Proofs.PX.ltk_trans
  LabelMap.Raw.Proofs.L.PX.MO.lt_antirefl
  LabelMap.Raw.Proofs.L.MX.lt_antirefl LabelMap.Raw.Proofs.PX.MO.lt_antirefl LabelMap.Raw.Proofs.MX.lt_antirefl
  LabelMap.Raw.Proofs.L.PX.eqk_not_ltk LabelMap.Raw.Proofs.L.PX.ltk_not_eqke
  LabelMap.Raw.Proofs.L.PX.ltk_not_eqk LabelMap.Raw.Proofs.L.PX.MO.lt_not_gt
  LabelMap.Raw.Proofs.L.PX.MO.eq_not_gt LabelMap.Raw.Proofs.L.PX.MO.eq_neq
  LabelMap.Raw.Proofs.L.PX.MO.neq_eq LabelMap.Raw.Proofs.L.PX.MO.eq_le
  LabelMap.Raw.Proofs.L.PX.MO.le_eq LabelMap.Raw.Proofs.L.PX.MO.eq_not_lt
  LabelMap.Raw.Proofs.L.PX.MO.gt_not_eq LabelMap.Raw.Proofs.L.MX.lt_not_gt
  LabelMap.Raw.Proofs.L.MX.eq_not_gt LabelMap.Raw.Proofs.L.MX.eq_neq
  LabelMap.Raw.Proofs.L.MX.neq_eq LabelMap.Raw.Proofs.L.MX.eq_le
  LabelMap.Raw.Proofs.L.MX.le_eq LabelMap.Raw.Proofs.L.MX.eq_not_lt
  LabelMap.Raw.Proofs.L.MX.gt_not_eq LabelMap.Raw.Proofs.PX.eqk_not_ltk
  LabelMap.Raw.Proofs.PX.ltk_not_eqke LabelMap.Raw.Proofs.PX.ltk_not_eqk
  LabelMap.Raw.Proofs.PX.MO.lt_not_gt LabelMap.Raw.Proofs.PX.MO.eq_not_gt
  LabelMap.Raw.Proofs.PX.MO.eq_neq LabelMap.Raw.Proofs.PX.MO.neq_eq
  LabelMap.Raw.Proofs.PX.MO.eq_le LabelMap.Raw.Proofs.PX.MO.le_eq
  LabelMap.Raw.Proofs.PX.MO.eq_not_lt LabelMap.Raw.Proofs.PX.MO.gt_not_eq
  LabelMap.Raw.Proofs.MX.lt_not_gt LabelMap.Raw.Proofs.MX.eq_not_gt
  LabelMap.Raw.Proofs.MX.eq_neq LabelMap.Raw.Proofs.MX.neq_eq
  LabelMap.Raw.Proofs.MX.eq_le LabelMap.Raw.Proofs.MX.le_eq
  LabelMap.Raw.Proofs.MX.eq_not_lt LabelMap.Raw.Proofs.MX.gt_not_eq
  LabelMap.Raw.Proofs.L.PX.Sort_Inf_NotIn LabelMap.Raw.Proofs.PX.Sort_Inf_NotIn
  LabelMap.Raw.Proofs.L.PX.Inf_eq LabelMap.Raw.Proofs.L.PX.MO.Inf_lt
  LabelMap.Raw.Proofs.L.MX.Inf_lt LabelMap.Raw.Proofs.PX.Inf_eq
  LabelMap.Raw.Proofs.PX.MO.Inf_lt LabelMap.Raw.Proofs.MX.Inf_lt
  LabelMap.Raw.Proofs.L.PX.Inf_lt LabelMap.Raw.Proofs.L.PX.MO.Inf_lt
  LabelMap.Raw.Proofs.L.MX.Inf_lt LabelMap.Raw.Proofs.PX.Inf_lt
  LabelMap.Raw.Proofs.PX.MO.Inf_lt LabelMap.Raw.Proofs.MX.Inf_lt
  LabelMap.Raw.InRight LabelMap.Raw.InLeft LabelMap.Raw.InRoot
  LabelMap.Raw.Proofs.L.PX.InA_eqke_eqk LabelMap.Raw.Proofs.L.PX.MO.In_eq
  LabelMap.Raw.Proofs.L.PX.MO.ListIn_In LabelMap.Raw.Proofs.L.MX.In_eq
  LabelMap.Raw.Proofs.L.MX.ListIn_In LabelMap.Raw.Proofs.PX.InA_eqke_eqk
  LabelMap.Raw.Proofs.PX.MO.In_eq LabelMap.Raw.Proofs.PX.MO.ListIn_In
  LabelMap.Raw.Proofs.MX.In_eq LabelMap.Raw.Proofs.MX.ListIn_In
  LabelMap.Raw.Proofs.L.PX.In_inv_3 LabelMap.Raw.Proofs.PX.In_inv_3
  LabelMap.Raw.Proofs.L.PX.In_inv_2 LabelMap.Raw.Proofs.PX.In_inv_2
  LabelMap.Raw.MapsRight LabelMap.Raw.MapsLeft
  LabelMap.Raw.MapsRoot LabelMap.Raw.Proofs.L.PX.MO.Sort_NoDup
  LabelMap.Raw.Proofs.L.MX.Sort_NoDup LabelMap.Raw.Proofs.PX.MO.Sort_NoDup
  LabelMap.Raw.Proofs.MX.Sort_NoDup
  LabelMap.Raw.BSLeaf LabelMap.Raw.BSNode LabelMap.Raw.Leaf LabelMap.Raw.Node.

Require FMapFacts.
Module LabelFacts := FMapFacts.WFacts_fun(LabelKey)(LabelMap).