(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

Require Import SetoidList Bool OrderedType OrdersLists RelationPairs Orders.
(* Require Import List Bool NArith Psatz Int63. *)
Require Import RelationClasses.

Class DecType T := {
 eq_refl : forall x : T, x = x;
 eq_sym : forall x y : T, x = y -> y = x;
 eq_trans : forall x y z : T, x = y -> y = z -> x = z;
 eq_dec : forall x y : T, { x = y } + { x <> y }
}.

Hint Immediate eq_sym.
Hint Resolve eq_refl eq_trans.

Class OrdType T := {
  lt: T -> T -> Prop;
  lt_trans : forall x y z : T, lt x y -> lt y z -> lt x z;
  lt_not_eq : forall x y : T, lt x y -> ~ eq x y
  (* compare : forall x y : T, Compare lt eq x y *)
}.

Hint Resolve lt_not_eq lt_trans.

(* Global Instance Comparable T `(OrdType T) : *)

Class Comparable T {ot:OrdType T} := {
  compare : forall x y : T, Compare lt eq x y
}.

Set Implicit Arguments.

Module Raw.

  Section Array.

  Variable key : Type.
  Variable elt : Type.
  Variable key_dec : DecType key.
  Variable key_ord : OrdType key.
  Variable key_comp : Comparable key.
  Variable elt_dec : DecType elt.
  Variable elt_ord : OrdType elt.

  Definition eqb_key (x y : key) : bool := if eq_dec x y then true else false.
  Definition eqb_elt (x y : elt) : bool := if eq_dec x y then true else false.

  Lemma eqb_key_eq x y : eqb_key x y = true <-> x = y.
  Proof. unfold eqb_key. case (eq_dec x y); split; easy. Qed.

  Lemma eqb_elt_eq x y : eqb_elt x y = true <-> x = y.
  Proof. unfold eqb_elt. case (eq_dec x y); split; easy. Qed.

  Hint Immediate eqb_key_eq eqb_elt_eq.

  Definition farray := list (key * elt).

  Definition eqk (a b : (key * elt)) := fst a = fst b.
  Definition eqe (a b : (key * elt)) := snd a = snd b.
  Definition eqke (a b : (key * elt)) := fst a = fst b /\ snd a = snd b.

  Definition ltk (a b : (key * elt)) := lt (fst a) (fst b).

  (* Definition ltke (a b : (key * elt)) := *)
  (*   lt (fst a) (fst b) \/ ( (fst a) = (fst b) /\ lt (snd a) (snd b)). *)

  Hint Unfold ltk (* ltke *) eqk eqke.
  Hint Extern 2 (eqke ?a ?b) => split.

  Global Instance StrictOrder_OrdType T `(OrdType T) :
    StrictOrder (lt : T -> T -> Prop).
  Proof.
    split.
    unfold Irreflexive, Reflexive, complement.
    intros. apply lt_not_eq in H0; auto.
    unfold Transitive. intros x y z. apply lt_trans.
  Qed.

  Check (lt : key -> key -> Prop).

  Global Instance lt_key_strorder : StrictOrder (lt : key -> key -> Prop).
  Proof. apply StrictOrder_OrdType. Qed.

  Global Instance lt_elt_strorder : StrictOrder (lt : elt -> elt -> Prop).
  Proof. apply StrictOrder_OrdType. Qed.

  Global Instance ke_dec : DecType (key * elt).
  Proof.
    split; auto.
    intros; destruct x, y, z.
    inversion H. inversion H0. trivial.
    intros; destruct x, y.
    destruct (eq_dec k k0).
    destruct (eq_dec e e0).
    left; rewrite e1, e2; auto.
    right; unfold not in *. intro; inversion H. exact (n H2).
    right; unfold not in *. intro; inversion H. exact (n H1).
  Qed.

  Global Instance ke_ord: OrdType (key * elt).
  Proof.
    exists ltk; unfold ltk; intros.
    apply (lt_trans _ (fst y)); auto.
    destruct x, y. simpl in H.
    unfold not. intro. inversion H0.
    apply (lt_not_eq k k0); auto.
  Qed.

  (* ltk ignore the second components *)

   Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e').
   Proof. auto. Qed.

   Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x.
   Proof. auto. Qed.
   Hint Immediate ltk_right_r ltk_right_l.

  Notation Sort := (sort ltk).
  Notation Inf := (lelistA (ltk)).

  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
  Definition In k m := exists e:elt, MapsTo k e m.

  Notation NoDupA := (NoDupA eqk).

  Hint Unfold MapsTo In.

  (* Instance ke_ord: OrdType (key * elt). *)
  (* Proof. *)
  (*   exists ltke. *)
  (*   unfold ltke. intros. *)
  (*   destruct H, H0. *)
  (*   left; apply (lt_trans _ (fst y)); auto. *)
  (*   destruct H0. left. rewrite <- H0. assumption. *)
  (*   destruct H. left. rewrite H. assumption. *)
  (*   destruct H, H0. *)
  (*   right. split. *)
  (*   apply (eq_trans _ (fst y)); trivial. *)
  (*   apply (lt_trans _ (snd y)); trivial. *)
  (*   unfold ltke. intros. *)
  (*   destruct x, y. simpl in H. *)
  (*   destruct H. *)
  (*   apply lt_not_eq in H. *)
  (*   unfold not in *. intro. inversion H0. apply H. trivial. *)
  (*   destruct H. apply lt_not_eq in H0. unfold not in *. intro.  *)
  (*   inversion H1. apply H0; trivial. *)
  (*   intros. *)
  (*   unfold ltke. *)
  (*   destruct (compare (fst x) (fst y)). *)
  (*   apply LT. left; assumption. *)
  (*   destruct (compare (snd x) (snd y)). *)
  (*   apply LT. right; split; assumption. *)
  (*   apply EQ. destruct x, y. simpl in *. rewrite e, e0; trivial. *)
  (*   apply GT. right; symmetry in e; split; assumption. *)
  (*   apply GT. left; assumption. *)
  (* Qed. *)

  (* Hint Immediate ke_ord. *)
  (* Let ke_ord := ke_ord. *)

  (* Instance keyelt_ord: OrdType (key * elt). *)

  (* Variable keyelt_ord : OrdType (key * elt). *)
   (* eqke is stricter than eqk *)

   Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
   Proof.
     unfold eqk, eqke; intuition.
   Qed.

  (* eqk, eqke are equalities *)

  Lemma eqk_refl : forall e, eqk e e.
  Proof. auto. Qed.

  Lemma eqke_refl : forall e, eqke e e.
  Proof. auto. Qed.

  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
  Proof. auto. Qed.

  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
  Proof. unfold eqke; intuition. Qed.

  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
  Proof. eauto. Qed.

  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
  Proof.
    unfold eqke; intuition; [ eauto | congruence ].
  Qed.

  Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''.
  Proof. eauto. Qed.

  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
  Proof. unfold ltk, eqk. intros. apply lt_not_eq; auto. Qed.

  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
  Proof.
    unfold eqke, ltk; intuition; simpl in *; subst.
    apply lt_not_eq in H. auto.
  Qed.

  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
  Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
  Hint Immediate eqk_sym eqke_sym.

  Global Instance eqk_equiv : Equivalence eqk.
  Proof. split; eauto. Qed.

  Global Instance eqke_equiv : Equivalence eqke.
  Proof. split; eauto. Qed.

  Global Instance ltk_strorder : StrictOrder ltk.
  Proof.
    split.
    unfold Irreflexive, Reflexive, complement.
    intros. apply lt_not_eq in H; auto.
    unfold Transitive. intros x y z. apply lt_trans.
  Qed.

  (* Instance ltke_strorder : StrictOrder ltke. *)
  (* Proof. *)
  (*   split. *)
  (*   unfold Irreflexive, Reflexive, complement. *)
  (*   intros. apply lt_not_eq in H; auto. *)
  (*   unfold Transitive. apply lt_trans. *)
  (* Qed. *)

  Global Instance eq_equiv : @Equivalence (key * elt) eq.
  Proof.
    split; auto.
    unfold Transitive. apply eq_trans.
  Qed.

  (* Instance ltke_compat : Proper (eq ==> eq ==> iff) ltke. *)
  (* Proof. *)
  (*   split; rewrite H, H0; trivial. *)
  (* Qed. *)

  Global Instance ltk_compat : Proper (eq ==> eq ==> iff) ltk.
  Proof.
    split; rewrite H, H0; trivial.
  Qed.

  Global Instance ltk_compatk : Proper (eqk==>eqk==>iff) ltk.
  Proof.
  intros (x,e) (x',e') Hxx' (y,f) (y',f') Hyy'; compute.
   compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto.
  Qed.

  Global Instance ltk_compat' : Proper (eqke==>eqke==>iff) ltk.
  Proof.
  intros (x,e) (x',e') (Hxx',_) (y,f) (y',f') (Hyy',_); compute.
   compute in Hxx'; compute in Hyy'. rewrite Hxx', Hyy'; auto.
  Qed.

  Global Instance ltk_asym : Asymmetric ltk.
  Proof. apply (StrictOrder_Asymmetric ltk_strorder). Qed.

  (* Additional facts *)

  Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'.
  Proof.
    unfold eqk, ltk.
    unfold not. intros x x' H.
    destruct x, x'. simpl in *.
    intro.
    symmetry in H.
    apply lt_not_eq in H. auto.
    subst. auto.
  Qed.

  Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''.
  Proof. unfold ltk, eqk. destruct e, e', e''. simpl.
    intros; subst; trivial.
  Qed.

  Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''.
  Proof.
    intros (k,e) (k',e') (k'',e'').
    unfold ltk, eqk; simpl; intros; subst; trivial.
  Qed.
  Hint Resolve eqk_not_ltk.
  Hint Immediate ltk_eqk eqk_ltk.

  Lemma InA_eqke_eqk :
     forall x m, InA eqke x m -> InA eqk x m.
  Proof.
    unfold eqke; induction 1; intuition.
  Qed.

  Hint Resolve InA_eqke_eqk.

  (* Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. *)
  (* Proof. *)
  (*  intros; apply InA_eqA with p; auto with *. *)
  (* Qed. *)

  (* Lemma In_eq : forall l x y, eq x y -> InA eqke x l -> InA eqke y l. *)
  (* Proof. intros. rewrite <- H; auto. Qed. *)

  (* Lemma ListIn_In : forall l x, List.In x l -> InA eqk x l. *)
  (* Proof. apply In_InA. split; auto. unfold Transitive. *)
  (*   unfold eqk; intros. rewrite H, <- H0. auto. *)
  (* Qed. *)

  (* Lemma Inf_lt : forall l x y, ltk x y -> Inf y l -> Inf x l. *)
  (* Proof. exact (InfA_ltA ltk_strorder). Qed. *)

  (* Lemma Inf_eq : forall l x y, x = y -> Inf y l -> Inf x l. *)
  (* Proof. exact (InfA_eqA eq_equiv ltk_compat). Qed. *)

  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)

  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
  Proof.
  firstorder.
  exists x; auto.
  induction H.
  destruct y.
  exists e; auto.
  destruct IHInA as [e H0].
  exists e; auto.
  Qed.

  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
  Proof.
  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *.
  Qed.

  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
  Proof.
  destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
  Qed.

  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
  Proof. exact (InfA_eqA eqk_equiv ltk_compatk). Qed.

  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
  Proof. exact (InfA_ltA ltk_strorder). Qed.

  Hint Immediate Inf_eq.
  Hint Resolve Inf_lt.

  Lemma Sort_Inf_In :
    forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
  Proof.
    exact (SortA_InfA_InA eqk_equiv ltk_strorder ltk_compatk).
  Qed.

  Lemma Sort_Inf_NotIn :
    forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
  Proof.
    intros; red; intros.
    destruct H1 as [e' H2].
    elim (@ltk_not_eqk (k,e) (k,e')).
    eapply Sort_Inf_In; eauto.
    red; simpl; auto.
  Qed.

  Hint Resolve Sort_Inf_NotIn.

  Lemma Sort_NoDupA: forall l, Sort l -> NoDupA l.
  Proof.
    exact (SortA_NoDupA eqk_equiv ltk_strorder ltk_compatk).
  Qed.

  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
  Proof.
    inversion 1; intros; eapply Sort_Inf_In; eauto.
  Qed.

  Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
                                   ltk e e' \/ eqk e e'.
  Proof.
    inversion_clear 2; auto.
    left; apply Sort_In_cons_1 with l; auto.
  Qed.

  Lemma Sort_In_cons_3 :
    forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
  Proof.
    inversion_clear 1; red; intros.
    destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)).
  Qed.

  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
  Proof.
    inversion 1.
    inversion_clear H0; eauto.
    destruct H1; simpl in *; intuition.
  Qed.

  Lemma In_inv_2 : forall k k' e e' l,
      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
  Proof.
    inversion_clear 1; compute in H0; intuition.
  Qed.

  Lemma In_inv_3 : forall x x' l,
      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
  Proof.
    inversion_clear 1; compute in H0; intuition.
  Qed.

  Hint Resolve In_inv_2 In_inv_3.

  (** * FMAPLIST interface implementaion  *)

  (** * [empty] *)

  Definition empty : farray := nil.

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

  Lemma empty_1 : Empty empty.
  Proof.
    unfold Empty,empty.
    intros a e.
    intro abs.
    inversion abs.
  Qed.
  Hint Resolve empty_1.

  Lemma empty_sorted : Sort empty.
  Proof.
    unfold empty; auto.
  Qed.

  (** * [is_empty] *)

  Definition is_empty (l : farray) : bool := if l then true else false.

  Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
  Proof.
    unfold Empty, MapsTo.
    intros m.
    case m;auto.
    intros (k,e) l inlist.
    absurd (InA eqke (k, e) ((k, e) :: l));auto.
  Qed.

  Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
  Proof.
    intros m.
    case m;auto.
    intros p l abs.
    inversion abs.
  Qed.

  (** * [mem] *)

  Function mem (k : key) (s : farray) {struct s} : bool :=
    match s with
    | nil => false
    | (k',_) :: l =>
      match compare k k' with
      | LT _ => false
      | EQ _ => true
      | GT _ => mem k l
      end
    end.

  Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
  Proof.
    intros m Hm x; generalize Hm; clear Hm.
    functional induction (mem x m);intros sorted belong1;trivial.

    inversion belong1. inversion H.

    absurd (In x ((k', _x) :: l));try assumption.
    apply Sort_Inf_NotIn with _x;auto.

    apply IHb.
    elim (sort_inv sorted);auto.
    elim (In_inv belong1);auto.
    intro abs.
    absurd (eq x k'); auto.
    symmetry in abs.
    apply lt_not_eq in abs; auto.
  Qed.

  Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m.
  Proof.
    intros m Hm x; generalize Hm; clear Hm; unfold In,MapsTo.
    functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
    exists _x; auto.
    induction IHb; auto.
    exists x0; auto.
    inversion_clear sorted; auto.
  Qed.

  (** * [find] *)

  Function find (k:key) (s: farray) {struct s} : option elt :=
    match s with
    | nil => None
    | (k',x)::s' =>
      match compare k k' with
      | LT _ => None
      | EQ _ => Some x
      | GT _ => find k s'
      end
    end.

  Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
  Proof.
    intros m x. unfold MapsTo.
    functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
  Qed.

  Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e.
  Proof.
    intros m Hm x e; generalize Hm; clear Hm; unfold MapsTo.
    functional induction (find x m);simpl; subst; try clear H_eq_1.

    inversion 2.

    inversion_clear 2.
    clear e1;compute in H0; destruct H0.
    apply lt_not_eq in H; auto. now contradict H.

    clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute.
    (* order. *)
    intros.
    apply (lt_trans k') in _x; auto.
    apply lt_not_eq in _x.
    now contradict _x.

    clear e1;inversion_clear 2.
    compute in H0; destruct H0; intuition congruence.
    generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute.
    (* order. *)
    intros.
    apply lt_not_eq in H. now contradict H.

    clear e1; do 2 inversion_clear 1; auto.
    compute in H2; destruct H2.
    (* order. *)
    subst. apply lt_not_eq in _x. now contradict _x.
  Qed.

  (** * [add] *)

  Function add (k : key) (x : elt) (s : farray) {struct s} : farray :=
    match s with
    | nil => (k,x) :: nil
    | (k',y) :: l =>
      match compare k k' with
      | LT _ => (k,x)::s
      | EQ _ => (k,x)::l
      | GT _ => (k',y) :: add k x l
      end
    end.

  Lemma add_1 : forall m x y e, eq x y -> MapsTo y e (add x e m).
  Proof.
    intros m x y e; generalize y; clear y.
    unfold MapsTo.
    functional induction (add x e m);simpl;auto.
  Qed.

  Lemma add_2 : forall m x y e e',
      ~ eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof.
    intros m x  y e e'.
    generalize y e; clear y e; unfold MapsTo.
    functional induction (add x e' m) ;simpl;auto;  clear e0.
    subst;auto.

    intros y' e'' eqky';  inversion_clear 1;  destruct H0; simpl in *.
    (* order. *)
    subst. now contradict eqky'.
    auto.
    auto.
    intros y' e'' eqky'; inversion_clear 1; intuition.
  Qed.

  Lemma add_3 : forall m x y e e',
      ~ eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof.
    intros m x y e e'. generalize y e; clear y e; unfold MapsTo.
    functional induction (add x e' m);simpl; intros.
    apply (In_inv_3 H0); compute; auto.
    apply (In_inv_3 H0); compute; auto.
    constructor 2; apply (In_inv_3 H0); compute; auto.
    inversion_clear H0; auto.
  Qed.

  Lemma add_Inf : forall (m:farray)(x x':key)(e e':elt),
      Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x'',e'').
    inversion_clear H.
    compute in H0,H1.
    simpl; case (compare x x''); intuition.
  Qed.
  Hint Resolve add_Inf.

  Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x',e').
    simpl; case (compare x x'); intuition; inversion_clear Hm; auto.
    constructor; auto.
    apply Inf_eq with (x',e'); auto.
  Qed.

  (** * [remove] *)

  Function remove (k : key) (s : farray) {struct s} : farray :=
    match s with
    | nil => nil
    | (k',x) :: l =>
      match compare k k' with
      | LT _ => s
      | EQ _ => l
      | GT _ => (k',x) :: remove k l
      end
    end.

  Lemma remove_1 : forall m (Hm:Sort m) x y, eq x y -> ~ In y (remove x m).
  Proof.
    intros m Hm x y; generalize Hm; clear Hm.
    functional induction (remove x m);simpl;intros;subst.

    red; inversion 1; inversion H0.

    apply Sort_Inf_NotIn with x0; auto.

    clear e0. inversion Hm. subst.
    apply Sort_Inf_NotIn with x0; auto.

    (* clear e0;inversion_clear Hm. *)
    (* apply Sort_Inf_NotIn with x0; auto. *)
    (* apply Inf_eq with (k',x0);auto; compute; apply eq_trans with x; auto. *)

    clear e0;inversion_clear Hm.
    assert (notin:~ In y (remove y l)) by auto.
    intros (x1,abs).
    inversion_clear abs.
    compute in H1; destruct H1.
    subst. apply lt_not_eq in _x; now contradict _x.
    apply notin; exists x1; auto.
  Qed.

  Lemma remove_2 : forall m (Hm:Sort m) x y e,
      ~ eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof.
    intros m Hm x y e; generalize Hm; clear Hm; unfold MapsTo.
    functional induction (remove x m);subst;auto;
      match goal with
      | [H: compare _ _ = _ |- _ ] => clear H
      | _ => idtac
      end.

    inversion_clear 3; auto.
    compute in H1; destruct H1.
    subst; now contradict H.
    inversion_clear 1; inversion_clear 2; auto.
  Qed.

  Lemma remove_3 : forall m (Hm:Sort m) x y e,
      MapsTo y e (remove x m) -> MapsTo y e m.
  Proof.
    intros m Hm x y e; generalize Hm; clear Hm; unfold MapsTo.
    functional induction (remove x m);subst;auto.
    inversion_clear 1; inversion_clear 1; auto.
  Qed.

  Lemma remove_Inf : forall (m:farray)(Hm : Sort m)(x x':key)(e':elt),
      Inf (x',e') m -> Inf (x',e') (remove x m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x'',e'').
    inversion_clear H.
    compute in H0.
    simpl; case (compare x x''); intuition.
    inversion_clear Hm.
    apply Inf_lt with (x'',e''); auto.
  Qed.
  Hint Resolve remove_Inf.

  Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
  Proof.
    induction m.
    simpl; intuition.
    intros.
    destruct a as (x',e').
    simpl; case (compare x x'); intuition; inversion_clear Hm; auto.
  Qed.

  (** * [elements] *)

  Definition elements (m: farray) := m.

  Lemma elements_1 : forall m x e,
      MapsTo x e m -> InA eqke (x,e) (elements m).
  Proof.
    auto.
  Qed.

  Lemma elements_2 : forall m x e,
      InA eqke (x,e) (elements m) -> MapsTo x e m.
  Proof.
    auto.
  Qed.

  Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m).
  Proof.
    auto.
  Qed.

  Lemma elements_3w : forall m (Hm:Sort m), NoDupA (elements m).
  Proof.
    intros.
    apply Sort_NoDupA.
    apply elements_3; auto.
  Qed.

  (** * [fold] *)

  Function fold (A:Type)(f:key->elt->A->A)(m:farray) (acc:A) {struct m} :  A :=
    match m with
    | nil => acc
    | (k,e)::m' => fold f m' (f k e acc)
    end.

  Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
      fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof.
    intros; functional induction (fold f m i); auto.
  Qed.

  (** * [equal] *)

  Function equal (cmp:elt->elt->bool)(m m' : farray) {struct m} : bool :=
    match m, m' with
    | nil, nil => true
    | (x,e)::l, (x',e')::l' =>
      match compare x x' with
      | EQ _ => cmp e e' && equal cmp l l'
      | _    => false
      end
    | _, _ => false
    end.

  Definition Equivb cmp m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).

  Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
      Equivb cmp m m' -> equal cmp m m' = true.
  Proof.
    intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
    functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
      intuition; subst.
    match goal with H: compare _ _ = _ |- _ => clear H end.
    assert (cmp_e_e':cmp e e' = true).
    apply H1 with x; auto.
    rewrite cmp_e_e'; simpl.
    apply IHb; auto.
    inversion_clear Hm; auto.
    inversion_clear Hm'; auto.
    unfold Equivb; intuition.
    destruct (H0 k).
    assert (In k ((x,e) ::l)).
    destruct H as (e'', hyp); exists e''; auto.
    destruct (In_inv (H2 H4)); auto.
    inversion_clear Hm.
    elim (Sort_Inf_NotIn H6 H7).
    destruct H as (e'', hyp); exists e''; auto.
    apply MapsTo_eq with k; auto.
    destruct (H0 k).
    assert (In k ((x,e') ::l')).
    destruct H as (e'', hyp); exists e''; auto.
    destruct (In_inv (H3 H4)); auto.
    subst.
    inversion_clear Hm'.
    now elim (Sort_Inf_NotIn H5 H6).
    apply H1 with k; destruct (eq_dec x k); auto.

    destruct (compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y.
    destruct (H0 x).
    assert (In x ((x',e')::l')).
    apply H; auto.
    exists e; auto.
    destruct (In_inv H3).
    (* order. *)
    apply lt_not_eq in Hlt; now contradict Hlt.
    inversion_clear Hm'.
    assert (Inf (x,e) l').
    apply Inf_lt with (x',e'); auto.
    elim (Sort_Inf_NotIn H5 H7 H4).

    destruct (H0 x').
    assert (In x' ((x,e)::l)).
    apply H2; auto.
    exists e'; auto.
    destruct (In_inv H3).
    (* order. *)
    subst; apply lt_not_eq in Hlt; now contradict Hlt.
    inversion_clear Hm.
    assert (Inf (x',e') l).
    apply Inf_lt with (x,e); auto.
    elim (Sort_Inf_NotIn H5 H7 H4).

    destruct m;
      destruct m';try contradiction.

    clear H1;destruct p as (k,e).
    destruct (H0 k).
    destruct H1.
    exists e; auto.
    inversion H1.

    destruct p as (x,e).
    destruct (H0 x).
    destruct H.
    exists e; auto.
    inversion H.

    destruct p;destruct p0;contradiction.
  Qed.

  Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp,
      equal cmp m m' = true -> Equivb cmp m m'.
  Proof.
    intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
    functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
      intuition; try discriminate; subst;
        try match goal with H: compare _ _ = _ |- _ => clear H end.

    inversion H0.

    inversion_clear Hm;inversion_clear Hm'.
    destruct (andb_prop _ _ H); clear H.
    destruct (IHb H1 H3 H6).
    destruct (In_inv H0).
    exists e'; constructor; split; trivial; apply eq_trans with x; auto.
    destruct (H k).
    destruct (H9 H8) as (e'',hyp).
    exists e''; auto.

    inversion_clear Hm;inversion_clear Hm'.
    destruct (andb_prop _ _ H); clear H.
    destruct (IHb H1 H3 H6).
    destruct (In_inv H0).
    exists e; constructor; split; trivial; apply eq_trans with x'; auto.
    destruct (H k).
    destruct (H10 H8) as (e'',hyp).
    exists e''; auto.

    inversion_clear Hm;inversion_clear Hm'.
    destruct (andb_prop _ _ H); clear H.
    destruct (IHb H2 H4 H7).
    inversion_clear H0.
    destruct H9; simpl in *; subst.
    inversion_clear H1.
    destruct H0; simpl in *; subst; auto.
    elim (Sort_Inf_NotIn H4 H5).
    exists e'0; apply MapsTo_eq with x; auto.
      (* order. *)
    inversion_clear H1.
    destruct H0; simpl in *; subst; auto.
    elim (Sort_Inf_NotIn H2 H3).
    exists e0; apply MapsTo_eq with x; auto.
    (* order. *)
    apply H8 with k; auto.
  Qed.

  (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *)

  Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
    eqk x y -> cmp (snd x) (snd y) = true ->
    (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
  Proof.
    intros.
    inversion H; subst.
    inversion H0; subst.
    destruct x; destruct y; compute in H1, H2.
    split; intros.
    apply equal_2; auto.
    simpl.
    case (compare k k0);
    subst; intro HH; try (apply lt_not_eq in HH; now contradict HH).
    rewrite H2; simpl.
    apply equal_1; auto.
    apply equal_2; auto.
    generalize (equal_1 H H0 H3).
    simpl.
    case (compare k k0);
    subst; intro HH; try (apply lt_not_eq in HH; now contradict HH).
    rewrite H2; simpl; auto.
  Qed.

End Array.

End Raw.

Section FArray.

  Variable key : Type.
  Variable elt : Type.
  Variable key_dec : DecType key.
  Variable key_ord : OrdType key.
  Variable key_comp : Comparable key.
  Variable elt_dec : DecType elt.
  Variable elt_ord : OrdType elt.
  Variable elt_comp : Comparable elt.

  Set Implicit Arguments.

  Record slist :=
    {this :> Raw.farray key elt; sorted : sort (Raw.ltk key_ord) this}.
  Definition farray := slist.

  (* Boolean comparison over elements *)
  Definition cmp (e e':elt) :=
    match compare e e' with EQ _ => true | _ => false end.

  Definition empty : farray := Build_slist (Raw.empty_sorted elt key_ord).
  Definition is_empty m : bool := Raw.is_empty m.(this).
  Definition add x e m : farray :=
    Build_slist (Raw.add_sorted key_dec key_comp m.(sorted) x e).
  Definition find x m : option elt := Raw.find key_comp x m.(this).
  Definition remove x m : farray :=
    Build_slist (Raw.remove_sorted key_comp m.(sorted) x).
  Definition mem x m : bool := Raw.mem key_comp x m.(this).
  Definition elements m : list (key*elt) := Raw.elements m.(this).
  Definition cardinal m := length m.(this).
  Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A :=
    Raw.fold f m.(this) i.
  Definition equal m m' : bool := Raw.equal key_comp cmp m.(this) m'.(this).

  Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this).
  Definition In x m : Prop := Raw.In x m.(this).
  Definition Empty m : Prop := Raw.Empty m.(this).

  Definition Equal m m' := forall y, find y m = find y m'.
  Definition Equiv m m' :=
    (forall k, In k m <-> In k m') /\
    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> e = e').
  Definition Equivb m m' : Prop := Raw.Equivb cmp m.(this) m'.(this).

  Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.eqk key elt.
  Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.eqke key elt.
  Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.ltk key elt key_ord.

  Lemma MapsTo_1 : forall m x y e, eq x y -> MapsTo x e m -> MapsTo y e m.
  Proof. intros m.
    apply (Raw.MapsTo_eq key_dec elt_dec). Qed.

  Lemma mem_1 : forall m x, In x m -> mem x m = true.
  Proof. intros m; apply (Raw.mem_1); auto. apply m.(sorted). Qed.
  Lemma mem_2 : forall m x, mem x m = true -> In x m.
  Proof. intros m; apply (Raw.mem_2); auto. apply m.(sorted). Qed.

  Lemma empty_1 : Empty empty.
  Proof. apply Raw.empty_1. Qed.

  Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
  Proof. intros m; apply Raw.is_empty_1. Qed.
  Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
  Proof. intros m; apply Raw.is_empty_2. Qed.

  Lemma add_1 : forall m x y e, eq x y -> MapsTo y e (add x e m).
  Proof. intros m; apply Raw.add_1; auto. Qed.
  Lemma add_2 : forall m x y e e', ~ eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
  Proof. intros m; apply Raw.add_2; auto. Qed.
  Lemma add_3 : forall m x y e e', ~ eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
  Proof. intros m; apply Raw.add_3; auto. Qed.

  Lemma remove_1 : forall m x y, eq x y -> ~ In y (remove x m).
  Proof. intros m; apply Raw.remove_1; auto. apply m.(sorted). Qed.
  Lemma remove_2 : forall m x y e, ~ eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
  Proof. intros m; apply Raw.remove_2; auto. apply m.(sorted). Qed.
  Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
  Proof. intros m; apply Raw.remove_3; auto. apply m.(sorted). Qed.

  Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
  Proof. intros m; apply Raw.find_1; auto. apply m.(sorted). Qed.
  Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
  Proof. intros m; apply Raw.find_2; auto. Qed.

  Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
  Proof. intros m; apply Raw.elements_1. Qed.
  Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
  Proof. intros m; apply Raw.elements_2. Qed.
  Lemma elements_3 : forall m, sort lt_key (elements m).
  Proof. intros m; apply Raw.elements_3; auto. apply m.(sorted). Qed.
  Lemma elements_3w : forall m, NoDupA eq_key (elements m).
  Proof. intros m; apply (Raw.elements_3w key_dec m.(sorted)). Qed.

  Lemma cardinal_1 : forall m, cardinal m = length (elements m).
  Proof. intros; reflexivity. Qed.

  Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
      fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
  Proof. intros m; apply Raw.fold_1. Qed.

  Lemma equal_1 : forall m m', Equivb m m' -> equal m m' = true.
  Proof. intros m m'; apply Raw.equal_1; auto. apply m.(sorted). apply  m'.(sorted). Qed.
  Lemma equal_2 : forall m m', equal m m' = true -> Equivb m m'.
  Proof. intros m m'; apply Raw.equal_2; auto. apply m.(sorted). apply  m'.(sorted). Qed.

  Fixpoint eq_list (m m' : list (key * elt)) : Prop :=
    match m, m' with
    | nil, nil => True
    | (x,e)::l, (x',e')::l' =>
      match compare x x' with
      | EQ _ => eq e e' /\ eq_list l l'
      | _       => False
      end
    | _, _ => False
    end.

  Definition eq m m' := eq_list m.(this) m'.(this).

  Lemma eq_equal : forall m m', eq m m' <-> equal m m' = true.
  Proof.
    intros (l,Hl); induction l.
    intros (l',Hl'); unfold eq; simpl.
    destruct l'; unfold equal; simpl; intuition.
    intros (l',Hl'); unfold eq.
    destruct l'.
    destruct a; unfold equal; simpl; intuition.
    destruct a as (x,e).
    destruct p as (x',e').
    unfold equal; simpl.
    destruct (compare x x') as [Hlt|Heq|Hlt]; simpl; intuition.
    unfold cmp at 1.
    case (compare e e');
    subst; intro HH; try (apply lt_not_eq in HH; now contradict HH);
    clear HH; simpl.
    inversion_clear Hl.
    inversion_clear Hl'.
    destruct (IHl H (Build_slist H2)).
    unfold equal, eq in H5; simpl in H5; auto.
    destruct (andb_prop _ _ H); clear H.
    generalize H0; unfold cmp.
    case (compare e e');
    subst; intro HH; try (apply lt_not_eq in HH; now contradict HH);
      auto; intro; discriminate.
    destruct (andb_prop _ _ H); clear H.
    inversion_clear Hl.
    inversion_clear Hl'.
    destruct (IHl H (Build_slist H3)).
    unfold equal, eq in H6; simpl in H6; auto.
  Qed.

  Lemma eq_1 : forall m m', Equivb m m' -> eq m m'.
  Proof.
    intros.
    generalize (@equal_1 m m').
    generalize (@eq_equal m m').
    intuition.
  Qed.

  Lemma eq_2 : forall m m', eq m m' -> Equivb m m'.
  Proof.
    intros.
    generalize (@equal_2 m m').
    generalize (@eq_equal m m').
    intuition.
  Qed.

  Lemma eqfarray_refl : forall m : farray, eq m m.
  Proof.
    intros (m,Hm); induction m; unfold eq; simpl; auto.
    destruct a.
    destruct (compare k k) as [Hlt|Heq|Hlt]; auto.
    apply lt_not_eq in Hlt. auto.
    split.
    apply eq_refl.
    inversion_clear Hm.
    apply (IHm H).
    apply lt_not_eq in Hlt. auto.
  Qed.

  Lemma eqfarray_sym : forall m1 m2 : farray, eq m1 m2 -> eq m2 m1.
  Proof.
    intros (m,Hm); induction m;
      intros (m', Hm'); destruct m'; unfold eq; simpl;
        try destruct a as (x,e); try destruct p as (x',e'); auto.
    destruct (compare x x')  as [Hlt|Heq|Hlt]; try easy.
    inversion_clear Hm; inversion_clear Hm'.
    intro. destruct H3.
    subst.
    case (compare x' x');
    subst; intro HH; try (apply lt_not_eq in HH; now contradict HH).
    split; auto.
    apply (IHm H (Build_slist H1)); auto.
  Qed.

  Lemma eqfarray_trans : forall m1 m2 m3 : farray, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
  Proof.
    intros (m1,Hm1); induction m1;
      intros (m2, Hm2); destruct m2;
        intros (m3, Hm3); destruct m3; unfold eq; simpl;
          try destruct a as (x,e);
          try destruct p as (x',e');
          try destruct p0 as (x'',e''); try contradiction; auto.
    destruct (compare x x') as [Hlt|Heq|Hlt];
      destruct (compare x' x'') as [Hlt'|Heq'|Hlt']; try easy.
    intros; destruct H, H0;  subst.
    case (compare x'' x'');
    subst; intro HH; try (apply lt_not_eq in HH; now contradict HH).
    split; auto.
    inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
    apply (IHm1 H (Build_slist H3) (Build_slist H5)); intuition.
  Qed.

  Fixpoint lt_list (m m' : list (key * elt)) : Prop :=
    match m, m' with
    | nil, nil => False
    | nil, _  => True
    | _, nil  => False
    | (x,e)::l, (x',e')::l' =>
      match compare x x' with
      | LT _ => True
      | GT _ => False
      | EQ _ => lt e e' \/ (e = e' /\ lt_list l l')
      end
    end.

  Definition lt_farray m m' := lt_list m.(this) m'.(this).

  Lemma lt_farray_trans : forall m1 m2 m3 : farray,
      lt_farray m1 m2 -> lt_farray m2 m3 -> lt_farray m1 m3.
  Proof.
    intros (m1,Hm1); induction m1;
      intros (m2, Hm2); destruct m2;
        intros (m3, Hm3); destruct m3; unfold lt_farray; simpl;
          try destruct a as (x,e);
          try destruct p as (x',e');
          try destruct p0 as (x'',e''); try contradiction; auto.
    destruct (compare x x') as [Hlt|Heq|Hlt];
      destruct (compare x' x'') as [Hlt'|Heq'|Hlt'];
      destruct (compare x x'') as [Hlt''|Heq''|Hlt'']; intros; subst; auto; try easy.
    apply (lt_trans x') in Hlt; apply lt_not_eq in Hlt.
    now contradict Hlt. auto.
    apply (lt_trans x') in Hlt; apply lt_not_eq in Hlt.
    now contradict Hlt.
    apply (lt_trans _ x'') ; auto.
    apply lt_not_eq in Hlt. now contradict Hlt.
    apply (lt_trans x'') in Hlt; apply lt_not_eq in Hlt.
    now contradict Hlt. auto.
    subst.
    apply lt_not_eq in Hlt'. now contradict Hlt'.
    apply (lt_trans x'') in Hlt'; apply lt_not_eq in Hlt'.
    now contradict Hlt'. auto.
    destruct H, H0.
    left; apply lt_trans with e'; auto.
    left. destruct H0. subst; auto.
    left. destruct H. subst; auto.
    right. destruct H, H0. subst; split; auto.
    inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
    apply (IHm1 H (Build_slist H3) (Build_slist H5)); intuition.
    apply lt_not_eq in Hlt''. now contradict Hlt''.
  Qed.

  Lemma lt_farray_not_eq : forall m1 m2 : farray, lt_farray m1 m2 -> ~ eq m1 m2.
  Proof.
    intros (m1,Hm1); induction m1;
      intros (m2, Hm2); destruct m2; unfold eq, lt; simpl;
        try destruct a as (x,e);
        try destruct p as (x',e'); try contradiction; auto.
    destruct (compare x x') as [Hlt|Heq|Hlt]; auto.
    intuition.
    inversion_clear Hm1; inversion_clear Hm2.
    subst.
    apply (IHm1 H0 (Build_slist H4)); intuition.
    unfold lt_farray in *.
    simpl in H.
    case (compare x' x') in *.
    apply lt_not_eq in l. now contradict l.
    destruct H.
    apply lt_not_eq in H. now contradict H.
    destruct H.
    auto.
    apply lt_not_eq in l. now contradict l.
  Qed.

  Definition compare_farray : forall m1 m2, Compare lt_farray eq m1 m2.
  Proof.
    intros (m1,Hm1); induction m1;
      intros (m2, Hm2); destruct m2;
        [ apply EQ | apply LT | apply GT | ]; auto.
    (* cmp_solve. *)
    unfold eq. simpl; auto.
    unfold lt_farray. simpl; auto.
    unfold lt_farray. simpl; auto.
    destruct a as (x,e); destruct p as (x',e').
    destruct (compare x x');
      [ apply LT | | apply GT ].
    unfold lt_farray. simpl.
    destruct (compare x x'); auto.
    subst. apply lt_not_eq in l; now contradict l.
    apply (lt_trans x') in l; auto. subst. apply lt_not_eq in l; now contradict l.
    (* subst. *)
    destruct (compare e e');
      [ apply LT | | apply GT ].
    unfold lt_farray. simpl.
    destruct (compare x x'); auto; try (subst; apply lt_not_eq in l0; now contradict l0).
    assert (Hm11 : sort (Raw.ltk key_ord) m1).
    inversion_clear Hm1; auto.
    assert (Hm22 : sort (Raw.ltk key_ord) m2).
    inversion_clear Hm2; auto.
    destruct (IHm1 Hm11 (Build_slist Hm22));
      [ apply LT | apply EQ | apply GT ].
    unfold lt_farray in *. simpl.
    destruct (compare x x'); auto; try (subst; apply lt_not_eq in l0; now contradict l0).
    unfold eq in *. simpl.
    destruct (compare x x'); auto; try (subst; apply lt_not_eq in l; now contradict l).
    unfold lt_farray in *. simpl.
    destruct (compare x' x); auto; try (subst; apply lt_not_eq in l0; now contradict l0).
    unfold lt_farray in *. simpl.
    destruct (compare x' x); auto; try (subst; apply lt_not_eq in l0; now contradict l0).
    unfold lt_farray in *. simpl.
    destruct (compare x' x); auto; try (subst; apply lt_not_eq in l; now contradict l).
    apply (lt_trans x) in l; auto. subst. apply lt_not_eq in l; now contradict l.
  Qed.
  (* TODO *)

  Lemma eq_option_alt : forall (elt:Type)(o o':option elt),
      o=o' <-> (forall e, o=Some e <-> o'=Some e).
  Proof.
    split; intros.
    subst; split; auto.
    destruct o; destruct o'; try rewrite H; auto.
    symmetry; rewrite <- H; auto.
  Qed.

  Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e.
  Proof.
    split; [apply find_1|apply find_2].
  Qed.

  Lemma add_neq_mapsto_iff : forall m x y e e',
      x <> y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
  Proof.
    split; [apply add_3|apply add_2]; auto.
  Qed.

  Lemma add_eq_o : forall m x y e,
      x = y -> find y (add x e m) = Some e.
  Proof. intros.
    apply find_1.
    apply add_1. auto.
  Qed.

  Lemma add_neq_o : forall m x y e,
      ~ x = y -> find y (add x e m) = find y m.
  Proof.
    intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff.
    apply add_neq_mapsto_iff; auto.
  Qed.
  Hint Resolve add_neq_o.

  Lemma MapsTo_fun : forall m x (e e':elt),
      MapsTo x e m -> MapsTo x e' m -> e=e'.
  Proof.
    intros.
    generalize (find_1 H) (find_1 H0); clear H H0.
    intros; rewrite H in H0; injection H0; auto.
  Qed.

  (** Another characterisation of [Equal] *)

  Lemma Equal_mapsto_iff : forall m1 m2 : farray,
      Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2).
  Proof.
    intros m1 m2. split; [intros Heq k e|intros Hiff].
    rewrite 2 find_mapsto_iff, Heq. split; auto.
    intro k. rewrite eq_option_alt. intro e.
    rewrite <- 2 find_mapsto_iff; auto.
  Qed.

  (** * Relations between [Equal], [Equiv] and [Equivb]. *)

  (** First, [Equal] is [Equiv] with Leibniz on elements. *)

  Lemma Equal_Equiv : forall (m m' : farray),
      Equal m m' <-> Equiv m m'.
  Proof.
    intros. rewrite Equal_mapsto_iff. split; intros.
    split.
    split; intros (e,Hin); exists e; unfold MapsTo in H; [rewrite <- H|rewrite H]; auto.
    intros; apply MapsTo_fun with m k; auto; rewrite H; auto.
    split; intros H'.
    destruct H.
    assert (Hin : In k m') by (rewrite <- H; exists e; auto).
    destruct Hin as (e',He').
    rewrite (H0 k e e'); auto.
    destruct H.
    assert (Hin : In k m) by (rewrite H; exists e; auto).
    destruct Hin as (e',He').
    rewrite <- (H0 k e' e); auto.
  Qed.

  Lemma Equiv_Equivb : forall m m', Equiv m m' <-> Equivb m m'.
  Proof.
    unfold Equiv, Equivb, Raw.Equivb, cmp; intuition; specialize (H1 k e e' H H2).
    destruct (compare e e'); auto; apply lt_not_eq in l; auto.
    destruct (compare e e'); auto; now contradict H1.
  Qed.

  (** Composition of the two last results: relation between [Equal]
    and [Equivb]. *)

  Lemma Equal_Equivb : forall (m m':farray), Equal m m' <-> Equivb m m'.
  Proof.
    intros; rewrite Equal_Equiv.
    apply Equiv_Equivb; auto.
  Qed.

  (** * Functional arrays *)

  Definition select (a: farray) (i: key) : option elt := find i a.

  Definition store (a: farray) (i: key) (v: elt) : farray := add i v a.

  Lemma read_over_same_write : forall a i j v, i = j -> select (store a i v) j = Some v.
  Proof.
    intros a i j v Heq.
    unfold select, store.
    intros. rewrite add_eq_o; auto.
  Qed.

  Lemma read_over_other_write : forall a i j v,
      i <> j -> select (store a i v) j = select a j.
  Proof.
    intros a i j v Hneq.
    unfold select, store.
    rewrite add_neq_o; auto.
  Qed.

  (* TODO *)
  Lemma find_ext_dec:
    (forall m1 m2: farray, Equal m1 m2 -> (equal m1 m2) = true).
  Proof. intros.
    apply Equal_Equivb in H.
    apply equal_1.
    exact H.
  Qed.

  Lemma extensionnality : forall a b,
      (forall i, select a i = select b i) -> equal a b = true.
  Proof.
    intros.
    unfold select in H.
    apply find_ext_dec in H.
    exact H.
  Qed.

  Require Import ProofIrrelevance.

  Lemma equal_eq : forall a b, equal a b = true -> a = b.
  Proof.
    intros. apply eq_equal in H.
    destruct a as (a, asort), b as (b, bsort).
    unfold eq in H.
    revert b bsort H.
    induction a; intros; destruct b.
    apply f_equal. apply proof_irrelevance.
    simpl in H. now contradict H.
    simpl in H. destruct a; now contradict H.
    simpl in H. destruct a, p.
    destruct (compare k k0); auto; try (now contradict H).
    destruct H.
    subst.
    inversion_clear asort.
    inversion_clear bsort.
    specialize (IHa H b H2 H0).
    inversion IHa. subst.
    apply f_equal.  apply proof_irrelevance.
 Qed.

(** farray equal in Prop *)
  Definition equalP (m m' : farray) : Prop :=
    if equal m m' then True else False.

  Lemma eq_list_refl: forall a, eq_list a a.
  Proof.
    intro a.
    induction a; intros.
    - now simpl.
    - simpl. destruct a as (k, e).
      case_eq (compare k k); intros.
      + revert H. generalize l.
        apply lt_not_eq in l. now contradict l.
      + split; easy.
      + revert H. generalize l.
        apply lt_not_eq in l. now contradict l.
  Qed.

  Lemma equal_refl: forall a, equal a a = true.
  Proof. intros; apply eq_equal; apply eq_list_refl. Qed.

  Lemma equal_eqP : forall a b, equalP a b <-> a = b.
  Proof.
     intros. split; intro H. unfold equalP in H.
     case_eq (equal a b); intros; rewrite H0 in H.
     now apply equal_eq. now contradict H.
     rewrite H. unfold equalP.
     now rewrite equal_refl.
  Qed.

 Lemma equal_B2P: forall (m m' : farray),
                  equal m m' = true <-> equalP m m'.
 Proof.
     intros. split; intros.
     apply equal_eq in H. rewrite H.
     unfold equalP. now rewrite equal_refl.
     apply equal_eqP in H.
     now rewrite H, equal_refl.
 Qed.

End FArray.

(*
   Local Variables:
   coq-load-path: ((rec ".." "SMTCoq"))
   End:
*)


Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

(* NOTE: The idea with this approach is that each type uniquely determines its
ordered type, but we keep the types separate from the ordered types to make
type inference work properly... *)

Class OTRelation (A:Type) : Type := ot_R : relation A.
Class OType (A:Type) {R:OTRelation A} : Prop :=
  { ot_PreOrder :> PreOrder ot_R }.

Arguments OTRelation A%type.
Arguments OType A%type {R}.

Instance OType_Reflexive A `{OType A} : Reflexive ot_R.
Proof. typeclasses eauto. Qed.

Instance OType_Transitive A `{OType A} : Transitive ot_R.
Proof. typeclasses eauto. Qed.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv {A} `{OTRelation A} : relation A :=
  fun x y => ot_R x y /\ ot_R y x.

Instance ot_equiv_Equivalence A `{OType A} : Equivalence ot_equiv.
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H0; split; assumption. }
  { destruct H0; destruct H1; split; transitivity y; assumption. }
Qed.

Notation "x <o= y" :=
  (ot_R x y) (no associativity, at level 70).
Notation "x =o= y" :=
  (ot_equiv x y) (no associativity, at level 70).

(* FIXME: replace "ot_R" below with "<o=" notation *)

(* FIXME: figure out what versions of this we need for rewriting! *)
Instance Proper_ot_R_ot_R A `{OType A}
  : Proper (ot_R --> ot_R ==> Basics.impl) (@ot_R A _).
Proof.
  intros a1 a2 Ra b1 b2 Rb Rab.
  transitivity a1; [ assumption | ]. transitivity b1; assumption.
Qed.

Instance Subrelation_ot_equiv_ot_R A `{OType A} : subrelation (@ot_equiv A _) ot_R.
Proof.
  intros a1 a2 Ra; destruct Ra; assumption.
Qed.

Instance Proper_ot_equiv_ot_R A `{OType A} :
  Proper (ot_equiv ==> ot_equiv ==> iff) (@ot_R A _).
Proof.
  intros x1 x2 Rx y1 y2 Ry; destruct Rx; destruct Ry; split; intro Rxy.
  transitivity x1; [ assumption | ]; transitivity y1; assumption.
  transitivity x2; [ assumption | ]; transitivity y2; assumption.
Qed.

Instance Proper_ot_equiv A `{OType A} :
  Proper (ot_equiv ==> ot_equiv ==> iff) (@ot_equiv A _).
Proof.
  intros x1 x2 Rx y1 y2 Ry. rewrite Rx. rewrite Ry. reflexivity.
Qed.

Instance Proper_ot_equiv_partial A `{OType A} a :
  Proper (ot_equiv ==> Basics.flip Basics.impl) (@ot_equiv A _ a).
Proof.
  intros x1 x2 Rx. rewrite Rx. reflexivity.
Qed.

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Instance OTProp_R : OTRelation Prop := Basics.impl.
Instance OTProp : OType Prop.
Proof. repeat constructor; typeclasses eauto. Qed.

(* The discrete ordered type, where things are only related to themselves; we
make this a definition, not an instance, so that it can be instantiated for
particular types. *)
Definition OTdiscrete_R (A:Type) : OTRelation A := eq.
Definition OTdiscrete A : @OType A (OTdiscrete_R A).
  repeat constructor. typeclasses eauto.
Qed.

(* The only ordered type over unit is the discrete one *)
Instance OTunit_R : OTRelation unit := OTdiscrete_R unit.
Instance OTunit : OType unit := OTdiscrete unit.

(* The ordered type that flips the ordering of an underlying OType; this becomes
a type itself in Coq *)
Inductive Flip A : Type := flip (a:A).
Definition unflip {A} (f:Flip A) : A := let (x) := f in x.

Instance OTFlip_R A (R:OTRelation A) : OTRelation (Flip A) :=
  fun x y => unflip y <o= unflip x.

Instance OTFlip A `{OType A} : OType (Flip A).
Proof.
  repeat constructor; intro; intros.
  - destruct x; compute; reflexivity.
  - destruct x; destruct y; destruct z; compute; transitivity a0; assumption.
Qed.

(* The pointwise relation on pairs *)
Instance OTpair_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A*B) :=
  fun p1 p2 => ot_R (fst p1) (fst p2) /\ ot_R (snd p1) (snd p2).

Instance OTpair A B `(OType A) `(OType B) : OType (A*B).
Proof.
  repeat constructor.
  - destruct x. reflexivity.
  - destruct x. reflexivity.
  - destruct x; destruct y; destruct z; destruct H1; destruct H2;
      transitivity a0; assumption.
  - destruct x; destruct y; destruct z; destruct H1; destruct H2;
      transitivity b0; assumption.
Qed.

(* The sort-of pointwise relation on sum types *)
Inductive sumR {A B} (RA:OTRelation A) (RB:OTRelation B) : A+B -> A+B -> Prop :=
| sumR_inl a1 a2 : RA a1 a2 -> sumR RA RB (inl a1) (inl a2)
| sumR_inr b1 b2 : RB b1 b2 -> sumR RA RB (inr b1) (inr b2).

Instance OTsum_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A+B) :=
  sumR RA RB.

Instance OTsum A B `(OType A) `(OType B) : OType (A+B).
Proof.
  repeat constructor; intro; intros.
  { destruct x; constructor; reflexivity. }
  { destruct H1; inversion H2.
    - constructor; transitivity a2; assumption.
    - constructor; transitivity b2; assumption. }
Qed.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** Proper Instances for Simple Ordered Types
 ***)

Instance Proper_pair A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R ==> ot_R) (pair : A -> B -> A*B).
Proof.
  repeat intro; split; assumption.
Qed.

Instance Proper_fst A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R) (fst : A*B -> A).
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

Instance Proper_snd A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R) (snd : A*B -> B).
Proof.
  intros p1 p2 Rp; destruct Rp; assumption.
Qed.

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun A B {RA:OTRelation A} {RB:OTRelation B} :=
  {
    pfun_app : A -> B;
    pfun_Proper : Proper (ot_R ==> ot_R) pfun_app
  }.

Arguments pfun_app {_ _ _ _} _ _.
Arguments pfun_Proper [_ _ _ _] _ _ _ _.

Notation "A '-o>' B" :=
  (Pfun A B) (right associativity, at level 99).
Notation "x @o@ y" :=
  (pfun_app x y) (left associativity, at level 20).

(* The non-dependent function ordered type *)
Instance OTarrow_R A B {RA:OTRelation A} {RB:OTRelation B} : OTRelation (A -o> B) :=
  fun f g =>
    forall a1 a2, ot_R a1 a2 -> ot_R (pfun_app f a1) (pfun_app g a2).

Instance OTarrow A B `{OType A} `{OType B} : OType (A -o> B).
Proof.
  repeat constructor; intro; intros; intro; intros.
  { apply pfun_Proper; assumption. }
  { transitivity (pfun_app y a1).
    - apply H1; reflexivity.
    - apply H2; assumption. }
Qed.

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. *)

(* pfun_app is always Proper *)
Instance Proper_pfun_app A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_R ==> ot_R ==> ot_R) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf a1 a2 Ra. apply Rf; assumption.
Qed.

(* pfun_app is always Proper w.r.t. ot_equiv *)
Instance Proper_pfun_app_equiv A B `{OTRelation A} `{OTRelation B} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf a1 a2 Ra; destruct Rf; destruct Ra.
  split; apply Proper_pfun_app; assumption.
Qed.

Instance Proper_pfun_app_partial A B `{OTRelation A} `{OTRelation B} f :
  Proper (ot_R ==> ot_R) (pfun_app (A:=A) (B:=B) f).
Proof.
  apply pfun_Proper.
Qed.

Instance Proper_pfun_app_partial_equiv A B `{OTRelation A} `{OTRelation B} f :
  Proper (ot_equiv ==> ot_equiv) (@pfun_app A B _ _ f).
Proof.
  intros a1 a2 Ra; destruct Ra; split; apply pfun_Proper; assumption.
Qed.

(***
 *** Some Useful Pfuns
 ***)

(* The identity pfun *)
Definition id_pfun {A} `{OTRelation A} : A -o> A :=
  {| pfun_app := fun x => x; pfun_Proper := fun x1 x2 Rx => Rx |}.

(* The identity pfun *)
Program Definition compose_pfun {A B C}
        `{OTRelation A} `{OTRelation B} `{OTRelation C}
        (f:A -o> B) (g:B -o> C) : A -o> C :=
  {| pfun_app := fun x => pfun_app g (pfun_app f x);
     pfun_Proper := _ |}.
Next Obligation.
  intros x1 x2 Rx. apply pfun_Proper. apply pfun_Proper. assumption.
Qed.

Instance Proper_compose_pfun A B C
         `{OTRelation A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_R ==> ot_R ==> ot_R) (@compose_pfun A B C _ _ _).
  intros f1 f2 Rf g1 g2 Rg a1 a2 Ra.
  apply Rg. apply Rf. assumption.
Qed.

Instance Proper_compose_pfun_equiv A B C
         `{OTRelation A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv) (@compose_pfun A B C _ _ _).
Proof.
  intros f1 f2 Rf g1 g2 Rg.
  split; intros a1 a2 Ra; simpl; apply Rg; apply Rf; apply Ra.
Qed.

(* Category theory laws for Pfuns *)
Lemma id_compose_pfun A B `{OTRelation A} `{OTRelation B} (f: A -o> B) :
  ot_equiv (compose_pfun id_pfun f) f.
  split; intros a1 a2 Ra; simpl; apply pfun_Proper; assumption.
Qed.
Lemma compose_id_pfun A B `{OTRelation A} `{OTRelation B} (f: A -o> B) :
  ot_equiv (compose_pfun f id_pfun) f.
  split; intros a1 a2 Ra; simpl; apply pfun_Proper; assumption.
Qed.
Lemma compose_compose_pfun A B C D
      `{OTRelation A} `{OTRelation B} `{OTRelation C} `{OTRelation D}
      (f: A -o> B) (g: B -o> C) (h: C -o> D) :
  ot_equiv (compose_pfun f (compose_pfun g h)) (compose_pfun (compose_pfun f g) h).
  split; intros a1 a2 Ra; simpl; repeat apply pfun_Proper; assumption.
Qed.

(* The constant pfun *)
Program Definition const_pfun {A B} `{OTRelation A} `{OType B} b : A -o> B :=
  {| pfun_app := fun _ => b; pfun_Proper := fun _ _ _ => ltac:(reflexivity) |}.

(* FIXME: this proper-ness proof should include irrelevance of the OType arg *)
Instance Proper_const_pfun {A B} `{OTRelation A} `{OType B} :
  Proper (ot_R ==> ot_R) (const_pfun (A:=A) (B:=B)).
Proof.
  intros b1 b2 Rb a1 a2 Ra. apply Rb.
Qed.

Instance Proper_const_pfun_equiv {A B} `{OTRelation A} `{OType B} :
  Proper (ot_equiv ==> ot_equiv) (const_pfun (A:=A) (B:=B)).
Proof.
  intros b1 b2 Rb; split; intros a1 a2 Ra; apply Rb.
Qed.

(* Composing with the constant pfun on the left *)
Lemma compose_const_pfun_f A B C `{OTRelation A} `{OType B} `{OType C}
      b (f : B -o> C) :
  ot_equiv (compose_pfun (const_pfun (A:=A) b) f) (const_pfun (pfun_app f b)).
  split; intros a1 a2 Ra; reflexivity.
Qed.

(* Composing with the constant pfun on the right *)
Lemma compose_f_const_pfun A B C `{OTRelation A} `{OType B} `{OType C}
      (f : A -o> B) c :
  ot_equiv (compose_pfun f (const_pfun c)) (const_pfun c).
  split; intros a1 a2 Ra; reflexivity.
Qed.

(* Take the pair of the outputs of two pfuns *)
Program Definition pair_pfun {A B C}
        `{OTRelation A} `{OTRelation B} `{OTRelation C}
        (f: A -o> B) (g: A -o> C) : A -o> (B * C) :=
  {| pfun_app := fun a => (pfun_app f a, pfun_app g a) |}.
Next Obligation.
  intros a1 a2 Ra; split; apply pfun_Proper; assumption.
Qed.

Instance Proper_pair_pfun A B C `{OTRelation A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_R ==> ot_R ==> ot_R) (pair_pfun (A:=A) (B:=B) (C:=C)).
Proof.
  intros a1 a2 Ra b1 b2 Rb c1 c2 Rc; simpl; split.
  - apply Ra; assumption.
  - apply Rb; assumption.
Qed.

Instance Proper_pair_pfun_equiv A B C
         `{OTRelation A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv)
         (pair_pfun (A:=A) (B:=B) (C:=C)).
Proof.
  intros a1 a2 Ra b1 b2 Rb.
  destruct Ra as [ Ra1 Ra2 ]; destruct Rb as [ Rb1 Rb2 ].
  split; intros c1 c2 Rc; split; simpl;
    first [ apply Ra1 | apply Ra2 | apply Rb1 | apply Rb2 ]; assumption.
Qed.

(* compose commutes with pair *)
Lemma compose_f_pair_pfun A B C D
      `{OTRelation A} `{OTRelation B} `{OTRelation C} `{OTRelation D}
      (f: A -o> B) (g: B -o> C) (h: B -o> D) :
  ot_equiv (compose_pfun f (pair_pfun g h))
           (pair_pfun (compose_pfun f g) (compose_pfun f h)).
  split; intros a1 a2 Ra; simpl; split; repeat apply pfun_Proper; assumption.
Qed.

(* The first projection pfun *)
Definition fst_pfun {A B} `{OTRelation A} `{OTRelation B} : A * B -o> A :=
  {| pfun_app := fst; pfun_Proper := _ |}.

(* The second projection pfun *)
Definition snd_pfun {A B} `{OTRelation A} `{OTRelation B} : A * B -o> B :=
  {| pfun_app := snd; pfun_Proper := _ |}.

(* Composing pair with fst gives the first function in the pair *)
Lemma compose_pair_fst A B C `{OTRelation A} `{OTRelation B} `{OTRelation C}
      (f: A -o> B) (g: A -o> C) :
  ot_equiv (compose_pfun (pair_pfun f g) fst_pfun) f.
  split; intros a1 a2 Ra; simpl; apply pfun_Proper; assumption.
Qed.

(* Composing pair with snd gives the second function in the pair *)
Lemma compose_pair_snd A B C `{OTRelation A} `{OTRelation B} `{OTRelation C}
      (f: A -o> B) (g: A -o> C) :
  ot_equiv (compose_pfun (pair_pfun f g) snd_pfun) g.
  split; intros a1 a2 Ra; simpl; apply pfun_Proper; assumption.
Qed.

(* Taking the pair of fst and snd is the identity *)
Lemma pair_fst_snd_eta A B `{OTRelation A} `{OTRelation B} :
  ot_equiv (pair_pfun (fst_pfun (A:=A) (B:=B)) snd_pfun) id_pfun.
  split; intros p1 p2 Rp; destruct Rp; split; simpl; assumption.
Qed.

(* Curry a Pfun *)
Program Definition pfun_curry {A B C} `{OType A} `{OTRelation B} `{OTRelation C}
        (pfun : (A * B) -o> C)
  : A -o> (B -o> C) :=
  {| pfun_app :=
       fun a =>
         {| pfun_app := fun b => pfun_app pfun (a,b);
            pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros b1 b2 Rb. apply pfun_Proper.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
Proof.
  intros a1 a2 Ra b1 b2 Rb; simpl.
  apply pfun_Proper; split; assumption.
Qed.

(* Uncrry a Pfun *)
Program Definition pfun_uncurry {A B C}
        `{OTRelation A} `{OTRelation B} `{OTRelation C}
        (pfun : A -o> (B -o> C))
  : (A * B) -o> C :=
  {| pfun_app :=
       fun ab => pfun_app (pfun_app pfun (fst ab)) (snd ab);
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros ab1 ab2 Rab. destruct Rab as [ Ra Rb ].
  exact (pfun_Proper pfun (fst ab1) (fst ab2) Ra (snd ab1) (snd ab2) Rb).
Qed.

(* pfun_curry is Proper *)
Instance Proper_pfun_curry A B C `{OType A} `{OTRelation B} `{OTRelation C}
  : Proper (ot_R ==> ot_R) (pfun_curry (A:=A) (B:=B) (C:=C)).
Proof.
  intros f1 f2 Rf a1 a2 Ra b1 b2 Rb. apply Rf. split; assumption.
Qed.

(* pfun_curry is Proper w.r.t. equivalence *)
Instance Proper_pfun_curry_equiv A B C `{OType A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_equiv ==> ot_equiv) (pfun_curry (A:=A) (B:=B) (C:=C)).
Proof.
  intros f1 f2 Rf; destruct Rf; split; apply Proper_pfun_curry; assumption.
Qed.

(* FIXME: Proper instance for pfun_uncurry *)

(* Currying and uncurrying of pfuns form an isomorphism: part 1 *)
Lemma pfun_curry_uncurry_eq A B C `{OType A} `{OTRelation B} `{OTRelation C}
      (f: (A * B) -o> C) :
  pfun_uncurry (pfun_curry f) =o= f.
  split; intros ab1 ab2 Rab; simpl; apply pfun_Proper;
    destruct Rab; split; assumption.
Qed.

(* Currying and uncurrying of pfuns form an isomorphism: part 2 *)
Lemma pfun_uncurry_curry_eq A B C `{OType A} `{OTRelation B} `{OTRelation C}
      (f: A -o> B -o> C) :
  pfun_curry (pfun_uncurry f) =o= f.
  split; intros a1 a2 Ra b1 b2 Rb; simpl; apply Proper_pfun_app;
    try apply pfun_Proper; assumption.
Qed.

(* The S combinator for pfuns (FIXME: do we need this?) *)
Program Definition pfun_S {A B C} `{OTRelation A} `{OTRelation B} `{OTRelation C}
  : (A -o> B -o> C) -o> (A -o> B) -o> A -o> C :=
  {| pfun_app :=
       fun f =>
         {| pfun_app :=
              fun g =>
                {| pfun_app := fun a => pfun_app (pfun_app f a) (pfun_app g a) |}
         |}
  |}.
Next Obligation.
  intros a1 a2 Ra; apply Proper_pfun_app; try apply pfun_Proper; assumption.
Qed.
Next Obligation.
  intros g1 g2 Rg a1 a2 Ra. simpl. apply Proper_pfun_app; try assumption.
  - apply pfun_Proper; assumption.
  - apply Rg; assumption.
Qed.
Next Obligation.
  intros f1 f2 Rf g1 g2 Rg a1 a2 Ra. simpl. apply Proper_pfun_app; try assumption.
  - apply Rf; assumption.
  - apply Rg; assumption.
Qed.

(* This is the S combinator, but partially applied *)
Program Definition pfun_apply {A B C}
        `{OTRelation A} `{OTRelation B} `{OTRelation C}
        (f: A -o> B -o> C) (g: A -o> B) : A -o> C :=
  {| pfun_app := fun a => pfun_app (pfun_app f a) (pfun_app g a) |}.
Next Obligation.
  intros a1 a2 Ra; apply Proper_pfun_app; try apply pfun_Proper; assumption.
Qed.

Instance Proper_pfun_apply A B C `{OTRelation A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_R ==> ot_R ==> ot_R) (pfun_apply (A:=A) (B:=B) (C:=C)).
Proof.
  intros a1 a2 Ra b1 b2 Rb c1 c2 Rc. simpl.
  apply Ra; try assumption. apply Rb; try assumption.
Qed.

Instance Proper_pfun_apply_equiv A B C
         `{OTRelation A} `{OTRelation B} `{OTRelation C} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv) (pfun_apply (A:=A) (B:=B) (C:=C)).
Proof.
  intros a1 a2 Ra b1 b2 Rb; split; intros c1 c2 Rc; simpl;
    apply Ra; try apply Rb; assumption.
Qed.

(* compose commutes with S *)
Lemma compose_pfun_apply A B C D `{OType A} `{OType B} `{OType C} `{OType D}
      (f : A -o> B) (g: B -o> C -o> D) h :
  compose_pfun f (pfun_apply g h)
  =o= pfun_apply (compose_pfun f g) (compose_pfun f h).
  split; intros a1 a2 Ra; simpl; rewrite Ra; reflexivity.
Qed.

(* compose commutes with currying *)
Lemma compose_pfun_curry A B C D `{OType A} `{OType B} `{OType C} `{OType D}
      (f: A -o> B) (g: B * C -o> D) :
  ot_equiv (compose_pfun f (pfun_curry g))
           (pfun_curry
              (compose_pfun (pair_pfun (compose_pfun fst_pfun f) snd_pfun) g)).
  split; intros a1 a2 Ra c1 c2 Rc; simpl; rewrite Ra; rewrite Rc; reflexivity.
Qed.

(* Applying a const is just composition. Note that we add the extra OType
constraint to quantify over all possible proofs that B -o> C is an OType, so
this rule applies independently of this aOType proof. *)
Lemma pfun_apply_const A B C `{OType A} `{OType B} `{OType C}
      {OBC: OType (B -o> C)} (f: B -o> C) (g: A -o> B) :
  ot_equiv (pfun_apply (A:=A) (const_pfun f) g) (compose_pfun g f).
  split; intros a1 a2 Ra; simpl; rewrite Ra; reflexivity.
Qed.

(* We can simplify pfun_S used with pfun_curry *)
Lemma pfun_apply_pfun_curry A B C `{OType A} `{OType B} `{OType C} f g :
  ot_equiv (pfun_apply (A:=A) (B:=B) (C:=C) (pfun_curry f) g)
           (compose_pfun (pair_pfun id_pfun g) f).
  split; intros a1 a2 Ra; simpl; apply pfun_Proper; split;
    try apply pfun_Proper; assumption.
Qed.

(* The pair constructor as a pfun *)
Program Definition pair_ctor_pfun {A B} `{OType A} `{OType B}
  : A -o> B -o> A * B :=
  {| pfun_app := fun a => {| pfun_app := fun b => (a,b) |} |}.
Next Obligation.
  intros b1 b2 Rb; rewrite Rb; reflexivity.
Qed.
Next Obligation.
  intros a1 a2 Ra b1 b2 Rb; simpl; rewrite Ra; rewrite Rb; reflexivity.
Qed.

(* Applying pair_ctor_pfun yields a pair_pfun *)
Lemma apply_pair_ctor_pfun {A B C} `{OType A} `{OType B} `{OType C}
      (f: A -o> B) (g: A -o> C) :
  ot_equiv (pfun_apply (pfun_apply (const_pfun pair_ctor_pfun) f) g)
           (pair_pfun f g).
  split; intros a1 a2 Ra; simpl; rewrite Ra; reflexivity.
Qed.

(***
 *** Building Proper Functions
 ***)

Class ProperPair A `{OTRelation A} (x y:A) : Prop :=
  proper_pair_pf : ot_R x y.

Definition ofun {A B} `{OTRelation A} `{OTRelation B} (f: A -> B)
           {prp:forall x y, ProperPair A x y -> ProperPair B (f x) (f y)}
  : A -o> B :=
  {| pfun_app := f; pfun_Proper := prp |}.

Instance ProperPair_refl A `{OType A} (x:A) : ProperPair A x x.
Proof.
  unfold ProperPair. reflexivity.
Qed.

Instance ProperPair_pfun_app A B `{OType A} `{OType B}
         (fl fr:A -o> B) argl argr
         (prpf:ProperPair (A -o> B) fl fr)
         (prpa:ProperPair A argl argr)
 : ProperPair B (pfun_app fl argl) (pfun_app fr argr).
Proof.
  apply prpf; assumption.
Qed.

Instance ProperPair_ofun A B `{OType A} `{OType B} (f g:A -> B) prpl prpr
         (pf: forall x y, ProperPair A x y -> ProperPair B (f x) (g y)) :
  ProperPair (A -o> B) (@ofun A B _ _ f prpl) (@ofun A B _ _ g prpr).
Proof.
  intros xl xr Rx; apply pf; assumption.
Qed.

(***
 *** Ordered Terms and ProperPair Instances for Pair Operations
 ***)

(* Proper function for fst *)
Definition ofst {A B} `{OTRelation A} `{OTRelation B} : A * B -o> A :=
  {| pfun_app := fst; pfun_Proper := _ |}.

(* Proper function for snd *)
Definition osnd {A B} `{OTRelation A} `{OTRelation B} : A * B -o> B :=
  {| pfun_app := snd; pfun_Proper := _ |}.

(* Proper function for pair *)
Program Definition opair {A B} `{OType A} `{OType B} : A -o> B -o> A * B :=
  {| pfun_app :=
       fun a => {| pfun_app := fun b => pair a b;
                   pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
  intros b1 b2 Rb. split; [ reflexivity | assumption ].
Qed.
Next Obligation.
  intros a1 a2 Ra b1 b2 Rb. split; assumption.
Qed.

(* Notation for proper pairs *)
Notation "( x ,o, y )" := (opair @o@ x @o@ y) (at level 0).

(* FIXME: get this notation to work *)
(*
Notation "( x ,o, y ,o, .. ,o, z )" :=
  (pfun_app opair .. (pfun_app (pfun_app opair x) y) .. z)
                                         (at level 0).
*)

(*
Instance ProperPair_fst A B `{OType A} `{OType B} (p1 p2: A*B)
         (pf: ProperPair (A*B) p1 p2) :
  ProperPair A (fst p1) (fst p2).
Proof.
  destruct pf; assumption.
Qed.

Instance ProperPair_snd A B `{OType A} `{OType B} (p1 p2: A*B)
         (pf: ProperPair (A*B) p1 p2) :
  ProperPair B (snd p1) (snd p2).
Proof.
  destruct pf; assumption.
Qed.

Instance ProperPair_pair A B `{OType A} `{OType B}
         (x1 x2:A) (y1 y2:B) (pfx: ProperPair A x1 x2) (pfy: ProperPair B y1 y2) :
  ProperPair (A*B) (pair x1 y1) (pair x2 y2).
Proof.
  split; assumption.
Qed.
 *)

(***
 *** Notations for Ordered Types
 ***)

(* FIXME: why don't these work?
Notation "'pfun' ( x : A ) =o> t" :=
  (@ot_Lambda A _ (fun x => t))
    (at level 100, right associativity, x at level 99) : pterm_scope.

Notation "'pfun' x =o> t" :=
  (ot_Lambda (fun x => t))
    (at level 100, right associativity, x at level 99) : pterm_scope.
 *)

(***
 *** Ordered Type Functions
 ***)

(*
Definition ot_fun_app (TF: forall A `{OType A}, Type) A `{OType A} := TF A.

Notation "F @t@ A" :=
  (ot_fun_app F A%type) (left associativity, at level 20).
*)

Class OTRelationF (TF: forall A `{OType A}, Type) : Type :=
  ot_rel_app : forall A `{OType A}, OTRelation (TF A).

Instance OTRelation_ot_rel_app TF `(OTRelationF TF) A `(OType A) :
  OTRelation (TF A _ _) := ot_rel_app A.

Class OTypeF (TF: forall A `{OType A}, Type) `{OTRelationF TF} : Prop :=
  otype_app : forall A `{OType A}, OType (TF A).

Instance OType_otype_app TF `(OTypeF TF) A `(OType A) :
  OType (TF A _ _) := otype_app A.

(***
 *** Examples of Ordered Terms
 ***)

Module OTExamples.

Definition ex1 : Prop -o> Prop := ofun (fun p => p).
(* Eval compute in (pfun_app ex1 : Prop -> Prop). *)

Definition ex2 {A} `{OType A} : A -o> A := ofun (fun p => p).
(* Eval simpl in (fun A `{OType A} => pfun_app (@ex2 A _ _) : A -> A). *)

Definition ex3 {A} `{OType A} : A -o> A -o> A :=
  ofun (fun p1 => ofun (fun p2 => p1)).
(* Eval simpl in (fun (A:OType) x => pfun_app (pfun_app (@ex3 A) x)). *)

Definition ex4 {A B} `{OType A} `{OType B} : (A * B -o> A) :=
  ofun (fun p => ofst @o@ p).
(* Eval simpl in (fun {A B} `{OType A} `{OType B} =>
                 pfun_app ex4 : A * B -> A). *)

Definition ex5 {A B} `{OType A} `{OType B} : A * B -o> B * A :=
  ofun (fun p => (osnd @o@ p ,o, ofst @o@ p)).
(* Eval simpl in (fun {A B} `{OType A} `{OType B} =>
                 pfun_app ex5 : A * B -> B * A). *)

Definition ex6 {A B C} `{OType A} `{OType B} `{OType C} : A * B * C -o> C * A :=
  ofun (fun triple => (osnd @o@ triple ,o, ofst @o@ (ofst @o@ triple))).

Definition ex7 {A B C} `{OType A} `{OType B} `{OType C}
  : (A * B -o> C) -o> C -o> A -o> B -o> C :=
  ofun (fun f =>
               ofun
                 (fun c =>
                    ofun
                      (fun a =>
                         ofun (fun b => f @o@ (a ,o, b))))).

End OTExamples.


Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.List.In.
Require Import Logic.List.Nil.
Require Import Logic.List.Equiv.
Require Import Logic.List.Concat.
Require Import Logic.List.Append.
Require Import Logic.List.Include.

Declare Scope Intersect_scope.

Fixpoint inter (v:Type) (e:Eq v) (xs ys:list v) : list v :=
    match xs with
    | nil        => nil
    | cons x xs =>
        match in_dec eqDec x ys with
        | left  _   => cons x (inter v e xs ys)
        | right _   => inter v e xs ys
        end
    end.

Arguments inter {v} {e}.

Notation "xs /\ ys" := (inter xs ys)
    (at level 80, right associativity) : Intersect_scope.

Open Scope Intersect_scope.

Lemma inter_charac : forall (v:Type) (e:Eq v) (xs ys:list v) (z:v),
    z :: (xs /\ ys) <-> z :: xs /\ z :: ys.
Proof.
    intros v e xs ys z. split.
    - induction xs as [|x xs IH]; intros H.
        + inversion H.
        + destruct (in_dec eqDec x ys) as [H'|H'] eqn:E;
          simpl in H; rewrite E in H.
            { destruct H as [H|H].
                { subst. split.
                    { left. reflexivity. }
                    { assumption. }
                }
                { apply IH in H. destruct H as [H1 H2]. split.
                    { right. assumption. }
                    { assumption. }
                }
            }
            { apply IH in H. destruct H as [H1 H2]. split.
                { right. assumption. }
                { assumption. }
            }
   - induction xs as [|x xs IH]; intros [H1 H2].
        + inversion H1.
        + destruct (in_dec eqDec x ys) as [H|H] eqn:E; simpl; rewrite E.
            { destruct H1 as [H1|H1].
                { subst. left. reflexivity. }
                { right. apply IH. split; assumption. }
            }
            { destruct H1 as [H1|H1].
                { subst. exfalso. apply H. assumption. }
                { apply IH. split; assumption. }
            }
Qed.

(* left-distributivity is false: xs = [0], ys = [1], zs = [1,0], then           *)
(* zs /\ xs = [0]                                                               *)
(* zs /\ ys = [1]                                                               *)
(* so (zs /\ xs) ++ (zs /\ ys) = [0,1] where zs /\ (xs ++ ys) = [1,0]           *)
Lemma inter_distrib_app_r : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    ((xs ++ ys) /\ zs) = (xs /\ zs) ++ (ys /\ zs).
Proof.
    intros v e. induction xs as [|x xs IH]; intros ys zs.
    - reflexivity.
    - rewrite <- app_comm_cons. simpl. destruct (in_dec eqDec x zs) as [H|H].
        + rewrite <- app_comm_cons. rewrite IH. reflexivity.
        + apply IH.
Qed.

Lemma inter_cons_not_in_r : forall (v:Type) (e:Eq v) (xs ys:list v) (y:v),
    ~ y :: xs -> (xs /\ (cons y ys)) = (xs /\ ys).
Proof.
    intros v e. induction xs as [|x xs IH]; intros ys y H.
    - reflexivity.
    - simpl. destruct (eqDec y x) as [H1|H1].
        + subst. exfalso. apply H. left. reflexivity.
        + destruct (in_dec eqDec x ys) as [H2|H2].
            { rewrite IH.
                { reflexivity. }
                { intros H3. apply H. right. assumption. }}
            { apply IH.  intros H3. apply H. right. assumption. }
Qed.

Lemma inter_cons_not_in_l : forall (v:Type) (e:Eq v) (xs ys:list v) (x:v),
    ~ x :: ys -> ((cons x xs) /\ ys) = (xs /\ ys).
Proof.
    intros v e. induction xs as [|x xs IH]; intros ys y H;
    simpl; destruct (in_dec eqDec y ys) as [H1|H1].
    - apply H in H1. contradiction.
    - reflexivity.
    - apply H in H1. contradiction.
    - reflexivity.
Qed.

Lemma inter_cons_in_r : forall (v:Type) (e:Eq v) (xs ys:list v) (y:v),
    y :: ys -> (xs /\ (cons y ys)) = (xs /\ ys).
Proof.
    intros v e. induction xs as [|x xs IH]; intros ys y H.
    - reflexivity.
    - simpl. destruct (eqDec y x) as [H1|H1].
        + subst. destruct (in_dec eqDec x ys) as [H2|H2].
            { rewrite IH.
                { reflexivity. }
                { assumption. }}
            { apply H2 in H. contradiction. }
        + destruct (in_dec eqDec x ys) as [H2|H2]; rewrite IH.
            { reflexivity. }
            { assumption. }
            { reflexivity. }
            { assumption. }
Qed.

Lemma inter_nil : forall (v:Type) (e:Eq v) (xs:list v),
    (xs /\ nil) = nil.
Proof.
    intros v e. induction xs as [|x xs IH].
    - reflexivity.
    - simpl. apply IH.
Qed.

Lemma inter_comm : forall (v:Type) (e:Eq v) (xs ys:list v),
    (xs /\ ys) == (ys /\ xs).
Proof.
   intros v e xs ys. split; intros z H; apply inter_charac in H;
    destruct H as [H1 H2]; apply inter_charac; split; assumption.
Qed.

Lemma inter_assoc : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    ((xs /\ ys) /\ zs) == (xs /\ (ys /\ zs)).
Proof.
    intros v e xs ys zs. split; intros z H; apply inter_charac in H;
    destruct H as [H1 H3].
    - apply inter_charac in H1. destruct H1 as [H1 H2].
      apply inter_charac. split.
        + assumption.
        + apply inter_charac. split; assumption.
    - apply inter_charac in H3. destruct H3 as [H2 H3].
      apply inter_charac. split.
        + apply inter_charac. split; assumption.
        + assumption.
Qed.

Lemma inter_compat_l : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    xs == ys -> (xs /\ zs) == (ys /\ zs).
Proof.
    intros v e xs ys zs [H1 H2]. split; intros z H;
    apply inter_charac in H; destruct H as [H3 H4];
    apply inter_charac; split.
    - apply H1. assumption.
    - assumption.
    - apply H2. assumption.
    - assumption.
Qed.

Lemma inter_compat_r : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    xs == ys -> (zs /\ xs) == (zs /\ ys).
Proof.
    intros v e xs ys zs [H1 H2]. split; intros z H;
    apply inter_charac in H; destruct H as [H3 H4];
    apply inter_charac; split.
    - assumption.
    - apply H1. assumption.
    - assumption.
    - apply H2. assumption.
Qed.

Lemma inter_compat_lr : forall (v:Type) (e:Eq v) (xs xs' ys ys':list v),
    xs == xs' -> ys == ys' -> (xs /\ ys) == (xs' /\ ys').
Proof.
   intros v e xs xs' ys ys' H1 H2.
   apply equivTrans with (xs' /\ ys).
   - apply inter_compat_l. assumption.
   - apply inter_compat_r. assumption.
Qed.

Lemma inter_sub : forall (v:Type) (e:Eq v) (xs ys:list v),
    xs <= ys -> (xs /\ ys) == xs.
Proof.
    intros v e xs ys H1. split; intros z H2.
    - apply inter_charac in H2. destruct H2 as [H2 H3]. assumption.
    - apply inter_charac. split.
        + assumption.
        + apply H1. assumption.
Qed.

(* Stronger result, useful for rewrite.                                         *)
Lemma inter_sub' : forall (v:Type) (e:Eq v) (xs ys:list v),
    xs <= ys -> (xs /\ ys) = xs.
Proof.
    intros v e. induction xs as [|x xs IH]; intros ys H.
    - reflexivity.
    - simpl. destruct (in_dec eqDec x ys) as [H1|H1].
        + rewrite IH.
            { reflexivity. }
            { intros z H2. apply H. right. assumption. }
        + exfalso. apply H1, H. left. reflexivity.
Qed.

Lemma inter_sub_equiv : forall (v:Type) (e:Eq v) (xs ys zs zs':list v),
    zs' <= zs ->
    (zs /\ xs)  == (zs /\ ys) ->
    (zs' /\ xs) == (zs' /\ ys).
Proof.
    intros v e xs ys zs zs' H1 H2.
    apply equivTrans with ((zs' /\ zs) /\ xs).
    - apply inter_compat_l. apply equivSym. apply inter_sub. assumption.
    - apply equivTrans with ((zs' /\ zs) /\ ys).
        + apply equivTrans with (zs' /\ (zs /\ xs)).
            { apply inter_assoc. }
            { apply equivTrans with (zs' /\ (zs /\ ys)).
                { apply inter_compat_r. assumption. }
                { apply equivSym. apply inter_assoc. }}
        + apply inter_compat_l. apply inter_sub. assumption.
Qed.

Lemma inter_distrib_app_l : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    (zs /\ (xs ++ ys)) == (zs /\ xs) ++ (zs /\ ys).
Proof.
    intros v e xs ys zs. apply equivTrans with ((xs ++ ys) /\ zs).
    - apply inter_comm.
    - rewrite inter_distrib_app_r. apply app_compat_lr; apply inter_comm.
Qed.

Lemma inter_app_nil_l : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    (zs /\ (xs ++ ys)) = nil -> (zs /\ xs) = nil /\ (zs /\ ys) = nil.
Proof.
    intros v e xs ys zs H1. apply equivNil in H1.
    assert ((zs /\ xs) ++ (zs /\ ys) == nil) as H2.
        { apply (equivCompatLR v (zs /\ (xs ++ ys)) nil).
            { apply equivSym, inter_distrib_app_l. }
            { apply equivRefl. }
            { assumption. }}
    apply equivNil in H2. apply app_nil in H2. destruct H2 as [H2 H3].
    split; assumption.
Qed.

Lemma inter_sub_nil_l : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    xs <= ys -> (ys /\ zs) = nil -> (xs /\ zs) = nil.
Proof.
   intros v e xs ys zs H1 H2. apply nil_charac. intros x.
   rewrite inter_charac. intros [H3 H4]. rewrite nil_charac in H2.
   apply (H2 x). apply inter_charac. split.
   - apply H1. assumption.
   - assumption.
Qed.

Lemma inter_sub_nil_r : forall (v:Type) (e:Eq v) (xs ys zs:list v),
    xs <= ys -> (zs /\ ys) = nil -> (zs /\ xs) = nil.
Proof.
    intros v e xs ys zs H1 H2. apply nil_charac. intros x.
    rewrite inter_charac. intros [H3 H4]. rewrite nil_charac in H2.
    apply (H2 x). apply inter_charac. split.
    - assumption.
    - apply H1. assumption.
Qed.

Lemma inter_concat_nil_l : forall (v:Type) (e:Eq v) (f:v -> list v) (xs ys:list v),
    (forall (u:v), u :: ys -> (xs /\ f u) = nil) ->
        (xs /\ concat (map f ys)) = nil.
Proof.
    intros v e f xs ys H1. apply nil_charac. intros x H2.
    apply inter_charac in H2. destruct H2 as [H2 H3]. apply concat_charac in H3.
    destruct H3 as [zs [H3 H4]]. apply in_map_iff in H4.
    destruct H4 as [u [H4 H5]].
    remember (H1 u H5) as H6 eqn:E. clear E. rewrite nil_charac in H6.
    apply (H6 x), inter_charac. rewrite <- H4 in H3. split; assumption.
Qed.