(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite map library *)

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

Require Import FunInd 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') as [Hlt|Heq|Hlt]; try contradiction; clear y.
 destruct (H0 x).
 assert (In x ((x',e')::l')).
  apply H; auto.
  exists e; auto.
 destruct (In_inv H3).
 order.
 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.
 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') as [Hlt|Heq|Hlt].
 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) as [Hlt| |Hlt]; simpl; auto.
 inversion_clear Hm; clear H0 Hlt 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) as [Hlt|Heq|Hlt]; 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) as [Hlt|Heq|Hlt].
 (* 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') as [Hlt|Heq|Hlt]; 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) as [Hlt|Heq|Hlt]; auto.
 apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
 split.
 apply D.eq_refl.
 inversion_clear Hm.
 apply (IHm H).
 apply (MapS.Raw.MX.lt_antirefl Hlt); 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')  as [Hlt|Heq|Hlt]; 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') as [Hlt|Heq|Hlt];
  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
   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') as [Hlt|Heq|Hlt];
  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
   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') as [Hlt|Heq|Hlt]; 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.


(* (c) Copyright Christian Doczkal and Joachim Bard                       *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import Relations.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import all_ssreflect.
From CompDecModal.libs Require Import edone bcase fset base modular_hilbert.
From CompDecModal.PDL Require Import PDL_def demo.

Set Default Proof Using "Type".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Implicit Types (C D : clause).

(** * Hilbert Refutations *)

Section HilbertRef.
  Variable (F : {fset form}).
  Hypothesis (sfc_F : sf_closed F).

  Local Notation S0 := (S0 F).
  Local Notation PU := (PU F).
  Local Notation xaf := (fun C => [af C]).

  Definition href C := prv ([af C] ---> Bot).

  Lemma refI1n s C : prv ([af C] ---> s) -> href (s^- |` C).
  Proof.
    move => H. rewrite /href. rewrite -> andU,H,bigA1,axAC.
    rule axAcase. exact: axContra.
  Qed.

  Lemma refE1n s C : href (s^- |` C) -> prv ([af C] ---> s).
  Proof.
    move => H. rewrite /href in H. rewrite -> andU,bigA1 in H.
    Intro. ApplyH axDN. Intro. ApplyH H. by ApplyH axAI.
  Qed.

  Lemma ax_lcons C : ~~ lcons C -> prv ([af C] ---> Bot).
  Proof.
    rewrite negb_and -has_predC negbK.
    case/orP => [inC|/hasP [s sinC /=]].
    - rewrite -> (bigAE _ inC). exact: axI.
    - rewrite negbK => nsinC.
      rewrite -> (axA2 [af C]). rewrite -> (bigAE _ sinC) at 2.
      rewrite -> (bigAE _ nsinC). simpl. rule axAcase. case: s sinC nsinC => s [|] _ _ /=.
      exact: axI. exact: axContra.
  Qed.

  Section ContextRefutations.
    Variable S : {fset clause}.
    Hypothesis sub_S : S `<=` S0.
    Hypothesis coref_S : coref F href S.

    (* Lemma 6.1 *)
    Lemma not_hint_max C : C \in PU -> maximal F C -> ~~ hintikka C -> prv ([af C] ---> Bot).
    Proof using sfc_F.
      move/powersetP => Csub /allP => M.
      rewrite negb_and. case/orP; first exact: ax_lcons.
      case/allPn => s inC /=. move: (Csub _ inC). move/flip_drop_sign.
      case: s inC. case => [|x|s t|[a|p0 p1|p0 p1|p|s] t] [|] //= inC inF.
      - move: (sfc_F inF) => /=. case/andP => sinF tinF.
        rewrite negb_or. case/andP => /negbTE sninC /negbTE tninC. move: (M s sinF).
        rewrite sninC orbF => sinC. move: (M t tinF). rewrite tninC /= => tinC.
        do 2 rule axDup. rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ tinC) at 1.
        rewrite -> (bigAE _ sinC) => /=. exact: ax_contraNN.
      - move: (sfc_F inF) => /=. case/andP => sinF tinF. rewrite negb_and.
        case/orP => [/negbTE sninC | /negbTE tninC].
        + move: (M s sinF). rewrite sninC /= => sinC. rule axDup.
          rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ sinC). do 2 Intro. Apply* 1. Intro.
          rewrite <- (axBE t). by Apply* 1.
        + move: (M t tinF). rewrite tninC orbF => tinC. rule axDup. rewrite -> (bigAE _ inC) at 1.
          rewrite -> (bigAE _ tinC). do 2 Intro. Apply* 1. Intro. by Asm.
      - move: (sfc_F inF) => /=. case/and3P => inF0 inF1 _. rewrite negb_and.
        case/orP => [/negbTE ninC0 | /negbTE ninC1].
        + move: (M _ inF0). rewrite ninC0 /= => inC0. rule axDup. rewrite -> (bigAE _ inC0) at 1.
          rewrite -> (bigAE _ inC) => /=. rewrite -> axChEl. exact: axI.
        + move: (M _ inF1). rewrite ninC1 /= => inC1. rule axDup. rewrite -> (bigAE _ inC1) at 1.
          rewrite -> (bigAE _ inC) => /=. rewrite -> axChEr. exact: axI.
      - move: (sfc_F inF). case/and3P => inF0 inF1 _. rewrite negb_or.
        case/andP => /negbTE ninC0 /negbTE ninC1. move: (M _ inF0) (M _ inF1).
        rewrite ninC0 ninC1 !orbF => inC0 inC1. do 2 rule axDup. rewrite -> (bigAE _ inC0) at 1.
        rewrite -> (bigAE _ inC1) at 1. rewrite -> (bigAE _ inC) => /=.
        rewrite -> (axDNE [p0 + p1]t). exact: axCh.
      - move/negbTE => ninC. move: (sfc_F inF). case/andP => inF' _. move: (M _ inF').
        rewrite ninC /= => inC'. rule axDup. rewrite -> (bigAE _ inC') at 1.
        rewrite -> (bigAE _ inC) => /=. rewrite -> axConE. exact: axI.
      - move/negbTE => ninC. move: (sfc_F inF). case/andP => inF' _. move: (M _ inF').
        rewrite ninC orbF => inC'. rule axDup. rewrite -> (bigAE _ inC') at 2.
        rewrite -> (bigAE _ inC) => /=. rewrite <- axCon. exact: axI.
      - move: (sfc_F inF). case/andP => pinF sinF. rewrite negb_and.
        case/orP => [/negbTE sninC | /negbTE pninC].
        + move: (M _ sinF). rewrite sninC /= => sinC. rule axDup. rewrite -> (bigAE _ sinC) at 1.
          rewrite -> (bigAE _ inC) => /=. rewrite -> axStarEl. exact: axI.
        + move: (M _ pinF). rewrite pninC /= => pinC. rule axDup.
          rewrite -> (bigAE _ inC) at 2 => /=. rewrite -> axStarEr.
          rewrite -> (bigAE _ pinC) => /=. exact: axI.
      - move: (sfc_F inF). case/andP => pinF sinF. rewrite negb_or.
        case/andP => /negbTE sninC /negbTE pninC. move: (M _ pinF) (M _ sinF).
        rewrite sninC pninC !orbF => pinC sinC. do 2 rule axDup.
        rewrite -> (bigAE _ inC) at 3 => /=. rewrite -> (axDNE [p^*]t).
        rewrite -> (bigAE _ sinC) at 1. rewrite -> (bigAE _ pinC). exact: axStar.

      (* Essentially the same as the implication cases *)
      - move: (sfc_F inF) => /=. case/andP => sinF tinF.
        rewrite negb_or. case/andP => /negbTE sninC /negbTE tninC. move: (M s sinF).
        rewrite sninC orbF => sinC. move: (M t tinF). rewrite tninC /= => tinC.
        do 2 rule axDup. rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ tinC) at 1.
        rewrite -> (bigAE _ sinC) => /=. rewrite -> axTestE. exact: ax_contraNN.
      - move: (sfc_F inF) => /=. case/andP => sinF tinF. rewrite negb_and.
        case/orP => [/negbTE sninC | /negbTE tninC].
        + move: (M s sinF). rewrite sninC /= => sinC. rule axDup.
          rewrite -> (bigAE _ inC) at 1. rewrite -> (bigAE _ sinC). rewrite /=.
          rewrite <- axTestI. do 2 Intro. Apply* 1. Intro. rewrite <- (axBE t). by Apply* 1.
        + move: (M t tinF). rewrite tninC orbF => tinC. rule axDup. rewrite -> (bigAE _ inC) at 1.
          rewrite /=. rewrite <- axTestI. rewrite -> (bigAE _ tinC). do 2 Intro. Apply* 1. Intro. by Asm.
    Qed.

    Lemma bigxm C s : prv ([af C] ---> [af s^+ |` C] :\/: [af s^- |` C]).
    Proof.
      apply: (rMP (s := s :\/: ~~:s)); last exact: axI. rule axOE.
      - rewrite <- axOIl. do 2 Intro. apply: bigAI => t /fsetU1P [->|inC]; first by Asm.
        Rev. drop. exact: bigAE.
      - rewrite <- axOIr. do 2 Intro. apply: bigAI => t /fsetU1P [->|inC]; first by Asm.
        Rev. drop. exact: bigAE.
    Qed.

    Lemma extension0 C : C \in PU ->
      prv ([af C] ---> \or_(D <- [fset D in S0 | C `<=` D]) [af D]).
    Proof using sfc_F.
      rewrite powersetE. apply: (slack_ind (P := fun C => prv ([af C] ---> _))) => D IH sub.
      case (boolP (maximal F D)).
      - case (boolP (hintikka D)).
        + move => H M. apply: bigOI. by rewrite !inE powersetE sub H M /= subxx.
        + move: sub. rewrite -powersetE => sub nH M. rewrite -> (not_hint_max sub M nH).
          exact: axBE.
      - case/allPn => s inF /=. rewrite negb_or. case/andP => sninD fsninD.
        rewrite -> (bigxm D s). rule axOE; (rewrite -> IH; last by rewrite fproper1).
        + apply: or_sub. move => E. rewrite !inE. case/andP => /and3P [-> -> ->] /=.
          by case/fsubUsetP.
        + rewrite fsubUset sub fsub1 /= andbT. apply/cupP. exists s. by rewrite inF !inE eqxx.
        + apply: or_sub. move => E. rewrite !inE. case/andP => /and3P [-> -> ->] /=.
          by case/fsubUsetP.
        + rewrite fsubUset sub fsub1 /= andbT. apply/cupP. exists s. by rewrite inF !inE eqxx.
    Qed.

    (* Lemma 6.2 (Extension) *)
    Lemma extension C : C \in PU ->
      prv ([af C] ---> \or_(D <- [fset D in S | C `<=` D]) [af D]).
    Proof using coref_S sfc_F.
      move => Csub. rewrite -> extension0 => //. apply: bigOE => D. rewrite !inE.
      case/andP => /and3P [Dsub M H] CsubD.
      case inS: (D \in S).
      - apply: bigOI. by rewrite !inE inS CsubD.
      - rewrite -> coref_S; first exact: axBE. by rewrite !inE Dsub M H inS.
    Qed.

    (* Lemma 6.3 (Admissibility of P1 *)
    Lemma adm_P1 C : C \in PU -> ~~ S |> C -> href C.
    Proof using coref_S sfc_F.
      rewrite /href => H1 H2. rewrite -> extension => //.
      apply: bigOE => D. rewrite inE => /andP [D1 D2]. case: notF.
      apply: contraNT H2 => _. by apply/hasP; exists D.
    Qed.

    Lemma nsub_contra C D :
      C \in S -> D \in S -> ~~ (C `<=` D) -> prv ([af C] ---> [af D] ---> fF).
    Proof using sub_S.
      move => /(subP sub_S). rewrite inE powersetE. case/and3P => sub _ _.
      move/(subP sub_S). rewrite inE. case/and3P => _ _ /allP maxD. case/subPn.
      case => s [|]; move => inC ninD; move: (maxD s); rewrite (negbTE ninD) ?orbF /=;
      rewrite -> (bigAE _ inC); move: inC => /(subP sub) => inF;
      rewrite (flip_drop_sign inF) => inD; rule axC; (rewrite -> bigAE;
      last exact: inD); [done| by rule axC].
    Qed.

    (* Lemma 6.4 *)
    Lemma neq_contra C D : C \in S -> D \in S -> C != D -> prv ([af C] ---> [af D] ---> fF).
    Proof using sub_S.
      move => CinS DinS. rewrite eqEsub negb_and.
      case/orP => H; [exact: nsub_contra | rule axC; exact: nsub_contra].
    Qed.

    (* Lemma 6.5 (1) *)
    Lemma or_S : prv (\or_(C <- S) [af C]).
    Proof using coref_S sfc_F.
      apply (rMP (s := [af fset0])).
      - rewrite -> extension; last by rewrite powersetE sub0x. apply: bigOE => C. rewrite inE.
        case/andP => inS _. exact: bigOI.
      - mp; last exact: axT. apply: bigAI => s. by rewrite inE.
    Qed.

    (* Lemma 6.5 (2) *)
    Lemma neg_or A : A `<=` S -> prv ((~~: \or_(C <- A) [af C]) ---> \or_(C <- S `\` A) [af C]).
    Proof using coref_S sfc_F.
      move => sub. mp; last exact: or_S. apply: bigOE => C inS. case inA: (C \in A).
      - rewrite <- (bigOI _ inA). exact: axContra.
      - rule axC. drop. apply: bigOI. by rewrite inE inS inA.
    Qed.

    Lemma maxS0 C s b : C \in S -> (s,b) \notin C -> s \in F -> (s,~~ b) \in C.
    Proof using sub_S.
      move/(subP sub_S). rewrite inE => /and3P[_ _ /allP] H inC /H.
      case: b inC => /negbTE-> //=. by rewrite orbF.
    Qed.

    Ltac adm_P2_aux_tac :=
      try match goal with
            [ Hu : is_true (_ \in F) |- _] =>
              by [move/sfc_F : Hu => /and3P[]|move/sfc_F : Hu => /andP[]]
          end.

    (* Lemma 6.7 *)
    Lemma adm_P2_aux C D p u : [p]u \in F ->
      C \in S -> D \in S -> ~~ reach_demo S p C D -> prv ([af C] ---> [p]~~:[af D]).
    Proof with adm_P2_aux_tac using coref_S sfc_F sub_S.
      elim: p u C D => [a|p0 IH0 p1 IH1|p0 IH0 p1 IH1|p IHp|s] u C D Hu CinS DinS /=.
      - rewrite -has_predC. case/hasP. case => s [|]; last by rewrite (negbTE (Rpos _ _ _)).
        rewrite RE /= => inC ninD.
        have inD : s^- \in D.
        { apply: maxS0 DinS ninD _. move: CinS => /(subP sub_S).
          rewrite inE powersetE. case/and3P => /subP sub _ _.
          apply: (@flip_drop_sign _ (s^+)).
          apply: flipcl_refl. move/sub : inC. by move/flip_drop_sign/sfc_F. }
        rewrite <- (axDN ([pV a](~~: [af D]))).
        rewrite -> (dmAX (pV a) (~~: [af D])). rewrite -> rEXn; last exact: axDN.
        rewrite -> (bigAE _ inC). rewrite -> (rEXn (pV a) (t:= ~~: s)).
        + rule axC. do 2 Intro. rule axB; last by do 2 Rev; exact: axDBD.
          rewrite -> rEXn; first exact: axnEXF. rewrite -> (axDNE (~~: s ---> ~~: s)). exact: axI.
        + rewrite -> bigAE; last exact: inD. exact: axI.
      - rewrite negb_or. case/andP => H0 H1. rewrite <- axDup. rewrite -> (IH0 u) at 1 => //...
        rewrite -> (IH1 u C D) => //... exact: axCh.
      - rewrite -all_predC. move/allP => H. rewrite <- axCon.
        rewrite <- (axDN ([p0][p1](~~: [af D]))).
        rewrite -> (dmAX p0 ([p1](~~: [af D]))).
        rewrite -> (rEXn p0 (t:= (\or_(E <- S) [af E]) :/\: EX p1 [af D])); last
          by apply: (rMP _ or_S); exact: axAI.
        rewrite -> rEXn; last by rewrite -> bigODr; exact: axI. rewrite -> bigEOOE.
        rule axC. apply: bigOE => E inS. move: (H E inS) => /=. rewrite negb_and.
        case/orP => [H0|H1].
        + rewrite -> (IH0 [p1]u C E) => //... do 2 Intro. rule axB; last by do 2 Rev; exact: axDBD.
          rewrite -> rEXn; first exact: axnEXF. do 2 rule axAcase. rule axC. drop.
          exact: axContra.
        + rule axC. drop. rewrite -> rEXn; first exact: axnEXF.
          rule axDup. rewrite -> axAEl at 2. rewrite -> axAEr. rewrite -> (IH1 u E D) => //...
      - move => H.
        set I := [fset E in S | reach_demo S (p^*) C E].
        set v := \or_(E <- I)[af E].
        suff X : prv (v ---> [p]v).
        { Cut v; first by apply: bigOI;rewrite !inE CinS /= connect_in0.
          rewrite -> (rStar_ind' X). apply: rNorm. apply: bigOE => E inI.
          apply: neq_contra => //; first by apply/(subP subsep); exact: inI.
          apply: contraTN inI => /eqP->. by rewrite inE DinS /= (negbTE H). }
        rewrite /v. rewrite <- (axDN ([p](\or_(E<-I) [af E]))), -> (dmAX p (\or_(E<-I) [af E])).
        apply: bigOE => E EinI. rewrite -> rEXn; last by apply: neg_or; exact: subsep.
        rewrite -> bigEOOE. rule axC. apply: bigOE => G GninI. rewrite -> (IHp [p^*]u E G) => //...
        * apply: (subP subsep). exact: EinI.
        * apply: (subP (fsubDl _ _)). exact: GninI.
        * apply/negP => ERG. move: GninI. rewrite inE. case/andP => GinS. apply/negP.
          apply/negPn. rewrite inE GinS /=. apply: connect_in_trans. move: EinI.
          case/sepP => _ CE. exact: CE. apply: connect_in1 => //. apply: (subP subsep).
          exact: EinI.
      - rewrite <- axTestI. case: (boolP (C == D)) => /= [/eqP-> A|].
        + suff X : s^- \in D. { rewrite -> (bigAE _ X) => /=. do 3 Intro. by Apply. }
          move/sfc_F : Hu => /andP [B _]. exact: (maxS0 DinS A).
        + move => A _. do 3 Intro. by ApplyH (neq_contra CinS DinS A).
    Qed.

    Lemma sfc_box p s : [p]s \in F -> s \in F.
    Proof using sfc_F.
      by case: p => [a|p1 p2|p1 p2|p|t] /sfc_F => /=; case:(s \in F); rewrite ?andbF.
    Qed.

    (* Lemma 6.8 (Admissibility of P2 *)
    Lemma adm_P2 C p s :
      C \in S -> [p]s^- \in C -> ~~[some D in S, reach_demo S p C D && (s^- \in D)]
        -> href C.
    Proof using coref_S sfc_F sub_S.
      move => inS inC. rewrite -all_predC. move/allP => nR.
      set X := [fset D in S | [fset s^-] `<=` D].
      have AAX: prv ([af C] ---> [p]\and_(D <- X) ~~:[af D]).
      { rewrite <- bigABBA. apply: bigAI => D. rewrite inE fsub1. case/andP => DinS inD.
        apply: (adm_P2_aux (u := s)) => //.
        - move/(subP sub_S) : inS inC.
          by rewrite inE powersetE => /andP [/subP H _] /H /flip_drop_sign.
        - move: (nR D DinS) => /=. by rewrite negb_and inD orbF.
      }
      have EOX: prv ([af C] ---> EX p (\or_(D <- X) [af D])).
      { rewrite <- rEXn; first by rewrite <- dmAX; exact: (bigAE _ inC).
        rewrite /X. rewrite <- (extension (C:= [fset s^-])).
        - apply: bigAI => t. rewrite inE. move/eqP => -> /=. exact: axI.
        - rewrite powersetE fsub1. apply: flipcl_refl.
          move/(subP sub_S) : inS inC.
          by rewrite inE powersetE => /andP [/subP H _] /H /flip_drop_sign /sfc_box.
      }
      rule axDup. rewrite -> EOX at 1. rewrite -> AAX. do 2 Intro.
      rule axB; last by do 2 Rev; exact: axDBD.
      rewrite -> rEXn; first exact: axnEXF.
      rewrite <- (axAcase (\or_(D<-X) [af D]) (\and_(D<-X) ~~: [af D]) Bot).
      apply: bigOE => D inX. rule axC. exact: bigAE.
    Qed.

  End ContextRefutations.

  (* Lemma 6.9 *)
  Theorem href_of C : pref F C -> href C.
  Proof using sfc_F. elim => *;[ apply: adm_P1 | apply: adm_P2 ]; eassumption. Qed.

End HilbertRef.

(** ** Completeness *)

(* Theorem 6.10 (Informative Completeness) *)
Theorem informative_completeness t :
    prv (fImp t fF)
  + ({ M: fmodel & #|M| <= 2^(2 * sizef t) & { w: M | eval t w}}).
Proof.
  set F := FL t. have sfc_s := @FL_closed t.
  case: (@pruning_completeness F _ [fset t^+]) => //.
  - by rewrite powersetE fsub1 flipcl_refl // FL_refl.
  - move => /href_of H. left. rewrite /href in H. rewrite <- H => //. apply: bigAI => u.
    by rewrite inE => /eqP ->.
  - move => H. right. move: H => [M] [w] /(_ (t^+) (fset11 _)) /= ? S.
    exists M; last by exists w.
    apply: leq_trans S _. by rewrite leq_exp2l ?leq_mul ?FL_size.
Qed.

(** ** Main Results *)

(* Corollary 6.11 *)
Corollary completeness s : valid s -> prv s.
Proof.
  case: (informative_completeness (~~: s)) => [H|[M] _ [w] H] V.
  - by rule axDN.
  - exfalso. apply: H. exact: (V (cmodel_of_fmodel M)).
Qed.

(* Corollary 6.12 (Decidability) *)
Corollary prv_dec s : decidable (prv s).
Proof.
  case: (informative_completeness (~~: s)) => H; [left|right].
  - by rule axDN.
  - move => prv_s. case: H => M _ [w]. apply. exact: (@soundness _ prv_s M).
Qed.

Corollary sat_dec s : decidable (exists (M: cmodel) (w: M), eval s w).
Proof.
  case: (informative_completeness s) => H; [right|left].
  - case => M [w] Hw. exact: (@soundness _ H M).
  - case: H => M _ [w] ?. by exists M; exists w.
Qed.

Corollary valid_dec s : decidable (forall (M: cmodel) (w: M), eval s w).
Proof.
  case (sat_dec (fImp s fF)) => /= H; [by firstorder|left => M w].
  apply: modelP => A. apply: H. by exists M;exists w.
Qed.

(* Corollary 6.13 (Small-Model Property) *)
Corollary small_models s:
  (exists (M: cmodel) (w: M), eval s w) ->
  (exists2 M: fmodel, #|M| <= 2^(2 * sizef s) & exists w: M, eval s w).
Proof.
  case: (informative_completeness s); last by firstorder.
  move => /(soundness) H [M] [w] w_s. exfalso. exact: H w_s.
Qed.


Require Import Coq.Program.Equality.
Require Import Coqlib.
Require Import ParserArg.
Import X86_PARSER_ARG.

Set Implicit Arguments.

Inductive void : Type := .

(** Syntax for the types returned by a grammar *)
Inductive xtype : Type :=
| xUnit_t : xtype
| xChar_t : xtype
| xVoid_t : xtype
| xPair_t : xtype -> xtype -> xtype
| xSum_t : xtype -> xtype -> xtype
| xList_t : xtype -> xtype.

Definition type_dec : forall (t1 t2:xtype), {t1=t2} + {t1<>t2}.
  decide equality.
Defined.

(** Interpret the type syntax as a Coq type. *)
Fixpoint xt_interp (t:xtype) : Type :=
  match t with
    | xUnit_t => unit
    | xChar_t => char_p
    | xVoid_t => void
    | xPair_t t1 t2 => (xt_interp t1) * (xt_interp t2)
    | xSum_t t1 t2 => (xt_interp t1) + (xt_interp t2)
    | xList_t t1 => list (xt_interp t1)
  end%type.

(** Syntax for transforms (functions) that map from one type to
      another.  This little first-order language uses a variable-
      free representation (similar to sequents) to avoid messing with
      issues around lambda representations. *)
Reserved Notation "t1 ->> t2" (left associativity, at level 69, t2 at next level).
Inductive xform : xtype -> xtype -> Type :=
| Xid    : forall {t}, t ->> t
| Xzero  : forall {t}, xVoid_t ->> t
| Xcomp  : forall {t1 t2 t3}, (t1 ->> t2) -> (t2 ->> t3) -> (t1 ->> t3)
| Xchar  : forall {t}, char_p -> t ->> xChar_t
| Xunit  : forall {t}, t ->> xUnit_t
| Xempty : forall {t1 t2}, t1 ->> xList_t t2
| Xpair  : forall {t t1 t2}, (t ->> t1) -> (t ->> t2) -> (t ->> xPair_t t1 t2)
| Xfst   : forall {t1 t2}, (xPair_t t1 t2) ->> t1
| Xsnd   : forall {t1 t2}, (xPair_t t1 t2) ->> t2
| Xinl   : forall {t1 t2}, t1 ->> (xSum_t t1 t2)
| Xinr   : forall {t1 t2}, t2 ->> (xSum_t t1 t2)
| Xmatch : forall {t t1 t2},  (t1 ->> t) -> (t2 ->> t) -> (xSum_t t1 t2 ->> t)
| Xcons  : forall {t1 t2}, (t1 ->> t2) -> (t1 ->> xList_t t2) -> (t1 ->> xList_t t2)
| Xfoldr : forall {t1 t2 t3},
             (xPair_t t1 t2 ->> t2) -> (t3 ->> t2) -> (t3 ->> xList_t t1) -> t3 ->> t2
where "t1 ->> t2" := (xform t1 t2).

(** These declarations ensure that the types will be erased upon extraction.
    But we must make sure not to ever eliminate these types... *)
Extraction Implicit Xid [t].
Extraction Implicit Xzero [t].
Extraction Implicit Xcomp [t1 t2 t3].
Extraction Implicit Xchar [t].
Extraction Implicit Xunit [t].
Extraction Implicit Xempty [t1 t2].
Extraction Implicit Xpair [t t1 t2].
Extraction Implicit Xfst [t1 t2].
Extraction Implicit Xsnd [t1 t2].
Extraction Implicit Xinl [t1 t2].
Extraction Implicit Xinr [t1 t2].
Extraction Implicit Xmatch [t1 t2 t].
Extraction Implicit Xcons [t1 t2].
Extraction Implicit Xfoldr [t1 t2 t3].

(** Interpret the transform syntax as a Coq function.  Note that
      this is really a "compiler" of sorts in that we are able to
      translate all of the sub-terms at compile-time, so we don't
      pay the pattern-match cost at run-time.
 *)
Fixpoint xinterp {t1 t2} (x: t1 ->> t2) : xt_interp t1 -> xt_interp t2 :=
  match x in t1 ->> t2 return xt_interp t1 -> xt_interp t2 with
    | Xid => fun x => x
    | Xzero => fun (x:xt_interp xVoid_t) => match x with end
    | Xcomp f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x => f2' (f1' x)
    | Xchar c => fun _ => c
    | Xunit => fun _ => tt
    | Xempty => fun x => nil
    | Xpair f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x => (f1' x, f2' x)
    | Xfst => fst
    | Xsnd => snd
    | Xinl => inl
    | Xinr => inr
    | Xmatch f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x =>
        match x with
          | inl x1 => f1' x1
          | inr x2 => f2' x2
        end
    | Xcons f1 f2 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      fun x => (f1' x)::(f2' x)
    | Xfoldr f1 f2 f3 =>
      let f1' := xinterp f1 in
      let f2' := xinterp f2 in
      let f3' := xinterp f3 in
      fun x => List.fold_right (fun a b => f1' (a,b)) (f2' x) (f3' x)
  end.
Extraction Implicit xinterp [t1 t2].

(** * Optimize an [xform]. *)

(* Here are the optimizations we do on transforms.  I'm using ";" to
     abbreviate composition, and the other abbreviations should be obvious.
     Our primary goal is to get rid of obvious reductions like constructing
     a pair, and then immediately projecting out the first component.  Along
     the way, we effectively get rid of composition (similar to cut-elimination)
     so that as many of the reductions fire as possible.  We also do some
     "eta-like" reductions (e.g., (fst,snd) = id), but not all of those that
     are possible yet.

     id ; f => f
     zero ; f => zero

     f ; id => f
     f ; (f1 ; f2) => (f ; f1) ; f2
     f ; char c => char c
     f ; unit => unit
     f ; empty => empty
     f ; (g1, g2) => (f;g1, f;g2)
     f ; g1::g2 => (f;g1)::(f;g2)
     f ; foldr g1 g2 g3 => foldr g1 (f ; g2) (f ; g3)

     (f1,f2) ; fst => f1
     (f1,f2) ; snd => f2
     inl ; match f1 f2 => f1
     inr ; match f1 f2 => f2
     foldr f1 f2 empty => f2
     foldr f1 f2 (f3::f4) => (f3, foldr f1 f2 f4) ; f1

     foldr f1 f2 zero => zero
     foldr f1 zero f3 => zero
     pair zero f => zero
     pair f zero => f
     cons zero f => zero
     cons f zero => zero

     (fst, snd) => id
     match inl inr => id

     I'd like to add support for the "eta" rule for lists:
       foldr (fst::snd) empty f => f
     but haven't bothered to yet.

     Finally, it may be necessary to call the rewriting multiple times
     to get a normal form, since I wasn't able to make all of the
     reductions mutually recursive as they need to be.
   *)

(** Need some explicit casting to get things to type-check. *)
Definition xcoerce t1 t2 t3 t4 (x:xform t1 t2) : t1 = t3 -> t2 = t4 -> xform t3 t4.
  intros. subst. apply x.
Defined.
Extraction Implicit xcoerce [t1 t2 t3 t4].

(** A note:  It would be much more natural to index [grammar] and [xform] by
    the corresponding Coq [Type]s instead of my own internal [type] syntax,
    which then has to be interpreted.  In particular, I could get rid of
    the need to use [Extraction Implicit] which is a bit of a hack for
    getting rid of the [type]s in the extracted code.  However, I wouldn't
    be able to prove these crucial injectivity properties of sums and
    products. *)
Definition eq_pair_fst t1 t2 t3 t4 : (xPair_t t1 t2 = xPair_t t3 t4) -> t3 = t1.
  intros ; injection H. intros. apply (eq_sym H1).
Defined.
Definition eq_pair_snd t1 t2 t3 t4 : (xPair_t t1 t2 = xPair_t t3 t4) -> t4 = t2.
  intros ; injection H. intros. apply (eq_sym H0).
Defined.
Definition eq_sum_fst t1 t2 t3 t4 : (xSum_t t1 t2 = xSum_t t3 t4) -> t3 = t1.
  intros ; injection H. intros. apply (eq_sym H1).
Defined.
Definition eq_sum_snd t1 t2 t3 t4 : (xSum_t t1 t2 = xSum_t t3 t4) -> t4 = t2.
  intros ; injection H. intros. apply (eq_sym H0).
Defined.
Definition list_t_eq : forall t1 t2, (xList_t t1 = xList_t t2) -> t2 = t1.
  intros. injection H. intro. apply (eq_sym H0).
Defined.
Definition pair_eq_snd t1 t2 t3 t4 : xPair_t t3 t4 = xPair_t t1 t2 ->
                                     xPair_t t1 t2 = xPair_t t1 t4.
Proof. intros. injection H. intros ; subst. auto.
Defined.
Definition pair_eq_fst t1 t2 t3 : t1 = t2 -> xPair_t t1 t3 = xPair_t t2 t3.
Proof. intro. subst. auto. Defined.
Definition sum_eq tf th td tc : xSum_t tf th = xSum_t td tc -> xSum_t td th = xSum_t td tc.
  intro. injection H. intros. subst. auto.
Defined.
Lemma two_pair {w tb tc u2 u3} :
  (w = xPair_t tb tc) -> (w = xPair_t u2 u3) -> xPair_t tb tc = xPair_t tb u3.
  intros. subst. injection H0. intros ; subst. auto.
Defined.

(** Define some "smart" constructors for transforms that do the reductions
      as we build them. *)

Definition xid {t} : t ->> t := Xid.
Definition xzero {t} : xVoid_t ->> t := Xzero.
Definition xchar {t} (c:char_p) : t ->> xChar_t := Xchar c.
Definition xunit {t} : t ->> xUnit_t := Xunit.
Definition xempty {t1 t2} : t1 ->> xList_t t2 := Xempty.
Definition xinl {t1 t2} : t1 ->> xSum_t t1 t2 := Xinl.
Definition xinr {t1 t2} : t2 ->> xSum_t t1 t2 := Xinr.
Definition xfst {t1 t2} : xPair_t t1 t2 ->> t1 := Xfst.
Definition xsnd {t1 t2} : xPair_t t1 t2 ->> t2 := Xsnd.

Extraction Implicit xid [t].
Extraction Implicit xzero [t].
Extraction Implicit xchar [t].
Extraction Implicit xunit [t].
Extraction Implicit xempty [t1 t2].
Extraction Implicit xinl [t1 t2].
Extraction Implicit xinr [t1 t2].
Extraction Implicit xfst [t1 t2].
Extraction Implicit xsnd [t1 t2].

(** These next two functions reduce [Xpair Xfst Xsnd] to [Xid].
    It's incredibly tedious to propagate the right types and equations around,
    so I had to break it into two functions. *)
Definition xpair_fst ta tc (x2:ta->>tc):forall t1 t2,
  (ta = xPair_t t1 t2) -> ta ->>(xPair_t t1 tc) :=
  match x2 in ta->>tc return forall t1 t2,ta=xPair_t t1 t2 -> ta->>(xPair_t t1 tc) with
    | @Xsnd t3 t4 => fun t1 t2 H => xcoerce Xid (eq_sym H) (pair_eq_snd H)
    | Xzero => fun t1 t2 H => Xzero
    | x2 => fun t1 t2 H => Xpair (xcoerce Xfst (eq_sym H) (eq_refl _)) x2
  end.
Extraction Implicit xpair_fst [ta tc t1 t2].

Definition xpair_r ta tb tc (x2:ta ->> tc) : (ta ->> tb) -> ta ->> (xPair_t tb tc) :=
  match x2 in ta ->> tc return ta->>tb -> ta->>(xPair_t tb tc) with
    | @Xzero _ => fun x1 => Xzero
    | x2 => fun x1 => Xpair x1 x2
  end.
Extraction Implicit xpair_r [ta tb tc].

Definition xpair ta tb tc (x1:ta ->> tb) (x2:ta ->> tc) : ta ->> (xPair_t tb tc) :=
 match x1 in ta ->> tb return ta->>tc -> ta->>(xPair_t tb tc) with
   | Xfst => fun x2 => xpair_fst x2 (eq_refl _)
   | Xzero => fun x2 => Xzero
   | x1 => fun x2 => xpair_r x2 x1
  end x2.
Extraction Implicit xpair [ta tb tc].

(** The [xpair] optimization preserves meaning. *)
Lemma xpair_r_corr ta tb tc (x2:ta ->> tc) (x1:ta->>tb) v :
  xinterp (xpair_r x2 x1) v = xinterp (Xpair x1 x2) v.
Proof.
  destruct x2 ; simpl in * ; auto. destruct v.
Qed.

Lemma xpair_corr ta tb tc (x1:ta->>tb) (x2:ta->>tc) v :
  xinterp (xpair x1 x2) v = xinterp (Xpair x1 x2) v.
Proof.
  Ltac xpair_corr_simp :=
    match goal with | [ H : void |- _ ] => destruct H | _ => auto end.
  destruct x1 ; simpl in * ; auto ; intros ; xpair_corr_simp ;
  dependent destruction x2 ; simpl in * ; xpair_corr_simp.
  destruct v. auto.
Qed.

Definition xmatch_inl :forall t1 t2 tb tc (x2:tb->>tc),
  (tc=xSum_t t1 t2) -> xSum_t t1 tb ->> xSum_t t1 t2.
refine (fun t1 t2 tb tc x2 =>
  match x2 in tb->>tc return (tc=xSum_t t1 t2) -> xSum_t t1 tb ->> xSum_t t1 t2 with
    | Xinr => fun H => xcoerce Xid _ H
    | x2' => fun H => Xmatch Xinl (xcoerce x2' (eq_refl _) H)
  end
). injection H ; intros ; subst. auto.
Defined.
Extraction Implicit xmatch_inl [t1 t2 tb tc].

Definition xmatch_empty {tb t} (x2:tb->>t) :
  forall {t1 t2}, (t = xList_t t2) -> xSum_t t1 tb ->> xList_t t2 :=
  match x2 in tb->>t return forall {t1 t2}, (t = xList_t t2) -> xSum_t t1 tb ->> xList_t t2
  with
    | Xempty => fun t1 t2 H => Xempty
    | x2' => fun t1 t2 H => (Xmatch Xempty (xcoerce x2' eq_refl H))
  end.
Extraction Implicit xmatch_empty [tb t t1 t2].

(** This function and the two above implement the reduction
    [match x with inl a => inl a | inr b => inr b end = id]. *)
Definition xmatch ta tb tc (x1:ta->>tc) (x2:tb->>tc) : xSum_t ta tb ->> tc :=
  match x1 in ta->>tc return tb->>tc -> xSum_t ta tb ->> tc with
    | Xinl => fun x2' => xmatch_inl x2' (eq_refl _)
    | Xempty => fun x2' => xmatch_empty x2' (eq_refl _)
    | x1' => Xmatch x1'
  end x2.
Extraction Implicit xmatch [ta tb tc].

(** Correctness of eta-reduction for sums. *)
Lemma xmatch_corr ta tb tc (x1:ta->>tc) (x2:tb->>tc) v :
  xinterp (xmatch x1 x2) v = xinterp (Xmatch x1 x2) v.
Proof.
  destruct x1 ; simpl ; auto ; intros; dependent destruction x2 ; simpl ; destruct v ;
  auto.
Qed.

(** These next few functions implement specific reductions for when a particular
    combinator is composed with another.
*)
(** (f1, f2) o id = (f1, f2)
    (f1, f2) o (char c) = char c
    (f1, f2) o unit = unit
    (f1, f2) o empty = empty
    (f1, f2) o fst = f1
    (f1, f2) o snd = f2
    (f1, f2) o (g1, g2) = ((f1, f2) o g1, (f1, f2) o g2)
*)
Fixpoint xcomp_pair t21 t22 (x2:t21 ->> t22) :
  forall ta tb tc (x11:ta->>tb) (x12:ta->>tc), (xPair_t tb tc = t21) -> ta ->> t22 :=
    match x2 in t21 ->> t22 return
      forall ta tb tc (x11:ta->>tb) (x12:ta->>tc), (xPair_t tb tc = t21) -> ta ->> t22 with
      | Xid => fun ta tb tc x11 x12 H => xcoerce (Xpair x11 x12) (eq_refl _) H
      | Xchar c => fun ta tb tc x11 x12 H => Xchar c
      | Xunit => fun ta tb tc x11 x12 H => Xunit
      | Xempty => fun ta tb tc x11 x12 H => Xempty
      | Xfst =>
        fun ta tb tc x11 x12 H => xcoerce x11 (eq_refl _) (eq_pair_fst (eq_sym H))
      | Xsnd =>
        fun ta tb tc x11 x12 H => xcoerce x12 (eq_refl _) (eq_pair_snd (eq_sym H))
      | Xpair x21 x22 =>
        fun ta tb tc x11 x12 H =>
          xpair (xcomp_pair x21 x11 x12 H) (xcomp_pair x22 x11 x12 H)
      | x2' =>
        fun ta tb tc x11 x12 H =>
          Xcomp (xpair x11 x12) (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_pair [t21 t22 ta tb tc].

(** [xcomp_pair] is correct. *)
Lemma xcomp_pair_corr :
  forall t21 t22 (x2:t21->>t22) ta tb tc (x11:ta->>tb) (x12:ta->>tc) H v,
  xinterp (xcomp_pair x2 x11 x12 H) v =
  xinterp (Xcomp (Xpair x11 x12) (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  induction x2 ; simpl ; intros ; subst ; simpl ; auto ; try discriminate ;
  try rewrite xpair_corr ; simpl ; auto. rewrite IHx2_1. rewrite IHx2_2.
  auto. injection H ; intros ; subst. rewrite (proof_irrelevance _ H (eq_refl _)).
  auto. injection H ; intros ; subst ; rewrite (proof_irrelevance _ H (eq_refl _)). auto.
Qed.

(**  inl o id = inl
     inl o (char c) = char c
     inl o unit = unit
     inl o empty = empty
     inl o (match f1 f2) = f1
*)
Definition xcomp_inl t21 t22 (x2:t21 ->> t22) :
  forall ta tb, (xSum_t ta tb = t21) -> ta ->> t22 :=
    match x2 in t21->>t22 return
      forall ta tb, (xSum_t ta tb = t21) -> ta ->> t22 with
      | Xid => fun ta tb H => xcoerce Xinl (eq_refl _) H
      | Xchar c => fun ta tb H => Xchar c
      | Xunit => fun ta tb H => Xunit
      | Xempty => fun ta tb H => Xempty
      | Xmatch x21 x22 =>
        fun ta tb H => xcoerce x21 (eq_sum_fst H) (eq_refl _)
      | x2' =>
        fun ta tb H => Xcomp Xinl (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_inl [t21 t22 ta tb].

(** [xcomp_inl] is correct *)
Lemma xcomp_inl_corr t21 t22 (x2:t21->>t22) ta tb (H:xSum_t ta tb = t21) v:
  xinterp (xcomp_inl x2 H) v =
  xinterp (Xcomp Xinl (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; simpl ; auto. injection H ; intros ; subst.
  rewrite (proof_irrelevance _ H (eq_refl _)). auto.
Qed.

(**  inr o id = inr f
     inr o (char c) = char c
     inr o unit = unit
     inr o empty = empty
     inr o (match f1 f2) = f2
*)
Definition xcomp_inr t21 t22 (x2:t21 ->> t22) :
  forall ta tb, (xSum_t ta tb = t21) -> tb ->> t22 :=
    match x2 in t21->>t22 return
      forall ta tb, (xSum_t ta tb = t21) -> tb ->> t22 with
      | Xid => fun ta tb H => xcoerce Xinr (eq_refl _) H
      | Xchar c => fun ta tb H => Xchar c
      | Xunit => fun ta tb H => Xunit
      | Xempty => fun ta tb H => Xempty
      | Xmatch x21 x22 =>
        fun ta tb H => xcoerce x22 (eq_sum_snd H) (eq_refl _)
      | x2' =>
        fun ta tb H => Xcomp Xinr (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_inr [t21 t22 ta tb].

(** [xcomp_inr] is correct. *)
Lemma xcomp_inr_corr t21 t22 (x2:t21->>t22) ta tb (H:xSum_t ta tb = t21) v:
  xinterp (xcomp_inr x2 H) v =
  xinterp (Xcomp Xinr (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; simpl ; auto. injection H ; intros ; subst.
  rewrite (proof_irrelevance _ H (eq_refl _)). auto.
Qed.

(** empty o id = id
    empty o (char c) = char c
    empty o unit = unit
    empty o empty = empty
    empty o (map f) = empty
*)
Definition xcomp_empty t21 t22 (x2:t21 ->> t22) :
  forall ta tb, (xList_t tb = t21) -> ta ->> t22 :=
    match x2 in t21 ->> t22 return forall ta tb, (xList_t tb = t21) -> ta ->> t22 with
      | Xid => fun ta tb H => xcoerce Xempty (eq_refl _) H
      | Xchar c => fun ta tb H => Xchar c
      | Xunit => fun ta tb H => Xunit
      | Xempty => fun ta tb H => Xempty
      | x2' => fun ta tb H => Xcomp Xempty (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_empty [t21 t22 ta tb].

(** [xcomp_empty] is correct. *)
Lemma xcomp_empty_corr t21 t22 (x2:t21->>t22) ta tb (H:xList_t tb = t21) v :
  xinterp (xcomp_empty x2 ta H) v =
  xinterp (Xcomp Xempty (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; simpl ; auto.
Qed.

Definition xcons' t1 t (x2:t1->>t) :
  forall t2, (t = xList_t t2) -> (t1->>t2) -> (t1 ->> xList_t t2) :=
  match x2 in t1->>t return forall t2, (t = xList_t t2) -> (t1->>t2) -> (t1 ->> xList_t t2)
  with
    | Xzero => fun t2 H x1 => Xzero
    | x2' => fun t2 H x1 => Xcons x1 (xcoerce x2' eq_refl H)
  end.
Extraction Implicit xcons' [t1 t t2].

Lemma xcons'_corr t1 t (x2:t1->>t) :
  forall t2 (H:t=xList_t t2) x1 v,
    xinterp (xcons' x2 H x1) v = xinterp (Xcons x1 (xcoerce x2 eq_refl H)) v.
Proof.
  induction x2 ; intros ; auto. destruct v.
Qed.

Definition xcons t1 t2 (x1:t1->>t2) : (t1 ->> xList_t t2) -> (t1 ->> xList_t t2) :=
  match x1 in t1->>t2 return (t1 ->> xList_t t2) -> (t1 ->> xList_t t2) with
    | Xzero => fun _ => Xzero
    | x1' => fun x2 => xcons' x2 eq_refl x1'
  end.
Extraction Implicit xcons [t1 t2].

Lemma xcons_corr t1 t2 (x1:t1->>t2) (x2:t1 ->> xList_t t2) v :
  xinterp (xcons x1 x2) v = xinterp (Xcons x1 x2) v.
Proof.
  induction x1 ; try apply xcons'_corr. destruct v.
Qed.

(** (cons f1 f2) o id = (cons f1 f2)
    (cons f1 f2) o (char c) = char c
    (cons f1 f2) o unit = unit
    (cons f1 f2) o empty = empty
    (cons f1 f2) o (map f) = cons (f1 o f) (f2 o (map f))
*)
Definition xcomp_cons t21 t22 (x2:t21 ->> t22) :
  forall ta tb (x11:ta->>tb) (x12:ta->>xList_t tb), (xList_t tb = t21) -> ta ->> t22 :=
    match x2 in t21 ->> t22 return
      forall ta tb (x11:ta->>tb) (x12:ta->>xList_t tb), (xList_t tb = t21) -> ta ->> t22 with
      | Xid => fun ta tb x11 x12 H => xcoerce (Xcons x11 x12) (eq_refl _) H
      | Xchar c => fun ta tb x11 x12 H => Xchar c
      | Xunit => fun ta tb x11 x12 H => Xunit
      | Xempty => fun ta tb x11 x12 H => Xempty
      | x2' => fun ta tb x11 x21 H =>
        Xcomp (xcons x11 x21) (xcoerce x2' (eq_sym H) (eq_refl _))
    end.
Extraction Implicit xcomp_cons [t21 t22 ta tb].

(** [xcomp_cons] is correct. *)
Lemma xcomp_cons_corr t21 t22 (x2:t21->>t22) ta tb (x11:ta->>tb) (x12:ta->>xList_t tb) H v:
  xinterp (xcomp_cons x2 x11 x12 H) v = xinterp (Xcomp (Xcons x11 x12) (xcoerce x2 (eq_sym H) (eq_refl _))) v.
Proof.
  destruct x2 ; simpl ; intros ; subst ; try rewrite xcons_corr ; simpl ; auto.
Qed.

(** foldr f1 f2 zero => zero
      foldr f1 f2 empty => f1
      foldr f1 f2 (fhd::ftl) => (fhd, foldr f1 f2 ftl) ; f2
 *)
Fixpoint xfoldr' {t3 u} (x3:t3->>u) {struct x3} :
  forall {t1 t2}, (u = xList_t t1) -> (xPair_t t1 t2 ->> t2) -> (t3 ->> t2) -> t3 ->> t2 :=
  match x3 in t3->>u return
        forall {t1 t2}, (u = xList_t t1) -> (xPair_t t1 t2 ->> t2) -> (t3 ->> t2) -> t3 ->> t2
  with
    | Xempty => fun t1 t2 H x1 x2 => x2
    | Xcons x31 x32 =>
      fun t1 t2 H x1 x2 =>
        (Xcomp (xpair (xcoerce x31 eq_refl (list_t_eq (eq_sym H)))
                            (xfoldr' x32 eq_refl
                                     (xcoerce x1 (pair_eq_fst _ (list_t_eq H)) eq_refl) x2))
                     x1)
    | Xzero => fun t1 t2 H x1 x2 => Xzero
    | Xmatch x31 x32 =>
      fun t1 t2 H x1 x2 => Xmatch (xfoldr' x31 H x1 (Xcomp Xinl x2))
                                  (xfoldr' x32 H x1 (Xcomp Xinr x2))
    (* still missing the "eta" rule for xfoldr *)
    | x3' => fun t1 t2 H x1 x2 => Xfoldr x1 x2 (xcoerce x3' eq_refl H)
  end.
Extraction Implicit xfoldr' [t3 u t1 t2].

Lemma xfoldr'_corr t3 u (x3:t3->>u) :
  forall t1 t2 (H:u=xList_t t1) (x1:xPair_t t1 t2->>t2) (x2:t3->>t2)
         (v:xt_interp t3),
    xinterp (xfoldr' x3 H x1 x2) v =
    xinterp (Xfoldr x1 x2 (xcoerce x3 eq_refl H)) v.
Proof.
  induction x3 ; intros ; auto ; try (destruct v ; fail). injection H ; intros ;
  subst ; rewrite (proof_irrelevance _ H eq_refl) ; auto.
  subst. simpl. fold xt_interp. destruct v. rewrite IHx3_1. auto.
  rewrite IHx3_2 ; auto. injection H ; intros ; subst.
  rewrite (proof_irrelevance _ H eq_refl). simpl. fold xt_interp.
  rewrite xpair_corr. simpl. rewrite IHx3_2. auto.
Qed.

Definition xfoldr {t1 t2 t3}
           (x1:xPair_t t1 t2 ->> t2)(x2:t3 ->> t2)(x3:t3 ->> xList_t t1) : t3 ->> t2 :=
  xfoldr' x3 eq_refl x1 x2.

Lemma xfoldr_corr t1 t2 t3 (x1:xPair_t t1 t2 ->>t2)(x2:t3->>t2)(x3:t3->>xList_t t1) v :
  xinterp (xfoldr x1 x2 x3) v = xinterp (Xfoldr x1 x2 x3) v.
Proof.
  unfold xfoldr ; rewrite xfoldr'_corr ; auto.
Qed.
Extraction Implicit xfoldr [t1 t2 t3].

(** Cut eliminations on the right here:
     f o id = f
     f o (char c) = char c
     f o unit = unit
     f o empty = empty
*)
Fixpoint xcomp_r t21 t22 (x2:t21 ->> t22) : forall t11, t11 ->> t21 -> t11 ->> t22 :=
  match x2 in t21 ->> t22 return forall t11, t11 ->> t21 -> t11 ->> t22 with
    | Xid => fun t1 x1 => x1
    | Xchar c => fun t1 x1 => Xchar c
    | Xunit => fun t1 x1 => Xunit
    | Xempty => fun t1 x1 => Xempty
    | Xpair x21 x22 => fun t1 x1 => xpair (xcomp_r x21 x1) (xcomp_r x22 x1)
    | Xcons x21 x22 => fun t1 x1 => xcons (xcomp_r x21 x1) (xcomp_r x22 x1)
    | Xfoldr x21 x22 x23 => fun t1 x1 => xfoldr x21 (xcomp_r x22 x1) (xcomp_r x23 x1)
    | x2' => fun t1 x1 => Xcomp x1 x2'
  end.
Extraction Implicit xcomp_r [t21 t22 t11].

(** [xcomp_r] is correct. *)
Lemma xcomp_r_corr t21 t22 (x2:t21->>t22) t11 (x1:t11->>t21) v :
  xinterp (xcomp_r x2 x1) v = xinterp (Xcomp x1 x2) v.
Proof.
  induction x2 ; simpl ; intros ; auto.
  rewrite xpair_corr. simpl. rewrite IHx2_1. rewrite IHx2_2. auto.
  rewrite xcons_corr. simpl. rewrite IHx2_1. rewrite IHx2_2. auto.
  rewrite xfoldr_corr. simpl. fold xt_interp. rewrite IHx2_2. rewrite IHx2_3. auto.
Qed.

(** Optimization for composition of combinators, takes advantage
    of all of the specialized functions above, plus a few more:
     id o f = f
     zero o f = zero
     (f1 o f2) o f3 = f1 o (f2 o f3)
     (match f1 f2) o f3 = match (f1 o f3) (f2 o f3)
     plus the reductions in the functions above
*)
Fixpoint xcomp t11 t12 (x1:t11 ->> t12) : forall t22, t12 ->> t22 -> t11 ->> t22 :=
    match x1 in t11 ->> t12 return forall t22, t12 ->> t22 -> t11 ->> t22 with
      | Xid => fun t22 x2 => x2
      | Xzero => fun t22 x2 => Xzero
      | Xcomp x11 x12 =>
        fun t22 x2 => xcomp x11 (xcomp x12 x2)
      | Xpair x11 x12 =>
        fun t22 x2 => xcomp_pair x2 x11 x12 (eq_refl _)
      | Xinl => fun t22 x2 => xcomp_inl x2 (eq_refl _)
      | Xinr => fun t22 x2 => xcomp_inr x2 (eq_refl _)
      | Xempty => fun t22 x2 => xcomp_empty x2 _ (eq_refl _)
      | Xcons x11 x12 => fun t22 x2 => xcomp_cons x2 x11 x12 (eq_refl _)
      | Xmatch x11 x12 => fun t22 x2 => xmatch (xcomp x11 x2) (xcomp x12 x2)
      | x1' => fun t22 x2 => xcomp_r x2 x1'
    end.
Extraction Implicit xcomp [t11 t12 t22].

(** [xcomp] is correct. *)
Lemma xcomp_corr t1 t2 (x1:t1->>t2) t3 (x2:t2->>t3) v :
  xinterp (xcomp x1 x2) v = xinterp (Xcomp x1 x2) v.
Proof.
  induction x1 ; simpl in * ; intros ; auto ;
  match goal with
    | [ v : void |- _ ] => destruct v
    | [ |- xinterp (xcomp_r ?x2 ?x1) ?v = _ ] => apply (xcomp_r_corr x2 x1 v)
    | _ => idtac
  end.
  rewrite <- IHx1_2. rewrite <- IHx1_1. auto.
  apply xcomp_empty_corr. apply xcomp_pair_corr.  apply xcomp_inl_corr.
  apply xcomp_inr_corr. destruct v ; auto. rewrite xmatch_corr ; simpl ; auto.
  rewrite xmatch_corr ; simpl ; auto.
  apply xcomp_cons_corr.
Qed.

(** The [xcomp'] function is an extra loop to try to get more reductions
    to fire. *)
Fixpoint xcomp' tb tc (x2:tb->>tc) : forall ta, ta->>tb -> ta->>tc :=
  match x2 in tb->>tc return forall ta, ta->>tb -> ta->>tc with
    | Xcomp x21 x22 => fun ta x1 => xcomp' x22 (xcomp' x21 x1)
    | Xpair x21 x22 => fun ta x1 => xpair (xcomp' x21 x1) (xcomp' x22 x1)
    | Xcons x21 x22 => fun ta x1 => xcons (xcomp' x21 x1) (xcomp' x22 x1)
    | Xfoldr x21 x22 x23 => fun ta x1 => xfoldr x21 (xcomp' x22 x1) (xcomp' x23 x1)
    | x2' => fun ta x1 => xcomp x1 x2'
  end.
Extraction Implicit xcomp' [tb tc ta].

Lemma xcomp'_corr tb tc (x2:tb->>tc) ta (x1:ta->>tb) v :
  xinterp (xcomp' x2 x1) v = xinterp (Xcomp x1 x2) v.
Proof.
  induction x2 ; simpl ; intros ; auto ; try (rewrite xcomp_corr ; auto).
  rewrite IHx2_2. simpl. rewrite IHx2_1. auto. rewrite xpair_corr. simpl.
  rewrite IHx2_1. rewrite IHx2_2. auto. rewrite xcons_corr ; simpl ;
  rewrite IHx2_1 ; rewrite IHx2_2 ; auto.
  rewrite xfoldr_corr. simpl. rewrite IHx2_2. rewrite IHx2_3. auto.
Qed.

(** Optimize an [xform].  Most of the reductions are in the
    [Xcomp] (composition) case, though there are a couple of
    eta reductions for [Xpair] and [Xmatch] respectively. *)
Fixpoint xopt t1 t2 (x:t1 ->> t2) : t1 ->> t2 :=
  match x with
    | Xpair x1 x2 => xpair (xopt x1) (xopt x2)
    | Xmatch x1 x2 => xmatch (xopt x1) (xopt x2)
    | Xcomp x1 x2 => xcomp' (xopt x2) (xopt x1)
    | Xcons x1 x2 => xcons (xopt x1) (xopt x2)
    | Xfoldr x1 x2 x3 => xfoldr (xopt x1) (xopt x2) (xopt x3)
    | x' => x'
  end.
Extraction Implicit xopt [t1 t2].

(** [xopt] is correct. *)
Lemma xopt_corr t1 t2 (x:t1 ->> t2) : xinterp (xopt x) = xinterp x.
Proof.
  induction x ; simpl ; intros ; auto ; try (rewrite <- IHx ; auto) ;
    try (rewrite <- IHx1 ; rewrite <- IHx2 ; auto) ; apply extensionality ; intros.
  apply xcomp'_corr. apply xpair_corr. apply xmatch_corr. apply xcons_corr.
  rewrite <- IHx3 ; apply xfoldr_corr.
Qed.

(** Derived Transforms *)

(** Map a transform over a list. *)
Definition xmap {t1 t2} (f:t1 ->> t2) : xList_t t1 ->> xList_t t2 :=
  xopt (xfoldr (xcons (xcomp xfst f) xsnd) xempty xid).
Extraction Implicit xmap [t1 t2].

Lemma xmap_corr t1 t2 (f:t1 ->> t2) (vs:xt_interp (xList_t t1)) :
  xinterp (xmap f) = List.map (xinterp f).
Proof.
  eapply extensionality. intro x. unfold xmap. rewrite xopt_corr.
  induction x. auto. simpl. rewrite xcons_corr. simpl. rewrite xcomp_r_corr. simpl.
  rewrite <- IHx. auto.
Qed.

(** Append a pair of lists. *)
Definition xapp {t} : xPair_t (xList_t t) (xList_t t) ->> xList_t t :=
  xopt (xfoldr (xcons xfst xsnd) xsnd xfst).
Extraction Implicit xapp [t].

Lemma xapp_corr t (vs1 vs2: xt_interp (xList_t t)) :
  xinterp xapp (vs1,vs2) = vs1 ++ vs2.
Proof.
  unfold xapp. rewrite xopt_corr.
  induction vs1. simpl. auto. simpl. rewrite <- IHvs1. auto.
Qed.

(** Similar to Map but draws from the environment. *)
Definition xmapenv {t1 t2 t3} (f:xPair_t t1 t2 ->> t3) : xPair_t t1 (xList_t t2)->>xList_t t3 :=
  xopt (xcomp (xfoldr (xpair (xcomp xsnd xfst)
                       (xcons (xcomp (xpair (xcomp xsnd xfst) xfst) f)
                              (xcomp xsnd xsnd))) (xpair xfst xempty) xsnd) xsnd).
Extraction Implicit xmapenv [t1 t2 t3].

Lemma xmapenv_corr {t1 t2 t3} (f:xPair_t t1 t2->>t3) v :
  xinterp (xmapenv f) v = List.map (fun x => xinterp f (fst v,x)) (snd v).
Proof.
  assert (H: xinterp (xmapenv f) v =
          xinterp (Xcomp (Xfoldr (Xpair (Xcomp Xsnd Xfst)
                                        (Xcons (Xcomp (xpair (Xcomp Xsnd Xfst) Xfst) f)
                                               (Xcomp Xsnd Xsnd))) (Xpair Xfst Xempty) Xsnd)
                         Xsnd) v).
    unfold xmapenv. rewrite xopt_corr. rewrite xcomp_corr.
    simpl. repeat f_equal.
    eapply extensionality; intros.
    eapply extensionality; intros.
    rewrite xpair_r_corr.
    simpl.
    rewrite xcons_corr.
    f_equal.
    simpl.
    rewrite xcomp_pair_corr.
    auto.
  rewrite H. clear H.
  destruct v. induction x0. auto.
  simpl in *. rewrite IHx0.
  replace (fst
             (fold_right
                (fun (a0 : xt_interp t2) (b : xt_interp t1 * list (xt_interp t3)) =>
                   (fst b, xinterp f (fst b, a0) :: snd b))
                (x, nil) x0)) with x ; auto.
  clear IHx0. induction x0 ; auto.
Qed.

(** Flatten a list of lists. *)
Definition xflatten {t} : xList_t (xList_t t) ->> xList_t t :=
  xopt (xfoldr xapp xempty xid).
Extraction Implicit xflatten [t].

Lemma xflatten_corr {t} (vs : xt_interp (xList_t (xList_t t))) :
  xinterp xflatten vs =
  List.fold_right (fun a b => List.fold_right (fun x y => x::y) b a) nil vs.
Proof.
  unfold xflatten. rewrite xopt_corr.
  induction vs ; simpl ; fold xt_interp in *; auto.
Qed.

Lemma xflatten_corr2 {t} (vs: xt_interp (xList_t (xList_t t))) :
  xinterp xflatten vs = Coqlib.list_flatten vs.
Proof.
  rewrite xflatten_corr. fold xt_interp.
  assert ((fun a b : list (xt_interp t) =>
            fold_right (fun x y => x :: y) b a) = @List.app (xt_interp t)).
  apply Coqlib.extensionality. intro. apply Coqlib.extensionality. intro y.
  generalize x ; clear x. induction y. induction x ; auto.
  simpl. rewrite IHx. auto. induction x. auto. simpl. rewrite IHx. auto.
  rewrite H. auto.
Qed.

(** A singleton list *)
Definition xsingleton {t} : t ->> xList_t t := @xcons t t xid xempty.
Extraction Implicit xsingleton [t].

(** Compute the cross product of two lists.  For instance, the
      cross product of (1::2::nil, true::false::nil) is
      (1,true)::(1,false)::(2,true)::(2,false)::nil.
 *)
Definition xcross {t1 t2} : xPair_t (xList_t t1) (xList_t t2) ->> xList_t (xPair_t t1 t2) :=
  xopt (xcomp (xcomp (xpair xsnd xfst)
                     (xmapenv (xcomp (xpair xsnd xfst) (xmapenv xid)))) xflatten).
Extraction Implicit xcross [t1 t2].

Lemma xcross_corr t1 t2 (p : xt_interp (xPair_t (xList_t t1) (xList_t t2))) :
  xinterp xcross p =
  Coqlib.list_flatten (List.map (fun x => List.map (fun y => (x,y)) (snd p)) (fst p)).
Proof.
  Opaque xflatten xmapenv xpair.
  destruct p. fold xt_interp. unfold xcross. rewrite xopt_corr.
  repeat rewrite xcomp_corr. simpl. repeat rewrite xcomp_corr. simpl.
  rewrite xflatten_corr2. rewrite xmapenv_corr. fold xt_interp.
  repeat f_equal.
  apply Coqlib.extensionality. intro. rewrite xcomp_corr. simpl.
  rewrite xmapenv_corr. fold xt_interp. simpl.
  f_equal.
Qed.

Lemma xcross_corr2 {t1 t2} (vs: xt_interp (xPair_t (xList_t t1) (xList_t t2))):
  xinterp xcross vs = List.list_prod (fst vs) (snd vs).
Proof. rewrite xcross_corr. fold xt_interp.
  destruct vs as [l1 l2].
  induction l1.
    simpl. induction l2; auto.
    simpl in *. f_equal. trivial.
Qed.

(** Lift a continuation to work on a list of values, and then
      concatenate all of the results. *)
Definition xthen {t1 t2 t3} (f1: t1 ->> xList_t t2) (f2: t2 ->> xList_t t3) :
  t1 ->> xList_t t3 :=
  xopt (xcomp f1 (xcomp (xmap f2) xflatten)).
Extraction Implicit xthen [t1 t2 t3].

(** Like cross product, but parameterized by generators [f1] and [f2]. *)
Definition xcrossmap {t1 t2 t3 t4} (f1 : t1 ->> xList_t t3) (f2 : t2 ->> xList_t t4) :
  (xPair_t t1 t2) ->> xList_t (xPair_t t3 t4) :=
  xopt (xcomp (xpair (xcomp xfst f1) (xcomp xsnd f2)) xcross).
Extraction Implicit xcrossmap [t1 t2 t3 t4].

(** A simplification tactic for [xform]s *)
Ltac xinterp_simpl :=
  repeat match goal with
    | [|- context[xcomp ?X1 ?X2]] => rewrite (xcomp_corr X1 X2); simpl
    | [H:context[xcomp ?X1 ?X2] |- _] =>
      rewrite (xcomp_corr X1 X2) in H; simpl in H
    | [|- context[xinterp (xpair _ _) _]] => rewrite xpair_corr; simpl
    | [H:context[xinterp (xpair _ _) _] |- _] =>
      rewrite xpair_corr in H; simpl in H
    | [|- context[xinterp xcross _]] => rewrite xcross_corr2; simpl
    | [H:context[xinterp xcross _] |- _] =>
      rewrite xcross_corr2 in H; simpl in H
    | [|- context [xinterp xapp (_,_)]] => rewrite xapp_corr; simpl
    | [H:context [xinterp xapp (_,_)] |- _] =>
      rewrite xapp_corr in H; simpl in H
    | [|- context [xinterp (xmap _) ?V]] =>
      rewrite (@xmap_corr _ _ _ V); simpl
    | [H:context [xinterp (xmap _) ?V] |- _] =>
      rewrite (@xmap_corr _ _ _ V) in H; simpl in H
    | [|- context[xinterp xflatten _]] => rewrite xflatten_corr2; simpl
    | [H:context[xinterp xflatten _] |- _] =>
      rewrite xflatten_corr2 in H; simpl in H
  end.

(** Some utilities for viewing and seeing the size of Xforms. *)

Require Import Coq.Strings.String.
Local Open Scope string_scope.

Definition emit (s:string) (a:list string) : list string := s :: a.
Definition seq {A} (c1 c2:A -> A)(a:A): A :=
  c2 (c1 a).
Notation "c1 ;; c2" := (seq c1 c2) (right associativity, at level 84).

Fixpoint show_xform' t1 t2 (x:t1->>t2) : list string -> list string :=
  match x with
    | Xid => emit "id"
    | Xzero => emit "Z"
    | Xcomp x1 x2 =>
      emit "(" ;; (show_xform' x1) ;; emit ";" ;; (show_xform' x2) ;; emit ")"
    | Xchar c => emit (show_char c)
    | Xunit => emit "U"
    | Xempty => emit "[]"
    | Xpair x1 x2 =>
      emit "(" ;; (show_xform' x1) ;; emit "," ;; (show_xform' x2) ;; emit ")"
    | Xfst => emit "fst"
    | Xsnd => emit "snd"
    | Xinl => emit "inl"
    | Xinr => emit "inr"
    | Xmatch x1 x2 =>
      emit "[" ;; (show_xform' x1) ;; emit "|" ;; (show_xform' x2) ;; emit "]"
    | Xcons x1 x2 =>
      emit "(" ;; (show_xform' x1) ;; emit "::" ;; (show_xform' x2) ;; emit ")"
    | Xfoldr x1 x2 x3 =>
      emit "fold(" ;; (show_xform' x1) ;; emit "," ;; (show_xform' x2) ;;
           emit "," ;; (show_xform' x3) ;; emit ")"
  end.
Extraction Implicit show_xform' [t1 t2].

Definition show_xform t1 t2 (x:t1->>t2) : string :=
  let ss := List.rev (show_xform' x nil) in
  List.fold_right (fun x y => x ++ y) "" ss.
Extraction Implicit show_xform [t1 t2].

Definition inc (n:nat) : nat := plus 1 n.

Fixpoint xform_count' t1 t2 (x:t1->>t2) : nat->nat :=
  match x with
    | Xid => inc
    | Xzero => inc
    | Xcomp x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xchar _ => inc
    | Xunit => inc
    | Xempty => inc
    | Xpair x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xfst => inc
    | Xsnd => inc
    | Xinl => inc
    | Xinr => inc
    | Xmatch x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xcons x1 x2 => inc ;; (xform_count' x1) ;; (xform_count' x2)
    | Xfoldr x1 x2 x3 =>
      inc ;; (xform_count' x1) ;; (xform_count' x2) ;; (xform_count' x3)
  end.
Extraction Implicit xform_count' [t1 t2].

Definition xform_count t1 t2 (x:t1->>t2) : nat := xform_count' x 0.
Extraction Implicit xform_count [t1 t2].