(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(** * Finite map library *)

(** This file proposes an implementation of the non-dependant interface
 [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
 left projection. *)

Require Import FMapInterface.

Set Implicit Arguments.
Unset Strict Implicit.

Module Raw (X:OrderedType).

Module Import MX := OrderedTypeFacts X.
Module Import PX := KeyOrderedType X.

Definition key := X.t.
Definition t (elt:Type) := list (X.t * elt).

Section Elt.
Variable elt : Type.

Notation eqk := (eqk (elt:=elt)).
Notation eqke := (eqke (elt:=elt)).
Notation ltk := (ltk (elt:=elt)).
Notation MapsTo := (MapsTo (elt:=elt)).
Notation In := (In (elt:=elt)).
Notation Sort := (sort ltk).
Notation Inf := (lelistA (ltk)).

(** * [empty] *)

Definition empty : t elt := 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 : t elt) : bool := if l then true else false.

Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
Proof.
 unfold Empty, PX.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 : t elt) {struct s} : bool :=
 match s with
  | nil => false
  | (k',_) :: l =>
     match X.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 (X.eq x k');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 PX.In,PX.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: t elt) {struct s} : option elt :=
 match s with
  | nil => None
  | (k',x)::s' =>
     match X.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 PX.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 PX.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;order.
 clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

 clear e1;inversion_clear 2.
 compute in H0; destruct H0; intuition congruence.
 generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.

 clear e1; do 2 inversion_clear 1; auto.
 compute in H2; destruct H2; order.
Qed.

(** * [add] *)

Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
 match s with
  | nil => (k,x) :: nil
  | (k',y) :: l =>
     match X.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, X.eq x y -> MapsTo y e (add x e m).
Proof.
 intros m x y e; generalize y; clear y.
 unfold PX.MapsTo.
 functional induction (add x e m);simpl;auto.
Qed.

Lemma add_2 : forall m x y e e',
  ~ X.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 PX.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.
 auto.
 auto.
 intros y' e'' eqky'; inversion_clear 1; intuition.
Qed.

Lemma add_3 : forall m x y e e',
  ~ X.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 PX.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:t elt)(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 (X.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 (X.compare x x'); intuition; inversion_clear Hm; auto.
 constructor; auto.
 apply Inf_eq with (x',e'); auto.
Qed.

(** * [remove] *)

Function remove (k : key) (s : t elt) {struct s} : t elt :=
 match s with
  | nil => nil
  | (k',x) :: l =>
     match X.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, X.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 H1.

 apply Sort_Inf_NotIn with x0; auto.
 clear e0;constructor; compute; order.

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

 clear e0;inversion_clear Hm.
 assert (notin:~ In y (remove x l)) by auto.
 intros (x1,abs).
 inversion_clear abs.
 compute in H2; destruct H2; order.
 apply notin; exists x1; auto.
Qed.

Lemma remove_2 : forall m (Hm:Sort m) x y e,
  ~ X.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 PX.MapsTo.
 functional induction (remove x m);subst;auto;
   match goal with
     | [H: X.compare _ _ = _ |- _ ] => clear H
     | _ => idtac
   end.

 inversion_clear 3; auto.
 compute in H1; destruct H1; order.

 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 PX.MapsTo.
 functional induction (remove x m);subst;auto.
 inversion_clear 1; inversion_clear 1; auto.
Qed.

Lemma remove_Inf : forall (m:t elt)(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 (X.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 (X.compare x x'); intuition; inversion_clear Hm; auto.
Qed.

(** * [elements] *)

Definition elements (m: t elt) := 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 eqk (elements m).
Proof.
 intros.
 apply Sort_NoDupA.
 apply elements_3; auto.
Qed.

(** * [fold] *)

Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (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' : t elt) {struct m} : bool :=
  match m, m' with
   | nil, nil => true
   | (x,e)::l, (x',e')::l' =>
      match X.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: X.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; order.
 destruct (H0 k).
 assert (In k ((x',e') ::l')).
  destruct H as (e'', hyp); exists e''; auto.
 destruct (In_inv (H3 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; order.
 apply H1 with k; destruct (X.eq_dec x k); auto.

 destruct (X.compare x x'); try contradiction; clear y.
 destruct (H0 x).
 assert (In x ((x',e')::l')).
  apply H; auto.
  exists e; auto.
 destruct (In_inv H3).
 order.
 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.
 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: X.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 X.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 X.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 H9; simpl in *; subst; auto.
 elim (Sort_Inf_NotIn H4 H5).
 exists e'0; apply MapsTo_eq with k; auto; order.
 inversion_clear H1.
 destruct H0; simpl in *; subst; auto.
 elim (Sort_Inf_NotIn H2 H3).
 exists e0; apply MapsTo_eq with k; 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.
 elim_comp.
 rewrite H2; simpl.
 apply equal_1; auto.
 apply equal_2; auto.
 generalize (equal_1 H H0 H3).
 simpl.
 elim_comp.
 rewrite H2; simpl; auto.
Qed.

Variable elt':Type.

(** * [map] and [mapi] *)

Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
  match m with
   | nil => nil
   | (k,e)::m' => (k,f e) :: map f m'
  end.

Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
  match m with
   | nil => nil
   | (k,e)::m' => (k,f k e) :: mapi f m'
  end.

End Elt.
Section Elt2.
(* A new section is necessary for previous definitions to work
   with different [elt], especially [MapsTo]... *)

Variable elt elt' : Type.

(** Specification of [map] *)

Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
  MapsTo x e m -> MapsTo x (f e) (map f m).
Proof.
 intros m x e f.
 (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
 induction m.
 inversion 1.

 destruct a as (x',e').
 simpl.
 inversion_clear 1.
 constructor 1.
 unfold eqke in *; simpl in *; intuition congruence.
 constructor 2.
 unfold MapsTo in *; auto.
Qed.

Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
  In x (map f m) -> In x m.
Proof.
 intros m x f.
 (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
 induction m; simpl.
 intros (e,abs).
 inversion abs.

 destruct a as (x',e).
 intros hyp.
 inversion hyp. clear hyp.
 inversion H; subst; rename x0 into e'.
 exists e; constructor.
 unfold eqke in *; simpl in *; intuition.
 destruct IHm as (e'',hyp).
 exists e'; auto.
 exists e''.
 constructor 2; auto.
Qed.

Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,e') (map f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x0,e0).
 inversion_clear H; auto.
Qed.

Hint Resolve map_lelistA.

Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'),
  sort (@ltk elt') (map f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear Hm.
 constructor; auto.
 exact (map_lelistA _ _ H0).
Qed.

(** Specification of [mapi] *)

Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
  MapsTo x e m ->
  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
Proof.
 intros m x e f.
 (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
 induction m.
 inversion 1.

 destruct a as (x',e').
 simpl.
 inversion_clear 1.
 exists x'.
 destruct H0; simpl in *.
 split; auto.
 constructor 1.
 unfold eqke in *; simpl in *; intuition congruence.
 destruct IHm as (y, hyp); auto.
 exists y; intuition.
Qed.

Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
  In x (mapi f m) -> In x m.
Proof.
 intros m x f.
 (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
 induction m; simpl.
 intros (e,abs).
 inversion abs.

 destruct a as (x',e).
 intros hyp.
 inversion hyp. clear hyp.
 inversion H; subst; rename x0 into e'.
 exists e; constructor.
 unfold eqke in *; simpl in *; intuition.
 destruct IHm as (e'',hyp).
 exists e'; auto.
 exists e''.
 constructor 2; auto.
Qed.

Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,f x e) (mapi f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear H; auto.
Qed.

Hint Resolve mapi_lelistA.

Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'),
  sort (@ltk elt') (mapi f m).
Proof.
 induction m; simpl; auto.
 intros.
 destruct a as (x',e').
 inversion_clear Hm; auto.
Qed.

End Elt2.
Section Elt3.

(** * [map2] *)

Variable elt elt' elt'' : Type.
Variable f : option elt -> option elt' -> option elt''.

Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
  match o with
   | Some e => (k,e)::l
   | None => l
  end.

Fixpoint map2_l (m : t elt) : t elt'' :=
  match m with
   | nil => nil
   | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
  end.

Fixpoint map2_r (m' : t elt') : t elt'' :=
  match m' with
   | nil => nil
   | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
  end.

Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
  match m with
   | nil => map2_r
   | (k,e) :: l =>
      fix map2_aux (m' : t elt') : t elt'' :=
        match m' with
         | nil => map2_l m
         | (k',e') :: l' =>
            match X.compare k k' with
             | LT _ => option_cons k (f (Some e) None) (map2 l m')
             | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l')
             | GT _ => option_cons k' (f None (Some e')) (map2_aux l')
            end
        end
  end.

Notation oee' := (option elt * option elt')%type.

Fixpoint combine (m : t elt) : t elt' -> t oee' :=
  match m with
   | nil => map (fun e' => (None,Some e'))
   | (k,e) :: l =>
      fix combine_aux (m':t elt') : list (key * oee') :=
        match m' with
         | nil => map (fun e => (Some e,None)) m
         | (k',e') :: l' =>
            match X.compare k k' with
             | LT _ => (k,(Some e, None))::combine l m'
             | EQ _ => (k,(Some e, Some e'))::combine l l'
             | GT _ => (k',(None,Some e'))::combine_aux l'
            end
        end
  end.

Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) :=
  List.fold_right (fun p => f (fst p) (snd p)) i l.

Definition map2_alt m m' :=
  let m0 : t oee' := combine m m' in
  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
  fold_right_pair (option_cons (A:=elt'')) m1 nil.

Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
Proof.
 unfold map2_alt.
 induction m.
 simpl; auto; intros.
 (* map2_r *)
 induction m'; try destruct a; simpl; auto.
 rewrite IHm'; auto.
 (* fin map2_r *)
 induction m'; destruct a.
 simpl; f_equal.
 (* map2_l *)
 clear IHm.
 induction m; try destruct a; simpl; auto.
 rewrite IHm; auto.
 (* fin map2_l *)
 destruct a0.
 simpl.
 destruct (X.compare t0 t1); simpl; f_equal.
 apply IHm.
 apply IHm.
 apply IHm'.
Qed.

Lemma combine_lelistA :
  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
  lelistA (@ltk elt) (x,e) m ->
  lelistA (@ltk elt') (x,e') m' ->
  lelistA (@ltk oee') (x,e'') (combine m m').
Proof.
 induction m.
 intros.
 simpl.
 exact (map_lelistA _ _ H0).
 induction m'.
 intros.
 destruct a.
 replace (combine ((t0, e0) :: m) nil) with
             (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
 exact (map_lelistA _ _ H).
 intros.
 simpl.
 destruct a as (k,e0); destruct a0 as (k',e0').
 destruct (X.compare k k').
 inversion_clear H; auto.
 inversion_clear H; auto.
 inversion_clear H0; auto.
Qed.
Hint Resolve combine_lelistA.

Lemma combine_sorted :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
  sort (@ltk oee') (combine m m').
Proof.
 induction m.
 intros; clear Hm.
 simpl.
 apply map_sorted; auto.
 induction m'.
 intros; clear Hm'.
 destruct a.
 replace (combine ((t0, e) :: m) nil) with
             (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
 apply map_sorted; auto.
 intros.
 simpl.
 destruct a as (k,e); destruct a0 as (k',e').
 destruct (X.compare k k').
 inversion_clear Hm.
 constructor; auto.
 assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
 exact (combine_lelistA _ H0 H1).
 inversion_clear Hm; inversion_clear Hm'.
 constructor; auto.
 assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
 exact (combine_lelistA _ H0 H3).
 inversion_clear Hm; inversion_clear Hm'.
 constructor; auto.
 change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
                 (combine ((k,e)::m) m')).
 assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
 exact (combine_lelistA _  H3 H2).
Qed.

Lemma map2_sorted :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
  sort (@ltk elt'') (map2 m m').
Proof.
 intros.
 rewrite <- map2_alt_equiv.
 unfold map2_alt.
 assert (H0:=combine_sorted Hm Hm').
 set (l0:=combine m m') in *; clearbody l0.
 set (f':= fun p : oee' => f (fst p) (snd p)).
 assert (H1:=map_sorted (elt' := option elt'') H0 f').
 set (l1:=map f' l0) in *; clearbody l1.
 clear f' f H0 l0 Hm Hm' m m'.
 induction l1.
 simpl; auto.
 inversion_clear H1.
 destruct a; destruct o; auto.
 simpl.
 constructor; auto.
 clear IHl1.
 induction l1.
 simpl; auto.
 destruct a; destruct o; simpl; auto.
 inversion_clear H0; auto.
 inversion_clear H0.
 red in H1; simpl in H1.
 inversion_clear H.
 apply IHl1; auto.
 apply Inf_lt with (t1, None (A:=elt'')); auto.
Qed.

Definition at_least_one (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => Some (o,o')
  end.

Lemma combine_1 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
  find x (combine m m') = at_least_one (find x m) (find x m').
Proof.
 induction m.
 intros.
 simpl.
 induction m'.
 intros; simpl; auto.
 simpl; destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 inversion_clear Hm'; auto.
 induction m'.
 (* m' = nil *)
 intros; destruct a; simpl.
 destruct (X.compare x t0); simpl; auto.
 inversion_clear Hm; clear H0 l Hm' IHm t0.
 induction m; simpl; auto.
 inversion_clear H.
 destruct a.
 simpl; destruct (X.compare x t0); simpl; auto.
 (* m' <> nil *)
 intros.
 destruct a as (k,e); destruct a0 as (k',e'); simpl.
 inversion Hm; inversion Hm'; subst.
 destruct (X.compare k k'); simpl;
  destruct (X.compare x k);
   elim_comp || destruct (X.compare x k'); simpl; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 rewrite IHm; auto; simpl; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
 change (find x (combine ((k, e) :: m) m') =
         at_least_one (find x m) (find x m')).
 rewrite IHm'; auto.
 simpl find; elim_comp; auto.
Qed.

Definition at_least_one_then_f (o:option elt)(o':option elt') :=
  match o, o' with
   | None, None => None
   | _, _  => f o o'
  end.

Lemma map2_0 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
Proof.
 intros.
 rewrite <- map2_alt_equiv.
 unfold map2_alt.
 assert (H:=combine_1 Hm Hm' x).
 assert (H2:=combine_sorted Hm Hm').
 set (f':= fun p : oee' => f (fst p) (snd p)).
 set (m0 := combine m m') in *; clearbody m0.
 set (o:=find x m) in *; clearbody o.
 set (o':=find x m') in *; clearbody o'.
 clear Hm Hm' m m'.
 generalize H; clear H.
 match goal with |- ?m=?n -> ?p=?q =>
   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
 induction m0; simpl in *; intuition.
 destruct o; destruct o'; simpl in *; try discriminate; auto.
 destruct a as (k,(oo,oo')); simpl in *.
 inversion_clear H2.
 destruct (X.compare x k); simpl in *.
 (* x < k *)
 destruct (f' (oo,oo')); simpl.
 elim_comp.
 destruct o; destruct o'; simpl in *; try discriminate; auto.
 destruct (IHm0 H0) as (H2,_); apply H2; auto.
 rewrite <- H.
 case_eq (find x m0); intros; auto.
 assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)).
 exists p; apply find_2; auto.
 (* x = k *)
 assert (at_least_one_then_f o o' = f oo oo').
  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
 rewrite H2.
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 case_eq (find x m0); intros; auto.
 assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)).
 exists p; apply find_2; auto.
 (* k < x *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (H3,_); apply H3; auto.
 destruct (IHm0 H0) as (H3,_); apply H3; auto.

 (* None -> None *)
 destruct a as (k,(oo,oo')).
 simpl.
 inversion_clear H2.
 destruct (X.compare x k).
 (* x < k *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 case_eq (find x m0); intros; auto.
 assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
  red; auto.
 destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
 exists p; apply find_2; auto.
 (* x = k *)
 discriminate.
 (* k < x *)
 unfold f'; simpl.
 destruct (f oo oo'); simpl.
 elim_comp; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
 destruct (IHm0 H0) as (_,H4); apply H4; auto.
Qed.

(** Specification of [map2] *)

Lemma map2_1 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
  In x m \/ In x m' ->
  find x (map2 m m') = f (find x m) (find x m').
Proof.
 intros.
 rewrite map2_0; auto.
 destruct H as [(e,H)|(e,H)].
 rewrite (find_1 Hm H).
 destruct (find x m'); simpl; auto.
 rewrite (find_1 Hm' H).
 destruct (find x m); simpl; auto.
Qed.

Lemma map2_2 :
  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
  In x (map2 m m') -> In x m \/ In x m'.
Proof.
 intros.
 destruct H as (e,H).
 generalize (map2_0 Hm Hm' x).
 rewrite (find_1 (map2_sorted Hm Hm') H).
 generalize (@find_2 _ m x).
 generalize (@find_2 _ m' x).
 destruct (find x m);
   destruct (find x m'); simpl; intros.
 left; exists e0; auto.
 left; exists e0; auto.
 right; exists e0; auto.
 discriminate.
Qed.

End Elt3.
End Raw.

Module Make (X: OrderedType) <: S with Module E := X.
Module Raw := Raw X.
Module E := X.

Definition key := E.t.

Record slist (elt:Type) :=
  {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
Definition t (elt:Type) : Type := slist elt.

Section Elt.
 Variable elt elt' elt'':Type.

 Implicit Types m : t elt.
 Implicit Types x y : key.
 Implicit Types e : elt.

 Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
 Definition is_empty m : bool := Raw.is_empty m.(this).
 Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e).
 Definition find x m : option elt := Raw.find x m.(this).
 Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x).
 Definition mem x m : bool := Raw.mem x m.(this).
 Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f).
 Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
 Definition map2 f m (m':t elt') : t elt'' :=
   Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
 Definition elements m : list (key*elt) := @Raw.elements elt m.(this).
 Definition cardinal m := length m.(this).
 Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f m.(this) i.
 Definition equal cmp m m' : bool := @Raw.equal elt cmp m.(this) m'.(this).

 Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
 Definition In x m : Prop := Raw.PX.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 (eq_elt:elt->elt->Prop) m m' :=
         (forall k, In k m <-> In k m') /\
         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
 Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this).

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

 Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
 Proof. intros m; exact (@Raw.PX.MapsTo_eq elt m.(this)). Qed.

 Lemma mem_1 : forall m x, In x m -> mem x m = true.
 Proof. intros m; exact (@Raw.mem_1 elt m.(this) m.(sorted)). Qed.
 Lemma mem_2 : forall m x, mem x m = true -> In x m.
 Proof. intros m; exact (@Raw.mem_2 elt m.(this) m.(sorted)). Qed.

 Lemma empty_1 : Empty empty.
 Proof. exact (@Raw.empty_1 elt). Qed.

 Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
 Proof. intros m; exact (@Raw.is_empty_1 elt m.(this)). Qed.
 Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
 Proof. intros m; exact (@Raw.is_empty_2 elt m.(this)). Qed.

 Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
 Proof. intros m; exact (@Raw.add_1 elt m.(this)). Qed.
 Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
 Proof. intros m; exact (@Raw.add_2 elt m.(this)). Qed.
 Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
 Proof. intros m; exact (@Raw.add_3 elt m.(this)). Qed.

 Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
 Proof. intros m; exact (@Raw.remove_1 elt m.(this) m.(sorted)). Qed.
 Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
 Proof. intros m; exact (@Raw.remove_2 elt m.(this) m.(sorted)). Qed.
 Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
 Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed.

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

 Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
 Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed.
 Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
 Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed.
 Lemma elements_3 : forall m, sort lt_key (elements m).
 Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed.
 Lemma elements_3w : forall m, NoDupA eq_key (elements m).
 Proof. intros m; exact (@Raw.elements_3w elt m.(this) 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; exact (@Raw.fold_1 elt m.(this)). Qed.

 Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
 Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.
 Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
 Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed.

 End Elt.

 Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
 Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed.
 Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
        In x (map f m) -> In x m.
 Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed.

 Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
 Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed.
 Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.
 Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed.

 Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
	In x m \/ In x m' ->
        find x (map2 f m m') = f (find x m) (find x m').
 Proof.
 intros elt elt' elt'' m m' x f;
 exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
 Qed.
 Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
        In x (map2 f m m') -> In x m \/ In x m'.
 Proof.
 intros elt elt' elt'' m m' x f;
 exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x).
 Qed.

End Make.

Module Make_ord (X: OrderedType)(D : OrderedType) <:
Sord with Module Data := D
        with Module MapS.E := X.

Module Data := D.
Module MapS := Make(X).
Import MapS.

Module MD := OrderedTypeFacts(D).
Import MD.

Definition t := MapS.t D.t.

Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.

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

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

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

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

Lemma eq_equal : forall m m', eq m m' <-> equal cmp 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 (X.compare x x'); simpl; intuition.
 unfold cmp at 1.
 MD.elim_comp; clear H; simpl.
 inversion_clear Hl.
 inversion_clear Hl'.
 destruct (IHl H (Build_slist H3)).
 unfold equal, eq in H5; simpl in H5; auto.
 destruct (andb_prop _ _ H); clear H.
 generalize H0; unfold cmp.
 MD.elim_comp; 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 cmp m m' -> eq m m'.
Proof.
 intros.
 generalize (@equal_1 D.t m m' cmp).
 generalize (@eq_equal m m').
 intuition.
Qed.

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

Lemma eq_refl : forall m : t, eq m m.
Proof.
 intros (m,Hm); induction m; unfold eq; simpl; auto.
 destruct a.
 destruct (X.compare t0 t0); auto.
 apply (MapS.Raw.MX.lt_antirefl l); auto.
 split.
 apply D.eq_refl.
 inversion_clear Hm.
 apply (IHm H).
 apply (MapS.Raw.MX.lt_antirefl l); auto.
Qed.

Lemma  eq_sym : forall m1 m2 : t, 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 (X.compare x x'); MapS.Raw.MX.elim_comp; intuition.
 inversion_clear Hm; inversion_clear Hm'.
 apply (IHm H0 (Build_slist H4)); auto.
Qed.

Lemma eq_trans : forall m1 m2 m3 : t, 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 (X.compare x x');
  destruct (X.compare x' x'');
   MapS.Raw.MX.elim_comp; intuition.
 apply D.eq_trans with e'; auto.
 inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
 apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
Qed.

Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
 intros (m3, Hm3); destruct m3; unfold lt; simpl;
 try destruct a as (x,e);
 try destruct p as (x',e');
 try destruct p0 as (x'',e''); try contradiction; auto.
 destruct (X.compare x x');
  destruct (X.compare x' x'');
   MapS.Raw.MX.elim_comp; intuition.
 left; apply D.lt_trans with e'; auto.
 left; apply lt_eq with e'; auto.
 left; apply eq_lt with e'; auto.
 right.
 split.
 apply D.eq_trans with e'; auto.
 inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
 apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition.
Qed.

Lemma lt_not_eq : forall m1 m2 : t, lt 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 (X.compare x x'); auto.
 intuition.
 exact (D.lt_not_eq H0 H1).
 inversion_clear Hm1; inversion_clear Hm2.
 apply (IHm1 H0 (Build_slist H5)); intuition.
Qed.

Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto.

Definition compare : forall m1 m2, Compare lt eq m1 m2.
Proof.
 intros (m1,Hm1); induction m1;
 intros (m2, Hm2); destruct m2;
  [ apply EQ | apply LT | apply GT | ]; cmp_solve.
 destruct a as (x,e); destruct p as (x',e').
 destruct (X.compare x x');
  [ apply LT | | apply GT ]; cmp_solve.
 destruct (D.compare e e');
  [ apply LT | | apply GT ]; cmp_solve.
 assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
  inversion_clear Hm1; auto.
 assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
  inversion_clear Hm2; auto.
 destruct (IHm1 Hm11 (Build_slist Hm22));
  [ apply LT | apply EQ | apply GT ]; cmp_solve.
Qed.

End Make_ord.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*            Benjamin Gregoire, Laurent Thery, INRIA, 2007             *)
(************************************************************************)

Require Export BigN.
Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake Ring Lia.
Import Zpow_def Zdiv.

(** * [BigZ] : arbitrary large efficient integers.

    The following [BigZ] module regroups both the operations and
    all the abstract properties:

    - [ZMake.Make BigN] provides the operations and basic specs w.r.t. ZArith
    - [ZTypeIsZAxioms] shows (mainly) that these operations implement
      the interface [ZAxioms]
    - [ZProp] adds all generic properties derived from [ZAxioms]
    - [MinMax*Properties] provides properties of [min] and [max]

*)

Delimit Scope bigZ_scope with bigZ.

Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder :=
 ZMake.Make BigN
 <+ ZTypeIsZAxioms
 <+ ZBasicProp [no inline] <+ ZExtraProp [no inline]
 <+ HasEqBool2Dec [no inline]
 <+ MinMaxLogicalProperties [no inline]
 <+ MinMaxDecProperties [no inline].

(** For precision concerning the above scope handling, see comment in BigN *)

(** Notations about [BigZ] *)

Local Open Scope bigZ_scope.

Notation bigZ := BigZ.t.
Bind Scope bigZ_scope with bigZ.
Bind Scope bigZ_scope with BigZ.t.
Bind Scope bigZ_scope with BigZ.t_.
Arguments BigZ.Pos _%bigN.
Arguments BigZ.Neg _%bigN.
Local Notation "0" := BigZ.zero : bigZ_scope.
Local Notation "1" := BigZ.one : bigZ_scope.
Local Notation "2" := BigZ.two : bigZ_scope.
Infix "+" := BigZ.add : bigZ_scope.
Infix "-" := BigZ.sub : bigZ_scope.
Notation "- x" := (BigZ.opp x) : bigZ_scope.
Infix "*" := BigZ.mul : bigZ_scope.
Infix "/" := BigZ.div : bigZ_scope.
Infix "^" := BigZ.pow : bigZ_scope.
Infix "?=" := BigZ.compare : bigZ_scope.
Infix "=?" := BigZ.eqb (at level 70, no associativity) : bigZ_scope.
Infix "<=?" := BigZ.leb (at level 70, no associativity) : bigZ_scope.
Infix "<?" := BigZ.ltb (at level 70, no associativity) : bigZ_scope.
Infix "==" := BigZ.eq (at level 70, no associativity) : bigZ_scope.
Notation "x != y" := (~x==y) (at level 70, no associativity) : bigZ_scope.
Infix "<" := BigZ.lt : bigZ_scope.
Infix "<=" := BigZ.le : bigZ_scope.
Notation "x > y" := (y < x) (only parsing) : bigZ_scope.
Notation "x >= y" := (y <= x) (only parsing) : bigZ_scope.
Notation "x < y < z" := (x<y /\ y<z) : bigZ_scope.
Notation "x < y <= z" := (x<y /\ y<=z) : bigZ_scope.
Notation "x <= y < z" := (x<=y /\ y<z) : bigZ_scope.
Notation "x <= y <= z" := (x<=y /\ y<=z) : bigZ_scope.
Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigZ_scope.
Infix "÷" := BigZ.quot (at level 40, left associativity) : bigZ_scope.

(** Some additional results about [BigZ] *)

Theorem spec_to_Z: forall n : bigZ,
  BigN.to_Z (BigZ.to_N n) = (Z.sgn (BigZ.to_Z n) * BigZ.to_Z n)%Z.
Proof.
intros n; case n; simpl; intros p;
  generalize (BigN.spec_pos p); case (BigN.to_Z p); auto.
intros p1 H1; case H1; auto.
intros p1 H1; case H1; auto.
Qed.

Theorem spec_to_N n:
 (BigZ.to_Z n = Z.sgn (BigZ.to_Z n) * (BigN.to_Z (BigZ.to_N n)))%Z.
Proof.
case n; simpl; intros p;
  generalize (BigN.spec_pos p); case (BigN.to_Z p); auto.
intros p1 H1; case H1; auto.
intros p1 H1; case H1; auto.
Qed.

Theorem spec_to_Z_pos: forall n, (0 <= BigZ.to_Z n)%Z ->
  BigN.to_Z (BigZ.to_N n) = BigZ.to_Z n.
Proof.
intros n; case n; simpl; intros p;
  generalize (BigN.spec_pos p); case (BigN.to_Z p); auto.
intros p1 _ H1; case H1; auto.
intros p1 H1; case H1; auto.
Qed.

(** [BigZ] is a ring *)

Lemma BigZring :
 ring_theory 0 1 BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq.
Proof.
constructor.
exact BigZ.add_0_l. exact BigZ.add_comm. exact BigZ.add_assoc.
exact BigZ.mul_1_l. exact BigZ.mul_comm. exact BigZ.mul_assoc.
exact BigZ.mul_add_distr_r.
symmetry. apply BigZ.add_opp_r.
exact BigZ.add_opp_diag_r.
Qed.

Lemma BigZeqb_correct : forall x y, (x =? y) = true -> x==y.
Proof. now apply BigZ.eqb_eq. Qed.

Definition BigZ_of_N n := BigZ.of_Z (Z.of_N n).

Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq BigZ_of_N BigZ.pow.
Proof.
constructor.
intros. unfold BigZ.eq, BigZ_of_N. rewrite BigZ.spec_pow, BigZ.spec_of_Z.
rewrite Zpower_theory.(rpow_pow_N).
destruct n; simpl. reflexivity.
induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto.
Qed.

Lemma BigZdiv : div_theory BigZ.eq BigZ.add BigZ.mul (@id _)
 (fun a b => if b =? 0 then (0,a) else BigZ.div_eucl a b).
Proof.
constructor. unfold id. intros a b.
BigZ.zify.
case Z.eqb_spec.
BigZ.zify. auto with zarith.
intros NEQ.
generalize (BigZ.spec_div_eucl a b).
generalize (Z_div_mod_full (BigZ.to_Z a) (BigZ.to_Z b) NEQ).
destruct BigZ.div_eucl as (q,r), Z.div_eucl as (q',r').
intros (EQ,_). injection 1 as EQr EQq.
BigZ.zify. rewrite EQr, EQq; auto.
Qed.

(** Detection of constants *)

Ltac isBigZcst t :=
 match t with
 | BigZ.Pos ?t => isBigNcst t
 | BigZ.Neg ?t => isBigNcst t
 | BigZ.zero => constr:(true)
 | BigZ.one => constr:(true)
 | BigZ.two => constr:(true)
 | BigZ.minus_one => constr:(true)
 | _ => constr:(false)
 end.

Ltac BigZcst t :=
 match isBigZcst t with
 | true => constr:(t)
 | false => constr:(NotConstant)
 end.

Ltac BigZ_to_N t :=
 match t with
 | BigZ.Pos ?t => BigN_to_N t
 | BigZ.zero => constr:(0%N)
 | BigZ.one => constr:(1%N)
 | BigZ.two => constr:(2%N)
 | _ => constr:(NotConstant)
 end.

(** Registration for the "ring" tactic *)

Add Ring BigZr : BigZring
 (decidable BigZeqb_correct,
  constants [BigZcst],
  power_tac BigZpower [BigZ_to_N],
  div BigZdiv).

Section TestRing.
Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + (y + 1*x)*x.
Proof.
intros. ring_simplify. reflexivity.
Qed.
Let test' : forall x y, 1 + x*y + x^2 - 1*1 - y*x + 1*(-x)*x == 0.
Proof.
intros. ring_simplify. reflexivity.
Qed.
End TestRing.

(** [BigZ] also benefits from an "order" tactic *)

Ltac bigZ_order := BigZ.order.

Section TestOrder.
Let test : forall x y : bigZ, x<=y -> y<=x -> x==y.
Proof. bigZ_order. Qed.
End TestOrder.

(** We can use at least a bit of lia by translating to [Z]. *)

Section TestLia.
Let test : forall x y : bigZ, x<=y -> y<=x -> x==y.
Proof. intros x y. BigZ.zify. Lia.lia. Qed.
End TestLia.


From Coq Require Import
     FunctionalExtensionality
     Setoid
     ssreflect
.

From ExtensibleCompiler.Theory Require Import
     Algebra
     Functor
     SubFunctor
.

Local Open Scope SubFunctor.

(**

The universal property of folds is as follows:

  [h = fold alg   <->   h . wrapF = alg h]

In an initial algebra setting, there is a unique implementation of [fold], so
the property can be checked once and for all.  In a Church encoding setting,
each term carries its fold, and with it, it should carry a proof.  Fortunately,
the direct direction follows from the overloaded definition of [fold] and
[wrapF], independent of the choice of term of [Fix F].

*)

(**
[h = fold alg -> h . wrapF = alg h]

Holds by definition of [mendlerFold] and [wrapF].
 *)
Lemma MendlerFoldUP (* cf. [Universal_Property] *)
      F A
      (alg : MendlerAlgebra F A) (h : Fix F -> A)
  : h = mendlerFold alg ->
    forall e,
      h (wrapF e) = alg (Fix F) h e.
Proof.
  move => -> //.
Qed.

(**
[h . wrapF = alg h -> h = fold alg]

To be proven for each value of type [Fix F].
 *)
Class MendlerFoldUP' (* cf. [Universal_Property'] *)
      {F}
      (e : Fix F)
  :=
    {
      mendlerFoldUP' : (* cf.  *)
        forall A (f : MendlerAlgebra F A) (h : Fix F -> A),
          (forall e', h (wrapF e') = f _ h e'
          ) ->
          h e = mendlerFold f e;
    }.

(**
[h = fold alg -> h . wrapF = alg h]

Holds by definition of [fold] and [wrapF].
 *)
Lemma FoldUP
      F `{Functor F}
      A (alg : Algebra F A) (h : Fix F -> A)
  : h = fold alg ->
    forall e,
      h (wrapF e) = alg (fmap h e).
Proof.
  move => -> //.
Qed.

(**
[h . wrapF = alg h -> h = fold alg]

To be proven for each value of type [Fix F].
 *)
Class FoldUP' (* cf. [Universal_Property'_fold] *)
      {F} `{Functor F} (e : Fix F)
  :=
    {
      foldUP' : (* cf. [E_fUP'] *)
        forall A (alg : Algebra F A) (h : Fix F -> A),
          (forall e, h (wrapF e) = alg (fmap h e)) ->
          h e = fold alg e;
    }.

Lemma fold_wrapF_Identity
      {F} `{Functor F}
      (e : Fix F)
      {UP'__e : FoldUP' e}
  : fold wrapF e = e.
Proof.
  apply : sym_eq.
  apply : foldUP' => e'.
  rewrite fmapId //.
Qed.

(**
A [WellFormedValue] for a functor [V] is a value of type [Fix V] s.t. it has
been properly constructed, and as such, satisfies [FoldUP'].
 *)
Definition WellFormedValue (* cf. [UP'_F] *)
           V `{Functor V}
  := { e : Fix V | FoldUP' e }.

Definition wrapUP' (* cf. [in_t_UP'] *)
           {F} `{Functor F}
           (v : F (WellFormedValue F))
  : WellFormedValue F.
  apply (exist _ (wrapF (fmap (F := F) (@proj1_sig _ _) v))).
  constructor => A alg rec EQ.
  rewrite EQ.
  rewrite /fold /mendlerFold /wrapF.
  rewrite !fmapFusion.
  f_equal.
  f_equal.
  rewrite /compose.
  apply functional_extensionality.
  move => [e' E'] /=.
  apply foldUP' => //.
Defined.

Definition unwrapUP' (* cf. [out_t_UP'] *)
           {F} `{Functor F}
           (v : Fix F)
  : F (WellFormedValue F)
  := fold (fmap wrapUP') v.

Lemma unwrapUP'_wrapF
      {E} `{Functor E}
  : forall (e : E (Fix E)),
    unwrapUP' (wrapF e)
    =
    fmap (fun e => wrapUP' (unwrapUP' e)) e.
Proof.
  move => e.
  rewrite {1} / unwrapUP'.
  setoid_rewrite FoldUP => //.
  rewrite fmapFusion //.
Qed.

Lemma fmap_unwrapUP'
      {E} `{Functor E}
  : forall (e : Fix E),
    FoldUP' e ->
    fmap (@proj1_sig _ _) (unwrapUP' e) = unwrapF e.
Proof.
  move => e UP__e.
  rewrite / unwrapF.
  apply (foldUP' _ _ (fun e => fmap (@proj1_sig _ _) (unwrapUP' e))).
  move => e'.
  rewrite fmapFusion / compose.
  rewrite unwrapUP'_wrapF.
  rewrite fmapFusion //.
Qed.

Lemma fmap_wrapF
      {E} `{Functor E}
  :
    (fun (R : Set) (rec : R -> E (Fix E)) (e : E R) => fmap wrapF (fmap rec e))
    =
    (fun (R : Set) (rec : R -> E (Fix E)) (e : E R) => fmap (fun r => wrapF (rec r)) e).
Proof.
  eapply functional_extensionality_dep => R.
  eapply functional_extensionality_dep => rec.
  eapply functional_extensionality_dep => e.
  rewrite fmapFusion //.
Qed.

Lemma unwrapF_wrapF
   {E} `{Functor E}
  : forall (e : E (Fix E)),
    unwrapF (wrapF e) = fmap (fun e => wrapF (unwrapF e)) e.
Proof.
  move => e.
  rewrite / unwrapF /=.
  erewrite (MendlerFoldUP _ _ (fun R rec fp => fmap (fun r => wrapF (rec r)) fp)) => //.
  rewrite / fold / mendlerFold.
  eapply functional_extensionality.
  move => e'.
  rewrite fmap_wrapF //.
Qed.

Lemma wrapF_unwrapF
      {E} `{Functor E}
  : forall (e : Fix E),
    FoldUP' e ->
    wrapF (unwrapF e) = e.
Proof.
  move => e UP__e.
  rewrite <- fold_wrapF_Identity => //.
  apply (foldUP' _ _ (fun e => wrapF (unwrapF e))).
  move => e'.
  rewrite unwrapF_wrapF //.
Qed.

Lemma wrapF_fold_fmap_wrapF
   {E} `{Functor E}
  : (fun e : sig FoldUP' =>
         wrapF (fold (fmap wrapF) (proj1_sig e))) =
    @proj1_sig _ _.
Proof.
  apply : functional_extensionality.
  move => x.
  setoid_rewrite wrapF_unwrapF => //.
  move : x => [] //.
Qed.

Lemma unwrapF_wrapF_fmap
   {E} `{Functor E}
  : forall (e : E (sig (FoldUP' (F := E)))),
    unwrapF (wrapF (fmap (@proj1_sig _ _) e)) = fmap (@proj1_sig _ _) e.
Proof.
  move => e.
  rewrite / unwrapF.
  erewrite FoldUP => //.
  rewrite fmapFusion.
  rewrite fmapFusion.
  setoid_rewrite wrapF_fold_fmap_wrapF => //.
Qed.

Theorem wrapUP'_unwrapUP' (* cf. [in_out_UP'_inverse] *)
        {E} `{Functor E}
  : forall (e : Fix E),
    FoldUP' e ->
    proj1_sig (wrapUP' (unwrapUP' e)) = e.
Proof.
  move => e UP__e /=.
  rewrite fmap_unwrapUP'.
  rewrite wrapF_unwrapF //.
Qed.

(**
Proof that [wrapF] is injective, as long as the subterms have the universal
property.
 *)
Lemma wrapF_inversion (* cf. [in_t_UP'_inject] *)
      {E} `{Functor E}
  : forall (e e' : E (sig FoldUP')),
      wrapF (fmap (@proj1_sig _ _) e) = wrapF (fmap (@proj1_sig _ _) e') ->
      fmap (@proj1_sig _ _) e = fmap (@proj1_sig _ _) e'.
Proof.
  move => e e' / (f_equal unwrapF).
  do 2 rewrite unwrapF_wrapF_fmap.
  rewrite //.
Qed.

Definition wrapF_inversion'
           {E} `{Functor E}
  := fun (a b : WellFormedValue E) EQ =>
  wrapF_inversion
    (E := E)
    (unwrapUP' (proj1_sig a))
    (unwrapUP' (proj1_sig b))
    EQ.

(**
This could be called [injectUP'], but we will use it a lot, so it gets to be
[inject].
 *)
Definition injectUP' (* cf. [inject'] *)
           {E F}
           `{Functor E} `{Functor F}
           `{SubFunctor F E}
           (fexp : F (WellFormedValue E))
  : WellFormedValue E
  := wrapUP' (inject fexp).

Definition injectF (* cf. [inject] *)
           {F G}
           `{SubFunctor F G}
           (fexp : F (WellFormedValue G))
  : Fix G
  := proj1_sig (injectUP' fexp).

Fixpoint boundedFixUP'
         {F A}
         `{Functor F}
         (n : nat)
         (fM : MixinAlgebra F (WellFormedValue F) A)
         (default : A)
         (e : WellFormedValue F)
  : A
  :=
  match n with
  | 0   => default
  | S n => fM (boundedFixUP' n fM default) (unwrapUP' (proj1_sig e))
  end.

Definition UniversalPropertyP (* cf. [UP'_P] *)
           {F} `{Functor F}
           (P : forall e : Fix F, FoldUP' e -> Prop)
           (e : Fix F)
  : Prop
  := sig (P e).

Definition UniversalPropertyP2 (* cf. [UP'_P2] *)
           {F G}
           `{Functor F} `{Functor G}
           (P : forall e : Fix F * Fix G, FoldUP' (fst e) /\ FoldUP' (snd e) -> Prop)
           (e : Fix F * Fix G)
  : Prop
  := sig (P e).

Definition projectUP'
           {E F}
           `{Functor E} `{Functor F}
           `{E supports F}
           (e : Fix E)
  : option (F (WellFormedValue E))
  := project (unwrapUP' e).

Definition projectF
           {E F}
           `{Functor E} `{Functor F}
           `{E supports F}
           (e : WellFormedValue E)
  : option (F (Fix E))
  := option_map
       (fmap (proj1_sig (A := Fix E) (P := _)))
       (projectUP' (proj1_sig e)).

Theorem project_successUP'
        {E F}
        `{Functor E} `{Functor F}
        `{E supports F}
        (e : Fix E)
        (f : F { e : Fix E | FoldUP' e })
  : FoldUP' e ->
    projectUP' e = Some f ->
    e = injectF f.
Proof.
  move => UP'__g /project_success.
  rewrite /injectF /injectUP' => <- .
  rewrite wrapUP'_unwrapUP' //.
Qed.


From Coq Require Import
     Classes.Morphisms
     Classes.RelationClasses
     Lists.List
     Relations.Relation_Operators
     Relations.Operators_Properties.

Module Type Config.
  Parameter t : Type.
End Config.

Module Permissions (C : Config).
  Definition config := C.t.

  (* A single permission *)
  Record perm : Type :=
    {
    rely : config -> config -> Prop; (* rely, the updates this permission allows of others *)
    rely_PO : PreOrder rely;
    pre : config -> Prop; (* precondition on configs *)
    pre_respects : forall x y, rely x y -> (pre x -> pre y);
    guar : config -> config -> Prop; (* guarantee, the updates that this permission allows *)
    guar_PO : PreOrder guar;
    }.

  Hint Unfold rely.
  Hint Unfold pre.
  Hint Unfold guar.
  Hint Resolve pre_respects.

  Instance rely_is_preorder p : PreOrder (rely p) := rely_PO p.
  Instance guar_is_preorder p : PreOrder (guar p) := guar_PO p.

  Record lte_perm (p q: perm) : Prop :=
    {
    pre_inc : forall x, pre q x -> pre p x;
    rely_inc : forall x y, rely q x y -> rely p x y;
    guar_inc : forall x y, guar p x y -> guar q x y;
    }.

  Hint Resolve pre_inc.
  Hint Resolve rely_inc.
  Hint Resolve guar_inc.

  Notation "p <= q" := (lte_perm p q).

  Instance lte_perm_is_PreOrder : PreOrder lte_perm.
  Proof.
    constructor; [ constructor; auto | constructor; intros ]; eauto.
  Qed.

  (* Equality of permissions = the symmetric closure of the ordering *)
  Definition eq_perm p q : Prop := p <= q /\ q <= p.

  Notation "p ≡ q" := (eq_perm p q) (at level 50).
  Lemma eq_perm_lte_1 : forall p q, p ≡ q -> p <= q.
  Proof. intros p q []. auto. Qed.
  Lemma eq_perm_lte_2 : forall p q, p ≡ q -> q <= p.
  Proof. intros p q []. auto. Qed.

  Hint Unfold eq_perm.
  Hint Resolve eq_perm_lte_1.
  Hint Resolve eq_perm_lte_2.

  Instance eq_perm_is_Equivalence : Equivalence eq_perm.
  Proof.
    constructor.
    - split; reflexivity.
    - intros x y []. split; auto.
    - intros x y z [] []. split; etransitivity; eauto.
  Qed.

  Instance Proper_eq_perm_lte_perm :
    Proper (eq_perm ==> eq_perm ==> Basics.flip Basics.impl) lte_perm.
  Proof.
    repeat intro. subst. etransitivity; eauto. etransitivity; eauto.
  Qed.

  Program Definition bottom_perm : perm :=
    {|
    pre := fun x => True;
    rely := fun x y => True;
    guar  := fun x y => x = y;
    |}.
  Next Obligation.
    constructor; repeat intro; subst; auto.
  Qed.

  Lemma bottom_perm_is_bottom : forall p, bottom_perm <= p.
  Proof.
    constructor; simpl; intros; subst; intuition.
  Qed.

  Program Definition top_perm : perm :=
    {|
    pre := fun x => False;
    rely := fun x y => x = y;
    guar  := fun x y => True;
    |}.
  Next Obligation.
    constructor; repeat intro; subst; auto.
  Qed.

  Lemma top_perm_is_top : forall p, p <= top_perm.
  Proof.
    constructor; simpl; repeat intro; subst; intuition.
  Qed.

  Ltac respects := eapply pre_respects; eauto.

  Program Definition join_perm (p q: perm) : perm :=
    {|
    pre := fun x => pre p x /\ pre q x;
    rely := fun x y => rely p x y /\ rely q x y;
    guar  := clos_trans _ (fun x y => (guar p x y) \/ (guar q x y))
    |}.
  Next Obligation.
    constructor; repeat intro.
    - split; reflexivity.
    - destruct H. destruct H0. split; etransitivity; eauto.
  Qed.
  Next Obligation.
    split; respects.
  Qed.
  Next Obligation.
    constructor.
    - constructor; left; reflexivity.
    - repeat intro. destruct H, H0.
      + destruct H, H0; econstructor 2; constructor; eauto.
      + econstructor 2. left. apply H. econstructor 2; eauto.
      + econstructor 2; eauto. econstructor 2; eauto. left. assumption.
      + repeat (econstructor 2; eauto).
  Qed.

  Lemma lte_l_join_perm : forall p q,
      p <= join_perm p q.
  Proof.
    intros. constructor; simpl; auto.
    - intros ? [? _]. auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma lte_r_join_perm : forall p q,
      q <= join_perm p q.
  Proof.
    intros. constructor; simpl; auto.
    - intros ? [_ ?]. auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma join_perm_min : forall p q r,
      p <= r ->
      q <= r ->
      join_perm p q <= r.
  Proof.
    intros p q r [] []. constructor; intros; simpl; auto.
    - induction H; auto.
      + destruct H; auto.
      + transitivity y; auto.
  Qed.

  Lemma join_perm_commut' : forall p q,
      join_perm p q <= join_perm q p.
  Proof.
    constructor.
    - intros ? []. split; auto.
    - intros x y []. repeat split; auto.
    - intros. induction H.
      + destruct H; constructor; auto.
      + etransitivity; eauto.
  Qed.

  Lemma join_perm_commut : forall p q,
      join_perm p q ≡ join_perm q p.
  Proof.
    split; apply join_perm_commut'.
  Qed.

  Lemma join_perm_assoc : forall p q r,
      join_perm p (join_perm q r) ≡ join_perm (join_perm p q) r.
  Proof.
    split; intros.
    {
      constructor.
      - intros x [[? ?] ?]. split; [| split]; auto.
      - intros x y [[] ?].
        repeat split; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + constructor. left. constructor. left. auto.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. constructor. right. auto.
          * constructor. right. auto.
    }
    {
      constructor.
      - intros x [? [? ?]]. split; [split |]; auto.
      - intros x y [? []].
        repeat split; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. auto.
          * constructor. right. constructor. left. auto.
        + constructor. right. constructor. right. auto.
    }
  Qed.

  Lemma join_perm_idem : forall p, join_perm p p ≡ p.
  Proof.
    split; intros.
    - constructor; intros.
      + split; auto.
      + repeat split; auto.
      + induction H; try solve [etransitivity; eauto].
        destruct H; auto.
    - constructor.
      + intros ? [? _]; auto.
      + intros x y []. auto.
      + constructor. auto.
  Qed.

  Definition meet_rely p q := clos_trans _ (fun x y => (rely p x y) \/ (rely q x y)).

  Program Definition meet_perm (p q:perm) : perm :=
    {|
    pre := fun x => pre p x \/ pre q x \/ exists y, (pre p y \/ pre q y) /\ meet_rely p q y x;
    rely := meet_rely p q;
    guar  := fun x y => guar p x y /\ guar q x y;
    |}.
  Next Obligation.
    constructor; repeat intro.
    - constructor. left. reflexivity.
    - econstructor 2; eauto.
  Qed.
  Next Obligation.
    induction H; auto.
    destruct H0 as [? | [? | [z [? ?]]]].
    - destruct H; try solve [left; respects].
      right; right. exists x. split; auto. constructor 1. auto.
    - destruct H; try solve [right; left; respects].
      right; right. exists x. split; auto. constructor 1. auto.
    - destruct H; right; right; exists z; split; auto;
        econstructor 2; eauto; constructor 1; auto.
  Qed.
  Next Obligation.
    constructor.
    - constructor; reflexivity.
    - intros x y z [] []. split; etransitivity; eauto.
  Qed.

  Lemma lte_meet_perm_l : forall p q,
      meet_perm p q <= p.
  Proof.
    intros. constructor; simpl; auto.
    - left; auto.
    - intros x y []; auto.
  Qed.
  Lemma lte_meet_perm_r : forall p q,
      meet_perm p q <= q.
  Proof.
    intros. constructor; simpl; auto.
    - left; auto.
    - intros x y []; auto.
  Qed.
  Lemma meet_perm_max : forall p q r,
      r <= p ->
      r <= q ->
      r <= meet_perm p q.
  Proof.
    intros p q r [] []. constructor; intros; simpl; auto.
    - simpl in H. destruct H as [? | [? | [? [? ?]]]]; auto.
      induction H0.
      + destruct H, H0; respects.
      + apply IHclos_trans1 in H.
        clear IHclos_trans1 IHclos_trans2 H0_.
        induction H0_0; auto.
        destruct H0; respects.
    - induction H.
      + destruct H; auto.
      + etransitivity; eauto.
  Qed.

  (*
Lemma meet_perm_commut: forall p q, meet_perm p q ≡ meet_perm q p.
Proof.
  split; intros.
  - constructor; intros.
    + destruct H as [? [? ?]].
    + induction H.
      * destruct H; constructor; auto.
      * etransitivity; eauto.
    + destruct H. constructor; auto.
  - constructor; intros.
    + induction H.
      * destruct H; constructor; auto.
      * etransitivity; eauto.
    + destruct H. constructor; auto.
Qed.

Lemma meet_perm_assoc : forall p q r,
    eq_perm (meet_perm p (meet_perm q r)) (meet_perm (meet_perm p q) r).
Proof.
  split; intros.
  - constructor; intros.
    + induction H; try solve [etransitivity; eauto].
      destruct H.
      * induction H; try solve [etransitivity; eauto].
        destruct H.
        -- constructor. left. auto.
        -- constructor. right. constructor. left. auto.
      * constructor. right. constructor. right. auto.
    + destruct H as [? [? ?]].
      constructor; auto. constructor; auto.
  - constructor; intros.
    + induction H; try solve [etransitivity; eauto].
      destruct H.
      * constructor. left. constructor. left. auto.
      * induction H; try solve [etransitivity; eauto].
        destruct H.
        -- constructor. left. constructor. right. auto.
        -- constructor. right. auto.
    + destruct H as [[? ?] ?].
      constructor; auto. constructor; auto.
Qed.

Lemma meet_perm_idem : forall p, eq_perm (meet_perm p p) p.
Proof.
  split; intros.
  - constructor; intros.
    + constructor. left. auto.
    + destruct H; auto.
  - constructor; intros.
    + induction H; try solve [etransitivity; eauto].
      destruct H; auto.
    + constructor; auto.
Qed.

Lemma join_perm_absorb : forall p q, eq_perm (join_perm p (meet_perm p q)) p.
Proof.
  split; intros.
  - constructor; intros.
    + constructor; auto. constructor; auto.
    + induction H; try solve [etransitivity; eauto].
      destruct H; auto. destruct H; auto.
  - constructor; intros.
    + destruct H. auto.
    + constructor. left. auto.
Qed.

Lemma meet_perm_absorb : forall p q, eq_perm (meet_perm p (join_perm p q)) p.
Proof.
  split; intros.
  - constructor; intros.
    + constructor. left. auto.
    + destruct H. auto.
  - constructor; intros.
    + induction H; try solve [etransitivity; eauto].
      destruct H; auto. destruct H; auto.
    + constructor; auto. constructor; auto.
Qed. *)

  Record separate (p q : perm) : Prop :=
    {
    sep_l: forall x y, guar q x y -> rely p x y;
    sep_r: forall x y, guar p x y -> rely q x y;
    }.

  Notation "p ⊥ q" := (separate p q) (at level 50).

  Instance separate_symmetric: Symmetric separate.
  Proof.
    intros p q []. constructor; auto.
  Qed.

  Lemma separate_bottom : forall p, p ⊥ bottom_perm.
  Proof.
    constructor; intros; simpl; auto.
    inversion H. reflexivity.
  Qed.

  Program Definition sym_guar_perm (p : perm) : perm :=
    {|
    pre x := False;
    rely := guar p;
    guar := rely p;
    |}.
  Lemma separate_self_sym : forall p, p ⊥ sym_guar_perm p.
  Proof.
    intros. split; intros; auto.
  Qed.

  Definition copyable p := forall x y, guar p x y -> rely p x y.

  Lemma copyable_separate : forall p, copyable p -> p ⊥ p.
  Proof.
    intros. red in H. split; auto.
  Qed.

  Lemma separate_antimonotone : forall p q r, p ⊥ q -> r <= q -> p ⊥ r.
  Proof.
    intros. constructor.
    - intros. apply H. apply H0. auto.
    - intros. apply H0. apply H. auto.
  Qed.

  Program Definition sep_conj_perm (p q: perm) : perm :=
    {|
    pre := fun x => pre p x /\ pre q x /\ separate p q;
    rely := fun x y => rely p x y /\ rely q x y;
    guar  := clos_trans _ (fun x y => (guar p x y) \/ (guar q x y))
    |}.
  Next Obligation.
    constructor; repeat intro.
    - split; reflexivity.
    (* - destruct H; split; symmetry; auto. *)
    - destruct H, H0.
      split; etransitivity; eauto.
  Qed.
  Next Obligation.
    split; [respects | split; [respects | auto]].
  Qed.
  Next Obligation.
    constructor.
    - constructor; intuition.
    - repeat intro. destruct H, H0.
      + destruct H, H0; econstructor 2; constructor; eauto.
      + econstructor 2. left. apply H. econstructor 2; eauto.
      + econstructor 2; eauto. econstructor 2; eauto. left. assumption.
      + repeat (econstructor 2; eauto).
  Qed.
  Notation "p * q" := (sep_conj_perm p q).

  Lemma sep_conj_join : forall p q, p ⊥ q -> p * q ≡ join_perm p q.
  Proof.
    split; intros.
    - constructor; auto; intros x []; split; auto.
    - constructor; auto; intros x [? [? ?]]; split; auto.
  Qed.

  Lemma lte_l_sep_conj_perm : forall p q, p <= p * q.
  Proof.
    intros. constructor; simpl; auto.
    - intros x []; auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma lte_r_sep_conj_perm : forall p q, q <= p * q.
  Proof.
    intros. constructor; simpl; auto.
    - intros x [? [? ?]]; auto.
    - intros x y []; auto.
    - constructor; auto.
  Qed.

  Lemma sep_conj_perm_monotone : forall p p' q q',
      p' <= p -> q' <= q -> p' * q' <= p * q.
  Proof.
    constructor; intros; simpl.
    - destruct H1 as [? [? ?]]; split; [| split]; eauto.
      eapply separate_antimonotone; eauto.
      symmetry. symmetry in H3. eapply separate_antimonotone; eauto.
    - split.
      + apply H. apply H1.
      + apply H0. apply H1.
    - induction H1.
      + constructor. destruct H1; eauto.
      + econstructor 2; eauto.
  Qed.

  Instance Proper_eq_perm_sep_conj_perm :
    Proper (eq_perm ==> eq_perm ==> eq_perm) sep_conj_perm.
  Proof.
    repeat intro. split; apply sep_conj_perm_monotone; auto.
  Qed.

  Lemma sep_conj_perm_bottom' : forall p, p * bottom_perm <= p.
  Proof.
    constructor; intros.
    - split; [| split]; simpl; intuition. apply separate_bottom.
    - repeat split; auto.
    - induction H.
      + destruct H; auto. inversion H. reflexivity.
      + etransitivity; eauto.
  Qed.

  Lemma sep_conj_perm_bottom : forall p, p * bottom_perm ≡ p.
  Proof.
    split; [apply sep_conj_perm_bottom' | apply lte_l_sep_conj_perm].
  Qed.

  Lemma sep_conj_perm_top' : forall p, p * top_perm <= top_perm.
  Proof.
    constructor; intros; simpl in *; intuition.
    subst. reflexivity.
  Qed.

  Lemma sep_conj_perm_top : forall p, top_perm ≡ p * top_perm.
  Proof.
    split; [apply lte_r_sep_conj_perm | apply sep_conj_perm_top'].
  Qed.

  Lemma sep_conj_perm_commut' : forall p q, p * q <= q * p.
  Proof.
    constructor.
    - intros x [? [? ?]]; simpl; split; [| split]; intuition.
    - intros x y []; repeat split; auto.
    - intros. induction H.
      + destruct H; constructor; auto.
      + etransitivity; eauto.
  Qed.

  Lemma sep_conj_perm_commut : forall p q, p * q ≡ q * p.
  Proof.
    split; apply sep_conj_perm_commut'.
  Qed.

  Lemma separate_sep_conj_perm_l: forall p q r, p ⊥ q * r -> p ⊥ q.
  Proof.
    intros. destruct H. constructor; intros.
    - apply sep_l0. constructor. left. auto.
    - apply sep_r0. auto.
  Qed.
  Lemma separate_sep_conj_perm_r: forall p q r, p ⊥ q * r -> p ⊥ r.
  Proof.
    intros. destruct H. constructor; intros.
    - apply sep_l0. constructor. right. auto.
    - apply sep_r0. auto.
  Qed.
  Lemma separate_sep_conj_perm: forall p q r, p ⊥ q ->
                                         p ⊥ r ->
                                         r ⊥ q ->
                                         p ⊥ q * r.
  Proof.
    intros. constructor; intros.
    - induction H2.
      + destruct H2; [apply H | apply H0]; auto.
      + etransitivity; eauto.
    - split; [apply H | apply H0]; auto.
  Qed.

  Lemma sep_conj_perm_assoc : forall p q r,
      p * q * r ≡ p * (q * r).
  Proof.
    split; intros.
    {
      constructor.
      - intros x [? [[? [? ?]] ?]].
        pose proof (separate_sep_conj_perm_l _ _ _ H3).
        pose proof (separate_sep_conj_perm_r _ _ _ H3).
        split; [split; [| split] | split]; auto.
        symmetry. apply separate_sep_conj_perm; symmetry; auto.
      - intros x y [? [? ?]]. split; [split |]; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. auto.
          * constructor. right. constructor. left. auto.
        + constructor. right. constructor. right. auto.
    }
    {
      constructor.
      - intros x [[? [? ?]] [? ?]]. symmetry in H3.
        pose proof (separate_sep_conj_perm_l _ _ _ H3). symmetry in H4.
        pose proof (separate_sep_conj_perm_r _ _ _ H3). symmetry in H5.
        split; [| split; [split; [| split] |]]; auto.
        apply separate_sep_conj_perm; auto. symmetry; auto.
      - intros x y [[? ?] ?]; simpl; auto.
      - intros. induction H; try solve [etransitivity; eauto].
        destruct H.
        + constructor. left. constructor. left. auto.
        + induction H; try solve [etransitivity; eauto].
          destruct H.
          * constructor. left. constructor. right. auto.
          * constructor. right. auto.
    }
  Qed.

  (* Perms = upwards-closed sets of permissions *)
  Record Perms :=
    {
    in_Perms : perm -> Prop;
    Perms_upwards_closed : forall p1 p2, in_Perms p1 -> p1 <= p2 -> in_Perms p2
    }.
  Notation "p ∈ P" := (in_Perms P p) (at level 60).

  (* superset *)
  Definition lte_Perms (P Q : Perms) : Prop :=
    forall p, p ∈ Q -> p ∈ P.
  Notation "P ⊑ Q" := (lte_Perms P Q) (at level 60).

  Instance lte_Perms_is_preorder : PreOrder lte_Perms.
  Proof.
    constructor; repeat intro; auto.
  Qed.

  Program Definition top_Perms : Perms :=
    {|
    in_Perms := fun r => False
    |}.

  Lemma top_Perms_is_top : forall P, P ⊑ top_Perms.
  Proof.
    repeat intro. inversion H.
  Qed.

  Program Definition bottom_Perms : Perms :=
    {|
    in_Perms := fun r => True
    |}.

  Lemma bottom_Perms_is_bottom : forall P, bottom_Perms ⊑ P.
  Proof.
    repeat intro. simpl. auto.
  Qed.

  (* The least Perms set containing a given p *)
  Program Definition singleton_Perms p1 : Perms :=
    {|
    in_Perms := fun p2 => p1 <= p2
    |}.
  Next Obligation.
    etransitivity; eassumption.
  Qed.

  Program Definition join_Perms (Ps : Perms -> Prop) : Perms :=
    {|
    in_Perms := fun p => forall P, Ps P -> p ∈ P
    |}.
  Next Obligation.
    eapply Perms_upwards_closed; eauto.
  Qed.
  Lemma lte_join_Perms : forall (Ps : Perms -> Prop) P,
      Ps P ->
      P ⊑ join_Perms Ps.
  Proof.
    repeat intro. apply H0. auto.
  Qed.
  Lemma join_Perms_min : forall (Ps : Perms -> Prop) Q,
      (forall P, Ps P -> P ⊑ Q) ->
      join_Perms Ps ⊑ Q.
  Proof.
    repeat intro.
    eapply H; eauto.
  Qed.

  (* Complete meet of Perms sets = union *)
  Program Definition meet_Perms (Ps : Perms -> Prop) : Perms :=
    {|
    in_Perms := fun p => exists P, Ps P /\ p ∈ P
    |}.
  Next Obligation.
    exists H. split; auto.
    apply (Perms_upwards_closed _ p1); assumption.
  Qed.

  Lemma lte_meet_Perms : forall (Ps : Perms -> Prop) P,
      Ps P ->
      meet_Perms Ps ⊑ P.
  Proof.
    repeat intro. exists P. auto.
  Qed.

  Lemma meet_Perms_max : forall (Ps : Perms -> Prop) Q,
      (forall P, Ps P -> Q ⊑ P) ->
      Q ⊑ meet_Perms Ps.
  Proof.
    repeat intro. destruct H0 as [? [? ?]].
    eapply H; eauto.
  Qed.

  Definition meet_Perms2 P Q : Perms := meet_Perms (fun R => R = P \/ R = Q).

  (* Set equality *)
  Definition eq_Perms (P Q : Perms) : Prop := P ⊑ Q /\ Q ⊑ P.
  Notation "P ≡≡ Q" := (eq_Perms P Q) (at level 60).

  Instance Equivalence_eq_Perms : Equivalence eq_Perms.
  Proof.
    constructor; repeat intro.
    - split; reflexivity.
    - destruct H; split; auto.
    - destruct H, H0. split; etransitivity; eauto.
  Qed.

  Instance Proper_eq_Perms_lte_Perms :
    Proper (eq_Perms ==> eq_Perms ==> Basics.flip Basics.impl) lte_Perms.
  Proof.
    do 5 red. intros. etransitivity. apply H. etransitivity. apply H1. apply H0.
  Qed.

  Instance Proper_eq_Perms_eq_perm_in_Perms : Proper (eq_Perms ==> eq_perm ==> Basics.flip Basics.impl) in_Perms.
  Proof.
    repeat intro; subst. apply H. eapply Perms_upwards_closed; eauto.
  Qed.

  Program Definition sep_conj_Perms (P Q : Perms) : Perms :=
    {|
    in_Perms := fun r => exists p q, p ∈ P /\ q ∈ Q /\ p * q <= r
    |}.
  Next Obligation.
    exists H, H1. split; [| split]; auto. etransitivity; eauto.
  Qed.
  Notation "P ** Q" := (sep_conj_Perms P Q) (at level 51, right associativity).

  Lemma lte_l_sep_conj_Perms : forall P Q, P ⊑ P ** Q.
  Proof.
    intros P Q p' ?. destruct H as [p [q [? [? ?]]]].
    eapply Perms_upwards_closed; eauto.
    etransitivity; eauto. apply lte_l_sep_conj_perm.
  Qed.

  Lemma lte_r_sep_conj_Perms : forall P Q, Q ⊑ P ** Q.
  Proof.
    intros P Q q' ?. destruct H as [p [q [? [? ?]]]].
    eapply Perms_upwards_closed; eauto.
    etransitivity; eauto. apply lte_r_sep_conj_perm.
  Qed.

  Lemma sep_conj_Perms_bottom_identity : forall P, bottom_Perms ** P ≡≡ P.
  Proof.
    constructor; repeat intro.
    - exists bottom_perm, p. split; simpl; [auto | split; auto].
      rewrite sep_conj_perm_commut. apply sep_conj_perm_bottom.
    - destruct H as [? [? [_ [? ?]]]].
      eapply (Perms_upwards_closed P); eauto.
      etransitivity; eauto. apply lte_r_sep_conj_perm.
  Qed.

  Lemma sep_conj_Perms_top_absorb : forall P, top_Perms ** P ≡≡ top_Perms.
  Proof.
    constructor; repeat intro.
    - inversion H.
    - destruct H as [? [_ [[] _]]].
  Qed.

  Lemma sep_conj_Perms_monotone : forall P P' Q Q', P' ⊑ P -> Q' ⊑ Q -> P' ** Q' ⊑ P ** Q.
  Proof.
    repeat intro. destruct H1 as [? [? [? [? ?]]]].
    exists x, x0. auto.
  Qed.

  Lemma sep_conj_Perms_perm: forall P Q p q,
      p ∈ P ->
      q ∈ Q ->
      p * q ∈ P ** Q.
  Proof.
    intros. exists p, q. split; auto. split; auto. reflexivity.
  Qed.

  Lemma sep_conj_Perms_commut : forall P Q, P ** Q ≡≡ Q ** P.
  Proof.
    split; repeat intro.
    - destruct H as [q [p' [? [? ?]]]].
      exists p', q. split; [| split]; auto. etransitivity; eauto. apply sep_conj_perm_commut.
    - destruct H as [p' [q [? [? ?]]]].
      exists q, p'. split; [| split]; auto. etransitivity; eauto. apply sep_conj_perm_commut.
  Qed.

  Lemma sep_conj_Perms_assoc : forall P Q R, P ** (Q ** R) ≡≡ (P ** Q) ** R.
  Proof.
    split; repeat intro.
    - rename p into p'. destruct H as [pq [r [? [? ?]]]].
      destruct H as [p [q [? [? ?]]]].
      exists p, (q * r).
      split; auto. split; auto. apply sep_conj_Perms_perm; auto.
      rewrite <- sep_conj_perm_assoc.
      etransitivity; eauto.
      apply sep_conj_perm_monotone; intuition.
    - rename p into p'. destruct H as [p [qr [? [? ?]]]].
      destruct H0 as [q [r [? [? ?]]]].
      exists (p * q), r.
      split; auto. apply sep_conj_Perms_perm; auto. split; auto.
      rewrite sep_conj_perm_assoc.
      etransitivity; eauto.
      apply sep_conj_perm_monotone; intuition.
  Qed.

  Lemma sep_conj_Perms_meet_commute : forall (Ps : Perms -> Prop) P,
      (meet_Perms Ps) ** P ≡≡ meet_Perms (fun Q => exists P', Q = P' ** P /\ Ps P').
  Proof.
    split; repeat intro.
    - destruct H as [? [[Q [? ?]] ?]].
      subst. destruct H1 as [? [? [? [? ?]]]].
      simpl. exists x, x0. split; [ | split]; auto.
      eexists; split; eauto.
    - destruct H as [? [? [[Q [? ?]] [? ?]]]].
      simpl. eexists. split.
      + exists Q. split; auto.
      + eapply Perms_upwards_closed; eauto.
        simpl. exists x, x0. split; [auto | split; [auto | ]]. reflexivity.
  Qed.

  Definition entails_Perms P Q := Q ⊑ P.
  Notation "P ⊦ Q" := (entails_Perms P Q) (at level 60).

  Instance entails_Perms_preorder : PreOrder entails_Perms.
  Proof.
    constructor; repeat intro; auto.
  Qed.

  Instance Proper_eq_Perms_entails_Perms :
    Proper (eq_Perms ==> eq_Perms ==> Basics.flip Basics.impl) entails_Perms.
  Proof.
    do 6 red. intros. rewrite H. rewrite H0. auto.
  Qed.

  Instance Proper_eq_Perms_sep_conj_Perms :
    Proper (eq_Perms ==> eq_Perms ==> eq_Perms) sep_conj_Perms.
  Proof.
    repeat intro. etransitivity.
    - split; eapply sep_conj_Perms_monotone; try eapply H0; try eapply H.
    - split; eapply sep_conj_Perms_monotone; try eapply H0; try eapply H; reflexivity.
  Qed.

  Definition impl_Perms P Q := meet_Perms (fun R => R ** P ⊦ Q).

  Lemma adjunction : forall P Q R, P ** Q ⊦ R <-> P ⊦ (impl_Perms Q R).
  Proof.
    intros. split; intros.
    - red. red. intros. simpl. exists P. auto.
    - apply (sep_conj_Perms_monotone _ _ Q Q) in H; intuition.
      red. etransitivity; [ | apply H ].
      unfold impl_Perms.
      rewrite sep_conj_Perms_meet_commute.
      apply meet_Perms_max. intros P' [? [? ?]]. subst. auto.
  Qed.

  Program Definition meet_A_Perms {A} (Ps : (A -> Perms) -> Prop) : A -> Perms :=
    fun a =>
      {|
        in_Perms := fun p => exists P, Ps P /\ p ∈ P a
      |}.
  Next Obligation.
    exists H. split; auto.
    apply (Perms_upwards_closed _ p1); assumption.
  Qed.

  Notation "P -⊑- Q" := (forall a, P a ⊑ Q a) (at level 60).
  Notation "P -≡- Q" := (P -⊑- Q /\ Q -⊑- P) (at level 60).

  Lemma lte_meet_A_Perms {A} : forall (Ps : (A -> Perms) -> Prop) P,
      Ps P ->
      meet_A_Perms Ps -⊑- P.
  Proof.
    repeat intro. exists P. auto.
  Qed.

  Lemma meet_A_Perms_max {A} : forall (Ps : (A -> Perms) -> Prop) Q,
      (forall P, Ps P -> Q -⊑- P) ->
      Q -⊑- meet_A_Perms Ps.
  Proof.
    repeat intro. destruct H0 as [? [? ?]].
    eapply H; eauto.
  Qed.

  Definition μ {A : Type}
             (F : (A -> Perms) -> A -> Perms)
             (Hmon: forall P Q, (P -⊑- Q) -> (F P -⊑- F Q)) : A -> Perms :=
    meet_A_Perms (fun P => F P -⊑- P).

  Lemma μ_fixedpoint {A} : forall (F : (A -> Perms) -> A -> Perms) Hmon,
      F (μ F Hmon) -≡- (μ F Hmon).
  Proof.
    intros. assert (F (μ F Hmon) -⊑- μ F Hmon).
    {
      unfold μ. repeat intro. destruct H as (P & ? & ?).
      eapply Hmon. 2: { apply H. assumption. }
      repeat intro. eexists. split; eauto.
    }
    split; auto.
    unfold μ. repeat intro. simpl. eexists. split. 2: eauto.
    apply Hmon. apply H.
  Qed.

  Lemma μ_least {A} : forall (F : (A -> Perms) -> A -> Perms) Hmon X,
      F X -≡- X ->
      μ F Hmon -⊑- X.
  Proof.
    intros. unfold μ. apply lte_meet_A_Perms. apply H.
  Qed.

  Lemma μ_induction {A} F (P : A -> Perms) Hmon :
    (forall a, F P a ⊑ P a) ->
    (forall a, μ F Hmon a ⊑ P a).
  Proof.
    intros Hlte a p Hp.
    eexists. split; eauto.
  Qed.
End Permissions.


From Undecidability.L Require Export Util.L_facts.

(* **** Closure calculus *)

Inductive Comp : Type :=
| CompVar (x:nat)
| CompApp (s : Comp) (t : Comp) : Comp
| CompClos (s : term) (A : list Comp) : Comp.

Coercion CompApp : Comp >-> Funclass.

Inductive lamComp : Comp -> Prop := lambdaComp s A: lamComp (CompClos (lam s) A).

Inductive validComp : Comp -> Prop :=
| validCompApp s t : validComp s -> validComp t -> validComp (s t)
| validCompClos (s : term) (A : list Comp) :
     (forall a, a el A -> validComp a) -> (forall a, a el A -> lamComp a) -> bound (length A) s -> validComp (CompClos s A).

Hint Constructors Comp lamComp validComp : core.

Definition validEnv A := forall a, a el A -> validComp a (*/\ lamComp a)*).

Definition validEnv' A := forall a, a el A -> closed a.

Hint Unfold validEnv validEnv' : core.

Lemma validEnv_cons a A : validEnv (a::A) <-> ((validComp a) /\ validEnv A).
Proof.
  unfold validEnv. simpl. split. auto. intros [? ?] a' [eq|el']; subst;auto.
Qed.

Lemma validEnv'_cons a A : validEnv' (a::A) <-> (closed a /\ validEnv' A).
Proof.
  unfold validEnv'. simpl. intuition. now subst.
Qed.

Ltac inv_validComp :=
  match goal with
    | H : validComp (CompApp _ _) |- _ => inv H
    | H : validComp (CompClos _ _)   |- _ => inv H
  end.

Definition Comp_ind_deep'
           (P : Comp -> Prop)
           (Pl : list Comp -> Prop)
           (IHVar : forall x : nat, P (CompVar x))
           (IHApp : forall s : Comp, P s -> forall t : Comp, P t -> P (s t))
           (IHClos : forall (s : term) (A : list Comp),
                       Pl A -> P (CompClos s A))
           (IHNil : Pl nil)
           (IHCons : forall (a:Comp) (A : list Comp),
                       P a -> Pl A -> Pl (a::A))
           (x:Comp) : P x :=
  (fix f c : P c:=
     match c with
       | CompVar x => IHVar x
       | CompApp s t => IHApp s (f s) t (f t)
       | CompClos s A => IHClos s A
         ((fix g A : Pl A :=
            match A with
                [] => IHNil
              | a::A => IHCons a A (f a) (g A)
            end) A)
     end) x
.

Definition Comp_ind_deep
           (P : Comp -> Prop)
           (IHVar : forall x : nat, P (CompVar x))
           (IHApp : forall s : Comp, P s -> forall t : Comp, P t -> P (s t))
           (IHClos : forall (s : term) (A : list Comp),
                       (forall a, a el A -> P a) -> P (CompClos s A)) : forall x, P x.
Proof.
  apply Comp_ind_deep' with (Pl:=fun A => (forall a, a el A -> P a));auto.
  intros. inv H1;auto.
Qed.

(*
Lemma subst_comm s x1 u1 x2 u2 : closed u1 -> closed u2 -> x1 <> x2 -> subst (subst s x1 u1) x2 u2 = subst (subst s x2 u2) x1 u1.
Proof with try (congruence||auto).
  intros cl1 cl2 neq. revert x1 x2 neq;induction s;simpl;intros.
  -decide (n=x1); decide (n=x2); try rewrite cl1;try rewrite cl2;subst;simpl...
   +decide (x1=x1)...
   +decide (x2=x2)...
   +decide (n=x2);decide (n=x1)...
  -rewrite IHs1,IHs2...
  -rewrite IHs...
Qed.
*) (*
Lemma subst_twice s x u1 u2 : closed u1 -> subst (subst s x u1) x u2 = subst s x u1.
Proof with try (congruence||auto).
  intros cl. revert x;induction s;simpl;intros.
  -decide (n=x);subst. now rewrite cl. simpl. decide (n=x);subst;congruence.
  -rewrite IHs1,IHs2...
  -rewrite IHs...
Qed.*)
(*
Lemma subst_free a s k u y: closed a -> subst s k u = s -> subst (subst s y a) k u = subst s y a.
Proof.
  intros ca eq. revert y k u eq. induction s;simpl;intros.
  -decide (n=y). now rewrite ca. apply eq.
  -simpl in eq. inversion eq. rewrite H0, H1, IHs1, IHs2;auto.
  -f_equal. simpl in eq. inversion eq. rewrite !H0. now rewrite IHs.
Qed.*)
(*
Lemma bound_ge k s m: bound k s -> m >= k -> bound m s.
Proof.
  intros. decide (m=k);subst.
  -auto.
  -eapply bound_gt;eauto. lia.
Qed.
*)
(*
Lemma bound_subst' x s a y:  bound x s -> closed a -> bound x (subst s y a).
Proof.
  intros dcl cl. revert y. induction dcl;simpl;intros.
  -decide (n=y);subst.
   +eapply bound_ge. now apply closed_dcl. lia.
   +now constructor.
  -now constructor.
  -now constructor.
Qed.
*)

(*
Fixpoint substList' (s:term) (x:nat) (A: list term): term :=
  match A with
    | nil => s
    | a::A => substList' (subst s x a) (S x) A
  end.*)

Fixpoint substList (s:term) (x:nat) (A: list term): term :=
  match s with
    | var n => if Dec (x>n) then var n else nth (n-x) A (var n)
    | app s t => app (substList s x A) (substList t x A)
    | lam s => lam (substList s (S x) A)
  end.

Fixpoint deClos (s:Comp) : term :=
  match s with
    | CompVar x => var x
    | CompApp s t => app (deClos s) (deClos t)
    | CompClos s A => substList s 0 (map deClos A)
  end.

(* Reduction *)

Reserved Notation "s '>[(' l ')]' t" (at level 50, format "s  '>[(' l ')]'  t").

Declare Scope LClos.

Inductive CPow : nat -> Comp -> Comp -> Prop :=
| CPowRefl (s:Comp) : s >[(0)] s
| CPowTrans (s t u:Comp) i j : s >[(i)] t -> t >[(j)] u -> s >[(i+j)] u
| CPowAppL (s s' t :Comp) l: s >[(l)] s' -> (s t) >[(l)] (s' t)
| CPowAppR (s t t':Comp) l: t >[(l)] t' -> (s t) >[(l)] (s t')
| CPowApp  (s t:term) (A:list Comp) :
    CompClos (app s t) A >[(0)] (CompClos s A) (CompClos t A)
| CPowVar (x:nat) (A:list Comp):
    CompClos (var x) A >[(0)] nth x A (CompVar x)
| CPowVal (s t:term) (A B:list Comp):
    lambda t -> (CompClos (lam s) A) (CompClos t B) >[(1)] (CompClos s ((CompClos t B)::A))
where "s  '>[(' l ')]'  t" := (CPow l s t)  : LClos.

Open Scope LClos.

Ltac inv_CompStep :=
  match goal with
    | H : (CompApp _ _) >(_) CompClos _ _ |- _ => inv H
    | H : (CompClos _ _) >(_) CompApp _ _ |- _ => inv H
  end.

Hint Constructors CPow : core.

Lemma CPow_congL n s s' t :
  s >[(n)] s' ->  s t >[(n)] s' t.
Proof.
  induction 1;eauto.
Qed.

Lemma CPow_congR n (s t t' : Comp) :
  t >[(n)] t' ->  s t >[(n)] s t'.
Proof.
  induction 1;eauto.
Qed.

Lemma CPow_trans s t u i j k : s >[(i)] t -> t >[(j)] u -> i + j = k -> s >[(k)] u.
Proof.
  intros. subst. eauto.
Qed.

Instance CPow'_App_properR n:
  Proper (eq ==> (CPow n) ==> (CPow n)) CompApp.
Proof.
  intros ? ? -> ? ?  ?. now eapply CPow_congR.
Qed.
(*
Definition CStar s t:= exists k , CPow k s t .

Notation "s '>[]*' t" := (CStar s t) (at level 50)  : L.los.

Instance rStar'_PreOrder : PreOrder CStar.
Proof.
  constructor; hnf.
  -now eexists.
  -eapply star_trans.
Qed.

Lemma rStar'_trans_l s s' t :
  s >[]* s' ->  s t >[]* s' t.
Proof.
  induction 1; eauto using star.
Qed.

Lemma rStar'_trans_r (s t t' : Comp):
  t >[]* t' -> s t >[]* s t'.
Proof.
  induction 1; eauto using star.
Qed.

Instance rStar'_App_proper :
  Proper ((star CStep) ==> (star CStep) ==> (star CStep)) CompApp.
Proof.
  cbv. intros s s' A t t' B. etransitivity.
  apply rStar'_trans_l, A. apply rStar'_trans_r, B.
Qed.

Instance CStep_star_subrelation : subrelation CStep (star CStep).
Proof.
  intros s t st. eauto using star.
Qed.

*)

(* Properties of step-indexed version *)
(*
Notation "x '>[]^' n y" := (ARS.pow CStep n x y) (at level 50) : L.cope.

Lemma CStep_Lam  n: forall (s t u:Comp), lamComp u -> (ARS.pow CStep n (s t) u) ->
                                       exists m1 m2 (s' t':Comp),(m1 < n /\ ARS.pow CStep m1 s s' /\ lamComp s')
                                                                 /\ (m2 < n /\ ARS.pow CStep m2 t t' /\ lamComp t').
Proof with repeat intuition;try now reflexivity.
  induction n;intros ? ? ? lu R.
  -inv R. inv lu.
  -destruct R as [u' [R R']]. inv R.
   +apply IHn in R'... decompose [ex and] R'. exists (S x), x0, x1, x2... change (S x) with (1+x). apply pow_add;simpl. exists s';intuition. eexists;simpl...
   +apply IHn in R'... decompose [ex and] R'. exists x, (S x0), x1, x2... change (S x0) with (1+x0). apply pow_add;simpl. exists t';intuition. eexists;simpl...
   +inv H2. eexists 0,0,_,_...
Qed.

Lemma CStep_Lam' (s t u:Comp) : lamComp u -> (s t) >[]* u ->
                         exists (s' t':Comp),( s >[]* s' /\ lamComp s')
                                             /\ (t >[]* t' /\ lamComp t').
Proof with repeat intuition;try now reflexivity.
  intros lu R. apply star_pow in R. destruct R as [n R]. revert s t u lu R. induction n;intros.
  -inv R. inv lu.
  -destruct R as [u' [R R']]. inv R.
   +apply IHn in R'... decompose [ex and] R'. exists x, x0... eauto using star.
   +apply IHn in R'... decompose [ex and] R'. exists x, x0... eauto using star.
   +inv H2. eexists _,_...
Qed.

*)
Lemma substList_bound x s A: bound x s -> substList s x A = s.
Proof.
  revert x;induction s;intros;simpl.
  -inv H. decide (x>n);tauto.
  -inv H. now rewrite IHs1,IHs2.
  -inv H. rewrite IHs;auto.
Qed.

Lemma substList_closed s A x: closed s -> substList s x A = s.
Proof.
  intros. apply substList_bound. destruct x. now apply closed_dcl. eapply bound_gt;[rewrite <- closed_dcl|];auto. lia.
Qed.

Lemma substList_var' y x A: y >= x -> substList (var y) x A = nth (y-x) A (var y).
Proof.
  intros ge. simpl. decide (x>y). lia. auto.
Qed.

Lemma substList_var y A: substList (var y) 0 A = nth y A (var y).
Proof.
  rewrite substList_var'. f_equal. lia. lia.
Qed.

Lemma substList_is_bound y A s: validEnv' A -> bound (y+|A|) (s) -> bound y (substList s y A).
Proof.
  intros vA. revert y. induction s;intros y dA.
  -apply closed_k_bound. intros k u ge. simpl. decide (y>n).
   +simpl. destruct (Nat.eqb_spec n k). lia. auto.
   +inv dA. assert (n-y<|A|) by lia. now rewrite (vA _ (nth_In A #n H)).
  -inv dA. simpl. constructor;auto.
  -simpl. constructor. apply IHs. now inv dA.
Qed.

Lemma substList_closed' A s: validEnv' A -> bound (|A|) (s) -> closed (substList s 0 A).
Proof.
  intros. rewrite closed_dcl. apply substList_is_bound;auto.
Qed.

Lemma deClos_valComp a: validComp a -> closed (deClos a).
Proof.
  intros va. induction va;simpl.
  -now apply app_closed.
  -apply substList_closed'. intros a ain. rewrite in_map_iff in ain. destruct ain as [a' [eq a'in]];subst. now apply H0. now rewrite map_length.
Qed.

Lemma deClos_validEnv A : validEnv A -> validEnv' (map deClos A).
Proof.
  intros vA. induction A;simpl.
  -unfold validEnv'. simpl. tauto.
  -rewrite validEnv'_cons.  apply validEnv_cons in vA as [ca cA]. split;auto. apply deClos_valComp; auto.
Qed.

Hint Resolve deClos_validEnv : core.

Lemma subst_substList x s t A: validEnv' A -> subst (substList s (S x) A) x t = substList s x (t::A).
Proof.
  revert x;induction s;simpl;intros x cl.
  -decide (S x > n);simpl. decide (x>n); destruct (Nat.eqb_spec n x);try lia;try tauto. subst. now rewrite minus_diag. decide (x>n). lia. destruct (n-x) eqn: eq. lia. assert (n2=n-S x) by lia. subst n2. destruct (nth_in_or_default (n-S x) A #n).
   + apply cl in i. now rewrite i.
   +rewrite e. simpl. destruct (Nat.eqb_spec n x). lia. auto.
  -now rewrite IHs1,IHs2.
  -now rewrite IHs.
Qed.

Lemma validComp_step s t l: validComp s -> s >[(l)] t -> validComp t.
Proof with repeat (subst || firstorder).
  intros vs R. induction R;repeat inv_validComp...
  -inv H3. constructor...
  -inv H3. apply H1. apply nth_In. lia.
  -inv H8. constructor;auto;intros a [?|?];subst;auto.
Qed.

Hint Resolve validComp_step : core.
(*
Lemma deClos_correct''' s t : validComp s -> s >(0) t -> deClos s = deClos t.
Proof with repeat (cbn in * || eauto || congruence || lia || subst).
  intros cs R. remember 0 as n eqn:eq in R. revert eq. induction R;intros ?;repeat inv_validComp...
  -destruct i... rewrite IHR1,IHR2...
  -destruct IHR...
  -rewrite IHR...
  -simpl. rewrite <- minus_n_O. rewrite <-map_nth with (f:=deClos)...
Qed.

Lemma deClos_correct'' s t : validComp s -> s >(1) t -> deClos s = deClos t \/ deClos s ≻ deClos t.
Proof with repeat (cbn in * || eauto || congruence || lia || subst).
  intros cs R. remember 1 as n eqn:eq in R. revert eq. induction R;intros ?;repeat inv_validComp...
  -destruct i...
   +destruct IHR2... apply deClos_correct''' in R1... left... aply deClos_correct''' in R1... right...
    right... split;eauto. destruct IHR. auto.  left... right...
  -destruct IHR. auto.  left... right...
  -left...
  -left. simpl. rewrite <- minus_n_O. rewrite <-map_nth with (f:=deClos)...
  -right. inv H. simpl. rewrite <-subst_substList...
Qed.*)

Lemma deClos_correct l s t : validComp s -> s >[(l)] t -> deClos s >(l) deClos t.
Proof with repeat (cbn in * || eauto 10 using star || congruence || lia || subst).
  intros cs R.
  induction R...
  -eapply pow_trans;eauto.
  -inv cs;apply pow_step_congL...
  -inv cs;apply pow_step_congR...
  -rewrite <- minus_n_O. rewrite <-map_nth with (f:=deClos)...
  -inv H. inv cs. inv H1. eexists;split... rewrite <- subst_substList...
Qed.

(*

(* relation that tries to capture that two closures 'reduce' to one another *)

Reserved Notation "s '=[]>' t" (at level 70).

Inductive reduceC : Comp -> Comp -> Prop :=
  | redC s t: deClos s >* deClos t -> s =[]> t
where "s '=[]>' t" := (reduceC s t).

Hint Constructors reduceC.

Lemma reduceC_if s t : s =[]> t -> deClos s >* deClos t.
Proof.
  now inversion 1.
Qed.

(* ** Properties of the extended reduction relation *)

Instance reduceC_PreOrder : PreOrder reduceC.
Proof.
  constructor;repeat intros;constructor.
  -reflexivity.
  -inv H. inv H0. now rewrite H1.
Qed.

Instance reduceC_App_proper :
  Proper (reduceC ==> reduceC ==> reduceC) CompApp.
Proof.
  cbv. intros s s' A t t' B. constructor. simpl. apply star_step_app_proper.
  -now inv A.
  -now inv B.
Qed.

Lemma CStep_reduceC l s t: validComp s -> s >(l) t -> s =[]> t.
Proof.
 intros. constructor. eapply deClos_correct;eauto.
Qed.

(* relation that tries to capture that two closures 'are the same' *)

Reserved Notation "s '=[]=' t" (at level 70).

Inductive equivC : Comp -> Comp -> Prop :=
  | eqC s t: deClos s == deClos t -> s =[]= t
where "s '=[]=' t" := (equivC s t).

Hint Constructors equivC.

Lemma equivC_if s t : s =[]= t -> deClos s == deClos t.
Proof.
  now inversion 1.
Qed.

(* ** Properties of the equivalence relation *)

Instance equivC_Equivalence : Equivalence equivC.
Proof.
  constructor;repeat intros;constructor.
  -reflexivity.
  -inv H. now rewrite H0.
  -inv H0. inv H. now rewrite H0.
Qed.

Instance equivC_App_proper :
  Proper (equivC ==> equivC ==> equivC) CompApp.
Proof.
  cbv. intros s s' A t t' B. constructor. simpl. apply equiv_app_proper.
  -now inv A.
  -now inv B.
Qed.

Lemma CStep_equivC s t: validComp s -> s >[]> t -> s =[]= t.
  intros vs R. induction R;repeat inv_validComp.
  -now rewrite IHR.
  -now rewrite IHR.
  -constructor. reflexivity.
  -constructor. simpl. rewrite <- minus_n_O. rewrite <-map_nth with (f:= deClos). reflexivity.
  -constructor. rewrite deClos_correct'. reflexivity. auto. auto.
Qed.

Lemma starC_equivC s t :
  validComp s -> s >[]* t -> s =[]= t.
Proof.
  intros vs R. induction R.
  -reflexivity.
  -rewrite <-IHR.
   +eauto using CStep_equivC.
   +eauto using validComp_step.
Qed.

*)

Lemma substList_nil s x: substList s x [] = s.
Proof.
  revert x. induction s;intros;simpl.
  -decide (x>n). reflexivity. now destruct(n-x).
  -congruence.
  -congruence.
Qed.
(*
Lemma equivC_deClos s : s =[]> CompClos (deClos s) [].
Proof.
  constructor. simpl. induction s;simpl.
  -now destruct x.
  -rewrite IHs1 at 1. rewrite IHs2 at 1. reflexivity.
  -now rewrite substList_nil.
Qed.

 *)
(*
Goal uniform_confluent CStep.
Proof with try (congruence||(now (subst;tauto))||(now (right;eauto))||(now (right;eauto;eexists;eauto))).
  intros s. induction s;intros.
  -inv H.
  -inv H;inv H0...
   +destruct (IHs1 _ _ H4 H3) as [?|[? [? ?]]]...
   +destruct (IHs2 _ _ H4 H3) as [?|[? [? ?]]]...
   +inv H4; now inv H3.
   +inv H3; now inv H4.
  -inv H; inv H0...
Qed.*)
(*
Lemma lamComp_noStep l s t : lamComp s -> ~ s>(S l)t.
Proof.
  intros H R. remember (S l). revert Heqn. revert H. induction R;intros;try congruence.
  destruct i. inv H. inv R.lia. .
Qed.
*)
Lemma validComp_closed s: closed s -> validComp (CompClos s []).
Proof.
  intros cs. constructor;simpl;try tauto. now apply closed_dcl.
Qed.
(*
Lemma lamComp_star s t : lamComp s -> s >[]* t -> s = t.
Proof.
  intros H R. induction R. auto. now apply lamComp_noStep in H0.
Qed.

Lemma validComp_star s t: validComp s -> s >[]* t -> validComp t.
Proof.
  intros vs R. induction R; eauto using validComp_step.
Qed.

*)
(*
Lemma deClos_lam p s: (λ s) = deClos p -> exists t, lamComp t /\ deClos t = (lam s) /\ p >[]* t.
Proof.
  revert s. apply Comp_ind_deep with (x:=p);clear p;simpl.
  -congruence.
  -congruence.
  -intros p A IH s eq. destruct p; simpl in eq.
   +rewrite <- minus_n_O in eq. change (var n) with (deClos (CompVar n)) in eq. rewrite map_nth in eq. apply IH in eq as [t [? [? R]]]. exists t;repeat split;auto. now rewrite CStepVar. destruct (nth_in_or_default n A (CompVar n)).
    *auto.
    *rewrite e in eq. simpl in eq. congruence.
   +inv eq.
   +exists (CompClos (lam p) A). simpl.  repeat split;auto. reflexivity.
Qed.

Fixpoint normComp' s A:=
  match s with
    | app s t => (normComp' s A) (normComp' t A)
    | var x => CompClos (var x) A (*nth x A (CompVar x)*)
    | lam s => CompClos (lam s) A
  end.

Fixpoint normComp s :=
  match s with
    | CompApp s t => (normComp s) (normComp t)
    | CompClos s A => normComp' s A
    | s => s
  end.

Lemma normComp'_deClos s A: deClos (CompClos s A) = deClos (normComp' s A).
Proof.
  induction s;simpl.
  -rewrite <- minus_n_O. reflexivity.
  -simpl in *. congruence.
  -simpl in *. congruence.
Qed.

Lemma normComp_deClos s: deClos s = deClos (normComp s).
Proof.
  induction s;simpl.
  -auto.
  -congruence.
  -rewrite <- normComp'_deClos. reflexivity.
Qed.

Lemma normComp'_star s A: CompClos s A >[]* normComp' s A.
Proof.
  induction s;simpl;eauto using star.
  -rewrite CStepApp. now rewrite IHs1,IHs2.
Qed.

Lemma normComp_star s: s >[]* normComp s.
Proof.
  induction s;simpl.
  -reflexivity.
  -now rewrite <- IHs1,<-IHs2.
  -apply normComp'_star.
Qed.

Lemma normComp'_idem s A:normComp (normComp' s A)=normComp' s A.
Proof.
  induction s;simpl;  congruence.
Qed.

Lemma normComp_idem s: normComp (normComp s)=normComp s.
Proof.
  induction s;simpl.
  -reflexivity.
  -congruence.
  -apply normComp'_idem.
Qed.

Lemma normComp'_valid s A: validComp (CompClos s A) -> validComp (normComp' s A).
Proof.
  intros vA. induction s;simpl.
  -auto.
  -inv vA. inv H3. auto.
  -auto.
Qed.

Lemma normComp_valid s: validComp s -> validComp (normComp s).
Proof.
  intros vs. induction s;simpl.
  -auto.
  -inv vs. auto.
  -apply normComp'_valid. auto.
Qed.

Lemma CompStep_correct2' s t : normComp s = s -> validComp s -> deClos s ≻ t -> exists t', t = deClos t' /\ s >[]* t'.
Proof.
  intros nc vs. revert t. induction vs as [s1 s2|]; intros t R.
  -simpl in R. inv R;simpl in nc.
   +destruct (deClos_lam H0) as [t'[lt' [eq R]]].
    destruct (deClos_lam H1) as [u [lu [equ Ru]]].
    inv lt'.
    exists (CompClos s0 (u::A)). simpl;split.
    *rewrite equ. rewrite <-subst_substList. simpl in eq. congruence. apply deClos_validEnv. apply validComp_star in R;auto. inv R. auto.
    *rewrite R, Ru. inv lu. rewrite <- CStepVal. reflexivity. auto.
   +apply IHvs2 in H2 as [u [? R]]. exists (s1 u). split; simpl. congruence. now rewrite R. congruence.
   +apply IHvs1 in H2 as [u [? R]]. exists (u s2). split; simpl. congruence. now rewrite R. congruence.
  -destruct s;simpl in nc.
   +simpl in R. rewrite <- minus_n_O in R. change (var n) with (deClos (CompVar n)) in R. rewrite map_nth in R. apply H0 in R. destruct R as [t' [? ?]].
    *eexists. split. eauto. now rewrite CStepVar.
    *apply nth_In. now inv H2.
    *destruct (nth_in_or_default n A (CompVar n)). apply H1 in i. inv i. now simpl.  rewrite e. reflexivity.
   +inv nc.
   +simpl in R. inv R.
Qed.

Lemma CompStep_correct2 s t : validComp s -> deClos s ≻ t -> exists t', t = deClos t' /\ s >[]* t'.
Proof.
  intros vs R. rewrite normComp_deClos in R. destruct (CompStep_correct2' (normComp_idem s) (normComp_valid vs) R) as [t' [eq R']]. exists t'. split.  auto. now rewrite normComp_star.
Qed.

Close Scope L.los.*)


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj25synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) (plus (Succ lv2) Zero)) (plus (mult lv2 (Succ lv1)) (Succ lv1))).
Admitted.
QuickChick conj25synthconj2.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e444m17_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.