(** Author: Christian Doczkal  *)
From Coq Require Import Omega.
From mathcomp Require Import all_ssreflect.
From RegLang Require Import misc setoid_leq languages dfa myhill_nerode two_way.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** ** Shepherdson Construction for 2NFAs *)

(** Preliminaries *)

Lemma contraN (b : bool) (P : Prop) : b -> ~~ b -> P. by case b. Qed.

Lemma inord_inj n m : n <= m -> injective (@inord m \o @nat_of_ord n.+1).
Proof.
  move => Hnm k k' /= /(f_equal (@nat_of_ord _)) E. apply/ord_inj.
  rewrite !inordK // in E; exact: leq_trans (ltn_ord _) _.
Qed.

(** Lemmas for character lookups on composite words *)

Lemma tnthL (T:eqType) (x z : seq T) (i : 'I_(size x)) (j : 'I_(size (x++z))) :
  i = j :> nat -> tnth (in_tuple x) i = tnth (in_tuple (x++z)) j.
Proof.
  move => e. pose a := tnth (in_tuple x) i.
  by rewrite !(tnth_nth a) /= -e nth_cat ltn_ord.
Qed.

Lemma tnthR (T:eqType) (x z : seq T) (i : 'I_(size z)) (j : 'I_(size (x++z))) :
  size x + i = j -> tnth (in_tuple z) i = tnth (in_tuple (x++z)) j.
Proof.
  move => e. pose a := tnth (in_tuple z) i.
  by rewrite !(tnth_nth a) /= -e nth_cat ltnNge leq_addr /= addKn.
Qed.

(** Wrapper for omega that uses ssreflects operators on [nat] *)

Ltac norm := rewrite ?(size_cat,cats0); simpl in *.
Ltac normH := match goal with [ H : is_true (_ <= _) |- _] => move/leP : H end.
Ltac somega :=
  try (try (apply/andP; split); apply/leP; repeat normH; norm ; rewrite ?addnE /addn_rec ; intros; omega).

Section NFA2toAFA.

  Variables (char : finType) (M : nfa2 char).
  Implicit Types (x y z w v : word char).

  (** We fix some 2NFA [M]. Instead of directly defining a DFA for [M], we
  instantiate the construction of DFAs from classifiers. This means that we have
  to give a finite type [Q] and define a function [T : word char -> Q] which is
  right congruent and refines the language of [M]. We take [Q] to be the type of
  tables or black-box results for [M]. *)

  Definition table := ({set M} * {set M * M})%type.

  (** We define the mapping from [word char] to [table] using a restriction of the
  step relation. The stop relation [srel k x] behaves like [step x] except that
  it does not continue if the head is at position [k]. *)

  Definition srel (k:nat) x (c d : nfa2_config M x) := (step M x c d) && (k != c.2).
  Arguments srel : clear implicits.

  Lemma srel_step k w : subrel (srel k w) (step M w).
  Proof. by move => c d /= => /andP[->]. Qed.

  Lemma srel_step_max x : srel (size x).+2 x =2 step M x.
  Proof. move => c d /=. by rewrite /srel neq_ltn ltn_ord orbT andbT. Qed.

  Definition Tab x : table :=
    ([set q | connect (srel (size x).+1 x) (nfa2_s M, ord1) (q,ord_max)],
     [set pq | connect (srel (size x).+1 x) (pq.1,inord (size x)) (pq.2,ord_max)]).

  (** To show that [Tab] is right-congruent and refines the language of [M], we
  need to make use of the fact that [M] moves its head only one step at a
  time. In particular, this allows us to split runs starting with head position
  [i] and ending at head position [j] at any position [k] in beteen. *)

  Lemma srelLR k x p i q j : srel k x (p,i) (q,j) ->
    j.+1 = i :> nat \/ j = i.+1 :> nat.
  Proof. move/srel_step. case/orP => /andP [_ /eqP ->]; tauto. Qed.

  Lemma srel1 k x c d : srel k x c d -> d.2 <= c.2.+1.
  Proof. move: c d => [p i] [q j] /srelLR [<-|->] //=. by somega. Qed.

  Lemma srelSr k' k x (c d : nfa2_config M x) : c.2 < k ->
    srel k x c d = srel (k+k') x c d.
  Proof. move => lt_k. by rewrite /srel !neq_ltn ltn_addr lt_k ?orbT. Qed.

  Lemma srelS k x p q (i j : pos x) m : i <= k ->
     connect (srel k x) (p,i) (q,j) -> connect (srel (k+m) x) (p,i) (q,j).
  Proof.
    move => H /connectP [cs].
    elim: cs p i H => [/= p i H _ [-> ->] //|[p' i'] cs IH p i H /= /andP [s pth] l].
    have Hk: i < k. case/andP : s => _ /= s. by rewrite ltn_neqAle H eq_sym s.
    apply: (connect_trans (y := (p',i'))) (connect1 _) _; first by rewrite -srelSr.
    apply: IH => //. move/srel1 : s Hk => /= s. exact: leq_trans.
  Qed.

  Lemma srel_mid_path (k k' : nat) x (i j : pos x) (p q : M) cs :
    i <= k <= j -> path (srel k' x) (p,i) cs -> (q,j) = last (p,i) cs ->
    exists p' cl cr, [/\ cs = cl ++ cr, (p',inord k) = last (p,i) cl & path (srel k x) (p,i) cl].
  Proof.
    move: cs p i. apply: (size_induction (measure := size)) => cs IH p i /andP [H1 H2].
    case: (boolP (i == k :> nat)) => Ei.
    - exists p. exists [::]. exists cs. by rewrite -[i]inord_val (eqP Ei).
    - destruct cs as [|c cs] => [_ /= [_ E]|/= /andP [s p1] p2]; subst.
      + by rewrite eqn_leq H1 H2 in Ei.
      + have Hi: i < k by rewrite ltn_neqAle Ei H1.
        have mid: c.2 <= k <= j by rewrite (leq_trans (srel1 s)).
        case: (IH cs _ c.1 _ mid) ; rewrite -?surjective_pairing //.
        move => p' [cl] [cr] [C1 C2 C3]. exists p'. exists (c::cl). exists cr.
        rewrite /= -C1 C3 andbT. split => //. rewrite /srel /= eq_sym Ei andbT.
        exact: srel_step s.
  Qed.

  Lemma srel_mid (k k' : nat) x (i j : pos x) (p q : M) : i <= k <= j -> k <= k' ->
    reflect (exists2 p', connect (srel k x) (p,i) (p',inord k) & connect (srel k' x) (p',inord k) (q,j))
            (connect (srel k' x) (p,i) (q,j)).
  Proof.
    move => H X. apply: (iffP idP).
    - case/connectP => cs c1 c2. case: (srel_mid_path H c1 c2) => [p'] [cl] [cr] [Ecs L C].
      subst cs. rewrite cat_path last_cat -L in c1 c2. case/andP : c1 => ? c1. exists p'.
      + apply/connectP. by exists cl.
      + apply/connectP. by exists cr.
    - case/andP: H => H1 H2 [p']. move/(srelS (k'-k) H1). rewrite subnKC //. exact: connect_trans.
  Qed.

  Lemma readL x z (p:M) (k : pos x) : k != (size x).+1 :> nat ->
    read p (inord k : pos (x++z)) = read p k.
  Proof.
    move => Hk. rewrite /read. case: (ord2P k) => [/eqP->|E|i Hi].
    - by rewrite /= -inord0 ord2P0.
    - apply: contraN Hk. by rewrite (eqP E).
    - have oi : i < size (x++z) by rewrite size_cat ltn_addr.
      have H_eq: (Ordinal oi).+1 = (inord k : pos (x++z)). by rewrite -Hi inordK // ; somega.
      by rewrite (ord2PC H_eq) -(tnthL (i := i)).
  Qed.

  Section CompositeWord.
    Variables (x z : word char).

    (** We first show that runs on [x] that do not cross the boundary between
    [x] and [z] do not depend on [z]. *)

    Lemma srelL (i j : pos x) p q :
      srel (size x).+1 x (p,i) (q,j) = srel (size x).+1 (x++z) (p,inord i) (q,inord j).
    Proof.
      case: (boolP (i == (size x).+1 :> nat)) => Hi.
      - rewrite /srel (eqP Hi) /= inordK ?eqxx //= ?andbF //; somega.
      - have Hi' : i < (size x).+1. by rewrite ltn_neqAle Hi -ltnS ltn_ord.
        rewrite /srel /step readL // !inordK //; somega.
        move: (ltn_ord j) => ?. somega.
    Qed.

    Lemma runL (i j : pos x) p q :
      connect (srel (size x).+1 x) (p,i) (q,j) =
      connect (srel (size x).+1 (x++z)) (p,inord i) (q,inord j).
    Proof.
      pose f (c : nfa2_config M x) : nfa2_config M (x ++ z) := (c.1, inord c.2).
      rewrite -[(p,inord i)]/(f (p,i)) -[(q,inord j)]/(f (q,j)).
      apply: connect_transfer => //.
      - move => {p q i j} [p i] [q j] /= [->] /inord_inj.
        case/(_ _)/Wrap => [|->//]. somega.
      - move => [? ?] [? ?]. rewrite /f /=. exact: srelL.
      - move => {p q i j} [p i] [q j] step. exists (q,inord j).
        rewrite /f /= inordK ?inord_val //.  move: (srel1 step) => /= Hs.
        case/andP : step => /= _ Hi. rewrite (leqRW Hs) ltn_neqAle eq_sym Hi /=.
        by rewrite inordK ltnS ?leq_ord // (leqRW (leq_ord i)) ltnS size_cat leq_addr.
    Qed.

    (** This entails, that the behaviour of [M] starting from the endpoints of
    [x] is also independent of [z]. Note that the direction from right to left
    makes use of lemma [term_uniq] *)

    Lemma Tab1P q : q \in (Tab x).1
        <-> connect (srel (size x).+1 (x++z)) (nfa2_s M,ord1) (q,inord (size x).+1).
    Proof. by rewrite /Tab inE runL /= -[ord1]inord_val. Qed.

    Lemma Tab2P p q : (p,q) \in (Tab x).2
        <-> connect (srel (size x).+1 (x++z)) (p,inord (size x)) (q,inord (size x).+1).
    Proof. by rewrite inE runL /= inordK. Qed.

    (** Dually, steps on the right of [x++z] do not depend on [x], if they do not
    cross the boundary between [x] and [z]. *)

    Lemma readR (q:M) k : k != 0 -> k < (size z).+2 ->
       read q (inord k : pos z) = read q (inord (size x + k) : pos (x++z)).
    Proof.
      move => Hk0 Hk. rewrite /read. case: (ord2P _) => [H|H|i Hi].
      - apply: contraN Hk0.
        move/eqP/(f_equal (@nat_of_ord _)) : H => /=. by rewrite inordK // => ->.
      - by rewrite -[k](@inordK (size z).+1) ?(eqP H) //= addnS -size_cat -inord_max ord2PM.
      - have Hi' : size x + i < size (x ++ z) by rewrite size_cat ltn_add2l.
        have X: (Ordinal Hi').+1 = (inord (size x + k) : pos (x ++ z)).
          by rewrite /= -addnS Hi !inordK //; somega.
        by rewrite (ord2PC X) -(tnthR (i := i)).
    Qed.

    Lemma srelR (m k k' : nat) p p' : k != 0 -> k < (size z).+2 -> k' < (size z).+2 ->
        srel ((size x).+1 + m) (x++z) (p,inord (size x + k)) (p',inord (size x + k'))
      = srel m.+1 z (p,inord k) (p',inord k').
    Proof.
      move => Hk0 Hk Hk'. rewrite /srel /= !inordK ?addSnnS ?eqn_add2l //; somega.
      case: (_ != _); rewrite ?andbT ?andbF // /step -?readR //.
      rewrite !inordK //; somega. by rewrite -!addnS !eqn_add2l.
    Qed.

    Lemma srelRE m k p c : k < (size z).+2 -> k != 0 ->
      srel m (x++z) (p,inord (size x + k)) c ->
      exists q k', k' < (size z).+2 /\ c = (q,inord (size x + k')).
    Proof.
      move: k c => [//|k] [q j] Hk _ /srelLR [/eqP C|/eqP C];
        exists q; rewrite inordK addnS ?eqSS in C; somega.
      - exists k. by rewrite ltnW // -[j]inord_val (eqP C).
      - exists k.+2. rewrite !addnS -[j]inord_val (eqP C). split => //.
        rewrite eqn_leq in C. case/andP : C => _ C.
        move: (leq_ltn_trans C (ltn_ord j)).
        by rewrite size_cat -!addnS leq_add2l.
    Qed.

  End CompositeWord.

  (** The main lemma used both in the proof of right-congruence and language
  refinement states that as long as the black-box results for [x] and [y]
  agreee, runs starting and ending on the right of composite words [x++z] and
  [y++z] behave the same even if they cross the boundaries. *)

  Lemma runR x y z p q (i j: nat) k :
    Tab x = Tab y -> i <= (size z).+1 -> 0 < j <= (size z).+1 ->
    connect (srel ((size x).+1 + k) (x++z)) (p,inord (size x + i)) (q,inord (size x + j)) ->
    connect (srel ((size y).+1 + k) (y++z)) (p,inord (size y + i)) (q,inord (size y + j)).
  Proof.
    move => Tab_eq Hi /andP [Hj0 Hj]. case/connectP => cs. move: cs i Hi p.
    apply: (size_induction (measure := size)) => /= cs IH i Hi p.
    case: (boolP (i == 0)) => Hi0.
    - rewrite (eqP Hi0) !addn0 => p1 p2.
      case: (srel_mid_path (k := (size x).+1) _ p1 p2); try solve [rewrite inordI; somega].
      apply/andP; split; rewrite !inordK; somega. move => p' [cl] [cr] [Ecs Lcl Pcl].
      apply/(@srel_mid (size y).+1) ; try solve [rewrite !inordK; somega|rewrite -addn1; somega].
      + exists p'. apply/Tab2P. rewrite -Tab_eq. apply/Tab2P. by apply/connectP; exists cl.
      + subst cs. rewrite -[_.+1 as X in inord X]addn1.
        apply: (IH cr) => {IH} //; somega.
        * destruct cl as [|c cs]; simpl in *. case: Lcl => _.
          -- move/(f_equal (@nat_of_ord _)); rewrite ?inordK; intros; somega.
          -- by  rewrite[size (cs ++ cr)]size_cat -addnS leq_addl.
        * rewrite cat_path -Lcl addn1 in p1 *. by case/andP : p1.
        * by rewrite p2 last_cat -Lcl addn1.
    - destruct cs as [|c cs]; simpl in *.
      + move => _ [-> /(f_equal (@nat_of_ord _))/eqP].
        rewrite !inordK ?eqn_add2l ?size_cat -?addnS ?leq_add2l // => /eqP ->.
        exact: connect0.
      + case/andP => P1 P2 L. case/srelRE: (P1) => // p' [ip] [Hip ?]; subst.
        rewrite srelR // -(@srelR y z) // in P1. apply: connect_trans (connect1 P1) _.
        exact: (IH cs).
  Qed.

  (** Variant of the lemma above, that generales equality subgoals *)
  Lemma runR_eq x y z p q (i j: nat) k xk xi xj yk yi yj :
    Tab x = Tab y -> i <= (size z).+1 -> 0 < j <= (size z).+1 ->
    xk = (size x).+1 + k -> xi = size x + i -> xj = size x + j ->
    yk = (size y).+1 + k -> yi = size y + i -> yj = size y + j ->
    connect (srel xk (x++z)) (p,inord xi) (q,inord xj) ->
    connect (srel yk (y++z)) (p,inord yi) (q,inord yj).
  Proof. move => ? ? ? ? ? ? ? ? ?. subst. exact: runR. Qed.

  Lemma Tab_refines : refines (nfa2_lang M) Tab.
  Proof.
    move => x y E.
    wlog suff W: x y E / (x \in nfa2_lang M) -> (y \in nfa2_lang M).
    { by apply/idP/idP; exact: W. }
    case/exists_inP => f Hq1 Hq2. apply/exists_inP; exists f => //. move: Hq2.
    rewrite -[x]cats0 -[y]cats0 -!(eq_connect (@srel_step_max _)).
    case/(@srel_mid (size x).+1); somega => q /Tab1P q1 q2.
    apply/(@srel_mid (size y).+1); somega.
    - exists q. apply/Tab1P. by rewrite -E.
    - move: q2 => {q1}. rewrite !inord_max.
      apply: (runR_eq (i := 1) (j := 1) (k := 1)); rewrite ?addn1 ?cats0 //=.
  Qed.

  Lemma Tab_rc : right_congruent Tab.
  Proof.
    move => x y a E.
    have Tab2 : (Tab (x ++ [:: a])).2 = (Tab (y ++ [:: a])).2.
    { apply/setP => [[p q]]. rewrite /Tab !inE /= !inord_max.
      apply/idP/idP; apply: (runR_eq (i := 1) (j := 2) (k := 1)); by rewrite ?size_cat ?addn1 ?addn2. }
    suff ?: (Tab (x ++ [:: a])).1 = (Tab (y ++ [:: a])).1 by congr pair.
    apply/setP => q /=. rewrite !inE.
    pose C x := connect (srel (size (x ++ [:: a])).+1 (x ++ [:: a])) (nfa2_s M, ord1) (q, ord_max).
    wlog suff W: x y E Tab2 / C x -> C y; [by apply/idP/idP; exact: W|].
    case/(@srel_mid (size x).+1); somega => p /Tab1P p1 p2.
    apply/(@srel_mid (size y).+1); somega.
    exists p; first by apply/Tab1P; rewrite -E. move: p2.
    rewrite -![_.+1 as X in inord X]addn1 -[1]/(size [:: a]) -!size_cat.
    rewrite !(@runL _ [::]) !inordK; somega. move/Tab2P => p2. by apply/Tab2P; rewrite -Tab2.
  Qed.

  Definition nfa2_to_classifier : classifier_for (nfa2_lang M) :=
    {| cf_classifier := Classifier Tab; cf_congruent := Tab_rc; cf_refines := Tab_refines |}.

  Theorem nfa2_to_dfa :
    { A : dfa char | dfa_lang A =i nfa2_lang M & #|A| <= 2 ^ (#|M| ^ 2 + #|M|) }.
  Proof.
    exists (classifier_to_dfa (nfa2_to_classifier)); first exact: classifier_to_dfa_correct.
    rewrite card_sub (leqRW (max_card _)) [#|_|]/=.
    by rewrite card_prod expnD mulnC leq_mul //= card_set // card_prod -mulnn.
  Qed.

End NFA2toAFA.

(** If M is determinististic, the size bound on the constructed 2DFA improves
  to [(#|M|.+1)^(#|M|.+1)] *)

Arguments srel [char] M k x c d.

(** ** Imropoved Bound for Translation of 2DFAs to DFAs *)

Section DFA2toAFA.
  Variables (char : finType) (M : dfa2 char).

  Lemma functional_srel k w : functional (srel M k w).
  Proof. apply: functional_sub (@srel_step _ _ k w). exact: step_fun. Qed.

  Lemma term_srel k x q (H: k < (size x).+2) : terminal (srel M k x) (q,inord k).
  Proof. move => c /=. by rewrite /srel inordK // ?eqxx /= andbF. Qed.

  Lemma Tab1_uniq x p q : p \in (Tab M x).1 -> q \in (Tab M x).1 -> p = q.
  Proof.
    rewrite !inE => H1 H2. suff: (p,@ord_max (size x).+1) = (q,ord_max) by case.
    apply: term_uniq H1 H2; rewrite ?inord_max; auto using term_srel, functional_srel.
  Qed.

  Lemma Tab2_functional x p q r : (p,q) \in (Tab M x).2 -> (p,r) \in (Tab M x).2 -> q = r.
  Proof.
    rewrite !inE => /= H1 H2. suff: (q,@ord_max (size x).+1) = (r,ord_max) by case.
    apply: term_uniq H1 H2; rewrite ?inord_max; auto using term_srel, functional_srel.
  Qed.

  Definition Tab' := image_fun (@Tab_rc _ M).

  Lemma image_rc : right_congruent Tab'.
  Proof. move => x y a /Sub_eq E. apply/Sub_eq. exact: Tab_rc. Qed.

  Lemma image_refines : refines (nfa2_lang M) Tab'.
  Proof. move => x y /Sub_eq E. exact: Tab_refines. Qed.

  Definition dfa2_to_myhill :=
    {| cf_classifier := Classifier Tab';
       cf_congruent := image_rc;
       cf_refines := image_refines |}.

  Lemma det_range : #|{:image_type (@Tab_rc _ M)}| <= (#|M|.+1)^(#|M|.+1).
  Proof.
    pose table' := (option M * {ffun M -> option M})%type.
    apply: (@leq_trans #|{: table'}|); last by rewrite card_prod card_ffun !card_option expnS.
    pose f (x : image_type (@Tab_rc _ M)) : table' :=
      let (b,_) := x in ([pick q | q \in b.1],[ffun p => [pick q | (p,q) \in b.2]]).
    suff : injective f by apply: card_leq_inj.
    move => [[a1 a2] Ha] [[b1 b2] Hb] [E1 /ffunP E2]. apply/Sub_eq.
    move: Ha Hb => /dec_eq /= [x Hx] /dec_eq [y Hy].
    rewrite [Tab M x]surjective_pairing [Tab M y]surjective_pairing !xpair_eqE in Hx Hy.
    case/andP : Hx => /eqP ? /eqP ?. case/andP : Hy => /eqP ? /eqP ?. subst. f_equal.
    - apply/setP => p. case: (pickP _) E1 => q1; case: (pickP _) => q2 //; last by rewrite q1 q2.
      move => {E2} H1 H2 [?]; subst.
      wlog suff S : p x y H1 H2 / (p \in (Tab M x).1) -> (p \in (Tab M y).1).
      { apply/idP/idP; exact: S. }
      move => H. by rewrite (@Tab1_uniq x p q2).
    - apply/setP => [[p q]]. move: E2 {E1} => /(_ p). rewrite !ffunE.
      case: (pickP _) => r1; case: (pickP _) => r2 //; last by rewrite r1 r2.
      move => H1 H2 [?]; subst. apply/idP/idP => ?.
      + by rewrite (@Tab2_functional x p q r2).
      + by rewrite (@Tab2_functional y p q r2).
  Qed.

  Theorem dfa2_to_dfa :
    { A : dfa char | dfa_lang A =i dfa2_lang M & #|A| <= (#|M|.+1)^(#|M|.+1) }.
  Proof.
    exists (classifier_to_dfa (dfa2_to_myhill)); first exact: classifier_to_dfa_correct.
    rewrite card_sub (leqRW (max_card _)). exact: det_range.
  Qed.

End DFA2toAFA.


Require Import OrderedTypeEx.
Require Import SetoidList.
Require Import Morphisms Program.Basics.

Generalizable All Variables.

(** This file corresponds to [FSetList.v] in the standard library
   and implements finite sets as ordered lists. The corresponding
   [FSet] and [FSetSpecs] instances are defined in
   the file [SetListInstance.v].
   *)

Module SetList.
  (** The type of sets of elements of type [A] is a list.
     It will be without duplicates, and ordered with respect
     to the comparison inferred by the typeclasses mechanism. *)
  Definition set (A : Type) `{OrderedType A} := list A.

  Section SetDefinitions.
    Variable elt : Type.
    Hypothesis (comparedec : OrderedType elt).

    Let t := (set elt).

    Definition empty : t := nil.
    Definition is_empty (s : t) : bool := if s then true else false.

    Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
      match s with
        | nil => false
        | y :: l =>
          match x =?= y with
            | Lt => false
            | Eq => true
            | Gt => mem x l
          end
      end.

    Fixpoint add (x : elt) (s : t) {struct s} : t :=
      match s with
        | nil => x :: nil
        | y :: l =>
          match x =?= y with
            | Lt => x :: s
            | Eq => s
            | Gt => y :: add x l
          end
      end.

    Definition singleton (x : elt) : t := x :: nil.

    Fixpoint remove (x : elt) (s : t) {struct s} : t :=
      match s with
        | nil => nil
        | y :: l =>
          match x =?= y with
            | Lt => s
            | Eq => l
            | Gt => y :: remove x l
          end
      end.

    Fixpoint union (s : t) : t -> t :=
      match s with
        | nil => fun s' => s'
        | x :: l =>
          (fix union_aux (s' : t) : t :=
            match s' with
              | nil => s
              | x' :: l' =>
                match x =?= x' with
                  | Lt => x :: union l s'
                  | Eq => x :: union l l'
                  | Gt => x' :: union_aux l'
                end
            end)
      end.

    Fixpoint inter (s : t) : t -> t :=
      match s with
        | nil => fun _ => nil
        | x :: l =>
          (fix inter_aux (s' : t) : t :=
            match s' with
              | nil => nil
              | x' :: l' =>
                match x =?= x' with
                  | Lt => inter l s'
                  | Eq => x :: inter l l'
                  | Gt => inter_aux l'
                end
            end)
      end.

    Fixpoint diff (s : t) : t -> t :=
      match s with
        | nil => fun _ => nil
        | x :: l =>
          (fix diff_aux (s' : t) : t :=
            match s' with
              | nil => s
              | x' :: l' =>
                match x =?= x' with
                  | Lt => x :: diff l s'
                  | Eq => diff l l'
                  | Gt => diff_aux l'
                end
            end)
      end.

    Fixpoint equal (s s' : t) : bool :=
      match s, s' with
        | nil, nil => true
        | x :: l, x' :: l' =>
          match x =?= x' with
            | Eq => equal l l'
            | _ => false
          end
        | _, _ => false
      end.

    Fixpoint subset (s s' : t) {struct s'} : bool :=
      match s, s' with
        | nil, _ => true
        | x :: l, x' :: l' =>
          match x =?= x' with
            | Lt => false
            | Eq => subset l l'
            | Gt => subset s l'
          end
        | _, _ => false
      end.

    Fixpoint fold {B : Type} (f : elt -> B -> B) (s : t) (i : B) : B :=
      match s with
        | nil => i
        | x :: l => fold f l (f x i)
      end.

    Definition map_monotonic {B : Type} `{OrderedType B}
      (f : elt -> B) (s : t) : set B :=
        List.map f s.

    Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
      match s with
        | nil => nil
        | x :: l => if f x then x :: filter f l else filter f l
      end.

    Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
      match s with
        | nil => true
        | x :: l => if f x then for_all f l else false
      end.

    Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
      match s with
        | nil => false
        | x :: l => if f x then true else exists_ f l
      end.

    Fixpoint partition (f : elt -> bool) (s : t) {struct s} : t * t :=
      match s with
        | nil => (nil, nil)
        | x :: l =>
          let (s1, s2) := partition f l in
            if f x then (x :: s1, s2) else (s1, x :: s2)
      end.

    Definition cardinal (s : t) : nat := length s.

    Definition elements (x : t) : list elt := x.

    Definition min_elt (s : t) : option elt :=
      match s with
        | nil => None
        | x :: _ => Some x
      end.

    Fixpoint max_elt (s : t) : option elt :=
      match s with
        | nil => None
        | x :: nil => Some x
        | _ :: l => max_elt l
      end.

    Definition choose := min_elt.

    Notation In := (@InA elt _eq).
    Definition Equal s s' := forall a : elt, In a s <-> In a s'.
    Definition Subset s s' := forall a : elt, In a s -> In a s'.
    Definition Empty s := forall a : elt, ~ In a s.
    Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
    Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x.
  End SetDefinitions.

  Arguments empty {elt comparedec}.
  Arguments is_empty {elt comparedec}.
  Arguments mem {elt comparedec}.
  Arguments add {elt comparedec}.
  Arguments singleton {elt comparedec}.
  Arguments remove {elt comparedec}.
  Arguments union {elt comparedec}.
  Arguments inter {elt comparedec}.
  Arguments diff {elt comparedec}.
  Arguments equal {elt comparedec}.
  Arguments subset {elt comparedec}.
  Arguments map_monotonic {elt comparedec B H}.
  Arguments fold {elt comparedec B}.
  Arguments filter {elt comparedec}.
  Arguments for_all {elt comparedec}.
  Arguments exists_ {elt comparedec}.
  Arguments partition {elt comparedec}.
  Arguments cardinal {elt comparedec}.
  Arguments elements {elt comparedec}.
  Arguments min_elt {elt comparedec}.
  Arguments max_elt {elt comparedec}.
  Arguments choose {elt comparedec}.
  Arguments Equal {elt comparedec}.
  Arguments Subset {elt comparedec}.
  Arguments Empty {elt comparedec}.
  Arguments For_all {elt comparedec}.
  Arguments Exists {elt comparedec}.

  Definition map {A : Type} `{OrderedType A} {B : Type} `{OrderedType B}
    (f : A -> B) (s : set A) : set B :=
      fold (fun a sb => add (f a) sb) s empty.
  Arguments map {A H B H0}.

  (** Sets seen as a CompareDec (uses list_CompareDec, but in an opaque way) *)
  Definition set_eq `{OrderedType A} : relation (set A) := @list_eq A _eq.
  Definition set_Equivalence `{OrderedType A} : Equivalence set_eq
    := @list_Equivalence A _eq _.

  Definition set_lt `{OrderedType A} : relation (set A) := @list_lt A _lt _eq.
  Definition set_StrictOrder `{OrderedType A} : StrictOrder set_lt set_eq
    := @list_StrictOrder A _.

  Definition set_compare `{OrderedType A} : set A -> set A -> comparison
    := list_compare.
  Definition set_OrderedType `{OrderedType A} : OrderedType (set A) :=
    @list_OrderedType A _.
  Typeclasses Opaque set.

  Set Implicit Arguments.
  Unset Strict Implicit.
  Section SetSpecs.
    Variable A : Type.
    Hypothesis (comparedec : OrderedType A).

    Let elt := A.
    Let t := (set elt).

    Notation Sort := (@sort elt _lt).
    Notation Inf := (@lelistA elt _lt).
    Notation In := (@InA elt _eq).

    Hint Extern 2 (In ?x (?x::_)) => constructor; reflexivity.

    Section AboutSort.
      Lemma In_eq : forall l x y, x === y -> In x l -> In y l.
      Proof. apply InA_eqA; auto. Qed.
      Global Instance In_eq_m : Proper (_eq ==> (@eq (list A)) ==> iff) In.
      Proof.
        repeat intro; subst; split; apply In_eq; auto.
      Qed.

      Lemma ListIn_In : forall l x, List.In x l -> In x l.
      Proof. apply In_InA; auto. Qed.

      Lemma Inf_lt : forall l x y, x <<< y -> Inf y l -> Inf x l.
      Proof. apply InfA_ltA; auto. Qed.
      Global Instance Inf_lt_m :
        Proper (_lt --> (@eq (list A)) ==> impl) Inf.
      Proof.
        repeat intro; subst; apply Inf_lt with x; auto.
      Qed.

      Lemma Inf_eq : forall l x y, x === y -> Inf y l -> Inf x l.
      Proof. apply InfA_eqA; auto. Qed.
      Global Instance Inf_eq_m : Proper (_eq ++> (@eq (list A)) ==> iff) Inf.
      Proof.
        repeat intro; subst; split; apply Inf_eq; auto.
      Qed.

      Lemma Sort_Inf_In :
        forall {l x a}, Sort l -> Inf a l -> In x l -> a <<< x.
      Proof.
        apply SortA_InfA_InA; auto.
      Qed.
      Lemma ListIn_Inf :
        forall l x, (forall y, List.In y l -> x <<< y) -> Inf x l.
      Proof. exact (@In_InfA A _lt). Qed.
      Lemma In_Inf : forall l x, (forall y, In y l -> x <<< y) -> Inf x l.
      Proof. apply InA_InfA; auto. Qed.
      Lemma Inf_alt :
        forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> x <<< y)).
      Proof.
        apply InfA_alt; auto.
      Qed.
    End AboutSort.

    Lemma mem_1 :
      forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true.
    Proof.
      simple induction s; intros.
      inversion H.
      inversion_clear Hs.
      inversion_clear H0; simpl.
      rewrite (elim_compare_eq H3); trivial.
      rewrite elim_compare_gt; auto.
      apply (@Sort_Inf_In l); trivial.
    Qed.

    Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
    Proof.
      simple induction s.
      intros; inversion H.
      intros a l Hrec x.
      simpl.
      destruct (compare_dec x a); intros; try discriminate; auto.
    Qed.

    Lemma add_Inf :
      forall (s : t) (x a : elt), Inf a s -> a <<< x -> Inf a (add x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); intuition; inversion H0;
        intuition.
    Qed.
    Hint Resolve add_Inf.

    Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); intuition; inversion_clear Hs;
        auto.
    Qed.

    Lemma add_1 :
      forall (s : t) (Hs : Sort s) (x y : elt), x === y -> In y (add x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); inversion_clear Hs; auto.
      constructor; transitivity x; auto.
    Qed.

    Lemma add_2 :
      forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); intuition.
      inversion_clear Hs; inversion_clear H0; auto.
    Qed.

    Lemma add_3 :
      forall (s : t) (Hs : Sort s) (x y : elt),
        x =/= y -> In y (add x s) -> In y s.
    Proof.
      simple induction s.
      simpl; inversion_clear 3; auto; symmetry in H; contradiction.
      simpl; intros a l Hrec Hs x y; destruct (compare_dec x a); intros;
        inversion_clear H1; inversion_clear Hs; auto.
      symmetry in H0; contradiction.
      constructor 2; apply Hrec with x; auto.
    Qed.

    Lemma remove_Inf :
      forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); intuition;
        inversion_clear H0; auto.
      inversion_clear Hs; apply Inf_lt with a; auto.
    Qed.
    Hint Resolve remove_Inf.

    Lemma remove_sort :
      forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); intuition;
        inversion_clear Hs; auto.
    Qed.

    Lemma remove_1 :
      forall (s : t) (Hs : Sort s) (x y : elt), x === y -> ~ In y (remove x s).
    Proof.
      simple induction s.
      simpl; red; intros; inversion H0.
      simpl; intros; destruct (compare_dec x a); intuition; inversion_clear Hs.
      inversion_clear H2.
      exact (lt_not_eq H1 (transitivity H0 H5)).
      generalize (Sort_Inf_In H3 H4 H5).
      rewrite H0 in H1; apply lt_not_gt; auto.
      generalize (Sort_Inf_In H3 H4 H2).
      rewrite H0 in H1; apply eq_not_gt; auto.
      inversion_clear H2.
      apply (gt_not_eq H1 (transitivity H0 H5)).
      apply (H H3 _ _ H0 H5).
    Qed.

    Lemma remove_2 :
      forall (s : t) (Hs : Sort s) (x y : elt),
        x =/= y -> In y s -> In y (remove x s).
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros; destruct (compare_dec x a); intuition; inversion_clear Hs;
        inversion_clear H1; auto.
      destruct H0; transitivity a; auto.
    Qed.

    Lemma remove_3 :
      forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s.
    Proof.
      simple induction s.
      simpl; intuition.
      simpl; intros a l Hrec Hs x y; destruct (compare_dec x a); intuition.
      inversion_clear Hs; inversion_clear H0; auto.
      constructor 2; apply Hrec with x; auto.
    Qed.

    Lemma singleton_sort : forall x : elt, Sort (singleton x).
    Proof.
      unfold singleton; simpl; auto.
    Qed.

    Lemma singleton_1 : forall x y : elt, In y (singleton x) -> x === y.
    Proof.
      unfold singleton; simpl; intuition.
      inversion_clear H; auto; inversion H0.
    Qed.

    Lemma singleton_2 : forall x y : elt, x === y -> In y (singleton x).
    Proof.
      unfold singleton; simpl; auto.
    Qed.

    Ltac DoubleInd :=
      simple induction s;
        [ simpl; auto; try solve [ intros; inversion H ]
          | intros x l Hrec; simple induction s';
            [ simpl; auto; try solve [ intros; inversion H ]
              | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst;
                simpl ] ].

    Lemma union_Inf :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
        Inf a s -> Inf a s' -> Inf a (union s s').
    Proof.
      DoubleInd.
      intros i His His'; inversion_clear His; inversion_clear His'.
      destruct (compare x x'); auto.
    Qed.
    Hint Resolve union_Inf.

    Lemma union_sort :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s').
    Proof.
      DoubleInd; destruct (compare_dec x x'); intuition; constructor; auto.
      apply Inf_eq with x'; trivial; apply union_Inf; trivial;
        apply Inf_eq with x; auto.
      change (Inf x' (union (x :: l) l')); auto.
    Qed.

    Lemma union_1 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x (union s s') -> In x s \/ In x s'.
    Proof.
      DoubleInd; destruct (compare_dec x x'); intuition;
        inversion_clear H0; intuition.
      elim (Hrec (x' :: l') H1 Hs' x0); intuition.
      elim (Hrec l' H1 H5 x0); intuition.
      elim (H3 x0); intuition.
    Qed.

    Lemma union_2 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x s -> In x (union s s').
    Proof.
      DoubleInd.
      intros i Hi; destruct (compare_dec x x'); intuition;
        inversion_clear Hi; auto.
    Qed.

    Lemma union_3 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x s' -> In x (union s s').
    Proof.
      DoubleInd.
      intros i Hi; destruct (compare_dec x x'); inversion_clear Hi; intuition.
      constructor; transitivity x'; auto.
    Qed.

    Lemma inter_Inf :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
        Inf a s -> Inf a s' -> Inf a (inter s s').
    Proof.
      DoubleInd.
      intros i His His'; inversion His; inversion His'; subst.
      destruct (compare_dec x x'); intuition.
      apply Inf_lt with x; auto.
      apply H4; auto.
      apply Inf_lt with x'; auto.
    Qed.
    Hint Resolve inter_Inf.

    Lemma inter_sort :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s').
    Proof.
      DoubleInd; destruct (compare_dec x x'); auto.
      constructor; auto.
      apply Inf_eq with x'; trivial;
        apply inter_Inf; trivial; apply Inf_eq with x; auto.
    Qed.

    Lemma inter_1 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x (inter s s') -> In x s.
    Proof.
      DoubleInd; destruct (compare_dec x x'); intuition.
      constructor 2; apply Hrec with (x'::l'); auto.
      inversion_clear H0; auto.
      constructor 2; apply Hrec with l'; auto.
    Qed.

    Lemma inter_2 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x (inter s s') -> In x s'.
    Proof.
      DoubleInd; destruct (compare_dec x x'); intuition; inversion_clear H0.
      constructor 1; transitivity x; auto.
      constructor 2; auto.
    Qed.

    Lemma inter_3 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x s -> In x s' -> In x (inter s s').
    Proof.
      DoubleInd.
      intros i His His'; destruct (compare_dec x x'); intuition.

      inversion_clear His; auto.
      generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ H) His').
      intro abs; rewrite H0 in abs; contradiction (lt_antirefl abs).

      inversion_clear His; auto; inversion_clear His'; auto.
      constructor; transitivity x'; auto.

      change (In i (inter (x :: l) l')).
      inversion_clear His'; auto.
      generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ H) His).
      intro abs; rewrite H0 in abs; contradiction (lt_antirefl abs).
    Qed.

    Lemma diff_Inf :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
        Inf a s -> Inf a s' -> Inf a (diff s s').
    Proof.
      DoubleInd.
      intros i His His'; inversion His; inversion His'.
      destruct (compare_dec x x'); intuition.
      apply Hrec; trivial.
      apply Inf_lt with x; auto.
      apply Inf_lt with x'; auto.
      apply H11; trivial.
      apply Inf_lt with x'; auto.
    Qed.
    Hint Resolve diff_Inf.

    Lemma diff_sort :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s').
    Proof.
      DoubleInd; destruct (compare_dec x x'); auto.
    Qed.

    Lemma diff_1 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x (diff s s') -> In x s.
    Proof.
      DoubleInd; destruct (compare_dec x x'); intuition.
      inversion_clear H0; auto.
      constructor 2; apply Hrec with (x'::l'); auto.
      constructor 2; apply Hrec with l'; auto.
    Qed.

    Lemma diff_2 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x (diff s s') -> ~ In x s'.
    Proof.
      DoubleInd.
      intros; intro Abs; inversion Abs.
      destruct (compare_dec x x'); intuition.

      inversion_clear H0.
      generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ H) H4).
      intro abs; exact (gt_not_eq abs H7).
      apply Hrec with (x'::l') x0; auto.

      inversion_clear H4.
      generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H0)).
      apply eq_not_lt; transitivity x'; auto.
      apply Hrec with l' x0; auto.

      inversion_clear H4.
      generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ H) (diff_1 Hs H5 H0)).
      apply eq_not_lt; auto.
      apply H3 with x0; auto.
    Qed.

    Lemma diff_3 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
        In x s -> ~ In x s' -> In x (diff s s').
    Proof.
      DoubleInd.
      intros i His His'; destruct (compare_dec x x'); intuition;
        inversion_clear His; auto.
      elim His'; constructor; transitivity x; auto.
    Qed.

    Lemma equal_1 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
        Equal s s' -> equal s s' = true.
    Proof.
      simple induction s; unfold Equal.
      intro s'; case s'; auto.
      simpl; intuition.
      elim (H e); intros; assert (Z : In e nil);
        [apply H1; constructor; reflexivity | inversion Z].
      intros x l Hrec s'.
      case s'.
      intros; elim (H x); intros; assert (Z : In x nil);
        [apply H0; constructor; reflexivity | inversion Z].
      intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst.
      simpl; destruct (compare_dec x x'); intros; auto.

      elim (H0 x); intros.
      assert (Z : In x (x' :: l'));
        [apply H3; constructor; reflexivity | inversion_clear Z].
      contradiction (lt_not_eq H H7).
      generalize (Sort_Inf_In H5 H6 H7); intro abs.
      contradiction (lt_not_gt abs H).

      apply Hrec; intuition; elim (H0 a); intros.
      assert (Z : In a (x' :: l')); auto; inversion_clear Z; auto.
      generalize (Sort_Inf_In H1 H2 H3).
      rewrite H; intro abs; contradiction (gt_not_eq abs H8).
      assert (Z : In a (x :: l)); auto; inversion_clear Z; auto.
      generalize (Sort_Inf_In H5 H6 H3).
      rewrite <- H; intro abs; contradiction (gt_not_eq abs H8).

      elim (H0 x'); intros.
      assert (Z : In x' (x :: l));
        [apply H4; constructor; reflexivity | inversion_clear Z].
      contradiction (gt_not_eq H (symmetry H7)).
      generalize (Sort_Inf_In H1 H2 H7); intro abs.
      contradiction (lt_not_gt abs H).
    Qed.

    Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
    Proof.
      simple induction s; unfold Equal.
      intro s'; case s'; intros.
      intuition.
      simpl in H; discriminate H.
      intros x l Hrec s'.
      case s'.
      intros; simpl in H; discriminate.
      intros x' l'; simpl; destruct (compare_dec x x');
        intros; auto; try discriminate.
      elim (Hrec l' H0 a); intuition; inversion_clear H3; auto.
      constructor; transitivity x; auto.
      constructor; transitivity x'; auto.
    Qed.

    Lemma subset_1 :
      forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
        Subset s s' -> subset s s' = true.
    Proof.
      intros s s'; generalize s' s; clear s s'.
      simple induction s'; unfold Subset.
      intro s; case s; auto.
      intros; elim (H e); intros; assert (Z : In e nil); auto; inversion Z.
      intros x' l' Hrec s; case s.
      simpl; auto.
      intros x l Hs Hs'; inversion Hs; inversion Hs'; subst.
      simpl; destruct (compare_dec x x'); intros; auto.

      assert (Z : In x (x' :: l')); auto; inversion_clear Z.
      contradiction (lt_not_eq H H3).
      generalize (Sort_Inf_In H5 H6 H3).
      intro abs; contradiction (lt_not_gt H abs).

      apply Hrec; intuition.
      assert (Z : In a (x' :: l')); auto; inversion_clear Z; auto.
      generalize (Sort_Inf_In H1 H2 H3).
      rewrite H; intro abs; contradiction (gt_not_eq abs H4).

      apply Hrec; intuition.
      assert (Z : In a (x' :: l')); auto; inversion_clear Z; auto.
      inversion_clear H3.
      contradiction (lt_antirefl (x:=a)); rewrite H4 at 1; rewrite H7; auto.
      generalize (Sort_Inf_In H1 H2 H7).
      rewrite H4; intro abs; contradiction (lt_not_gt H abs).
    Qed.

    Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
    Proof.
      intros s s'; generalize s' s; clear s s'.
      simple induction s'; unfold Subset.
      intro s; case s; auto.
      simpl; intros; discriminate H.
      intros x' l' Hrec s; case s.
      intros; inversion H0.
      intros x l; simpl; destruct (compare_dec x x'); intros; auto.
      discriminate.
      inversion_clear H1.
      constructor; transitivity x; auto.
      constructor 2; apply Hrec with l; auto.
      constructor 2; apply Hrec with (x::l); auto.
    Qed.

    Lemma empty_sort : Sort empty.
    Proof.
      unfold empty; constructor.
    Qed.

    Lemma empty_1 : Empty empty.
    Proof.
      unfold Empty, empty; intuition; inversion H.
    Qed.

    Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
    Proof.
      unfold Empty; intro s; case s; simpl; intuition.
      elim (H e); auto; constructor; reflexivity.
    Qed.

    Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s.
    Proof.
      unfold Empty; intro s; case s; simpl; intuition;
        inversion H0.
    Qed.

    Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
    Proof.
      unfold elements; auto.
    Qed.

    Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
    Proof.
      unfold elements; auto.
    Qed.

    Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s).
    Proof.
      unfold elements; auto.
    Qed.
    Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA _eq (elements s).
    Proof.
      unfold elements; intros; apply SortA_NoDupA with _lt; auto.
    Qed.

    Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
    Proof.
      intro s; case s; simpl; intros; inversion H; auto.
    Qed.

    Lemma min_elt_2 :
      forall (s : t) (Hs : Sort s) (x y : elt),
        min_elt s = Some x -> In y s -> ~ y <<< x.
    Proof.
      simple induction s; simpl.
      intros; inversion H.
      intros a l; case l; intros; inversion H0; inversion_clear H1; subst.
      apply eq_not_lt; auto.
      inversion H2.
      apply eq_not_lt; auto.
      inversion_clear Hs.
      inversion_clear H3.
      generalize (H H1 e y (refl_equal (Some e)) H2).
      intros Hlt abs; apply Hlt; transitivity x; auto.
    Qed.

    Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
    Proof.
      unfold Empty; intro s; case s; simpl; intuition;
        inversion H; inversion H0.
    Qed.

    Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
    Proof.
      simple induction s; simpl.
      intros; inversion H.
      intros x l; case l; simpl.
      intuition.
      inversion H0; auto.
      intros.
      constructor 2; apply (H _ H0).
    Qed.

    Lemma max_elt_2 :
      forall (s : t) (Hs : Sort s) (x y : elt),
        max_elt s = Some x -> In y s -> ~ x <<< y.
    Proof.
      simple induction s; simpl.
      intros; inversion H.
      intros x l; case l; simpl.
      intuition.
      inversion H0; subst.
      inversion_clear H1.
      apply (gt_not_eq H2 H3).
      inversion H3.
      intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1.
      assert (In e (e::l0)) by auto.
      generalize (H H2 x0 e H0 H1).
      intros Hlt abs; apply Hlt; transitivity y; auto; rewrite H3; auto.
      exact (H H2 x0 y H0 H3).
    Qed.

    Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
    Proof.
      unfold Empty; simple induction s; simpl.
      red; intros; inversion H0.
      intros x l; case l; simpl; intros.
      inversion H0.
      elim (H H0 e); auto.
    Qed.

    Definition choose_1 :
      forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1.

    Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3.

    Lemma choose_3: forall s s', Sort s -> Sort s' -> forall x x',
      choose s = Some x -> choose s' = Some x' -> Equal s s' -> x === x'.
    Proof.
      unfold choose, Equal; intros s s' Hs Hs' x x' Hx Hx' H.
      assert (~x <<< x').
      apply min_elt_2 with s'; auto.
      rewrite <-H; auto using min_elt_1.
      assert (~x' <<< x).
      apply min_elt_2 with s; auto.
      rewrite H; auto using min_elt_1.
      destruct (compare_dec x x'); intuition.
    Qed.

    Lemma fold_1 :
      forall (s : t) (Hs : Sort s) (A : Type) (i : A) (f : elt -> A -> A),
        fold f s i = fold_left (fun a e => f e a) (elements s) i.
    Proof.
      induction s.
      simpl; trivial.
      intros.
      inversion_clear Hs.
      simpl; auto.
    Qed.

    Lemma cardinal_1 :
      forall (s : t) (Hs : Sort s), cardinal s = length (elements s).
    Proof.
      auto.
    Qed.

    Lemma filter_Inf :
      forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool),
        Inf x s -> Inf x (filter f s).
    Proof.
      simple induction s; simpl.
      intuition.
      intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha.
      case (f x).
      constructor; auto.
      apply Hrec; auto.
      apply Inf_lt with x; auto.
    Qed.

    Lemma filter_sort :
      forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s).
    Proof.
      simple induction s; simpl.
      auto.
      intros x l Hrec Hs f; inversion_clear Hs.
      case (f x); auto.
      constructor; auto.
      apply filter_Inf; auto.
    Qed.

    Lemma filter_1 :
      forall (s : t) (x : elt) (f : elt -> bool)
        `{Proper _ (_eq ==> (@eq bool)) f}, In x (filter f s) -> In x s.
    Proof.
      simple induction s; simpl.
      intros; inversion H0.
      intros x l Hrec a f Hf.
      case (f x); simpl.
      inversion_clear 1.
      constructor; auto.
      constructor 2; apply (Hrec a f Hf); trivial.
      constructor 2; apply (Hrec a f Hf); trivial.
    Qed.

    Lemma filter_2 :
      forall (s : t) (x : elt) (f : elt -> bool)
        `{Proper _ (_eq ==> (@eq bool)) f},
        In x (filter f s) -> f x = true.
    Proof.
      simple induction s; simpl.
      intros; inversion H0.
      intros x l Hrec a f Hf.
      generalize (Hf x); case (f x); simpl; auto.
      inversion_clear 2; auto.
      symmetry; auto.
    Qed.

    Lemma filter_3 :
      forall (s : t) (x : elt) (f : elt -> bool)
        `{Proper _ (_eq ==> (@eq bool)) f},
        In x s -> f x = true -> In x (filter f s).
    Proof.
      simple induction s; simpl.
      intros; inversion H0.
      intros x l Hrec a f Hf.
      generalize (Hf x); case (f x); simpl.
      inversion_clear 2; auto.
      inversion_clear 2; auto.
      rewrite <- (H a (symmetry H1)); intros; discriminate.
    Qed.

    Lemma for_all_1 :
      forall (s : t) (f : elt -> bool) `{Proper _ (_eq ==> (@eq bool)) f},
        For_all (fun x => f x = true) s -> for_all f s = true.
    Proof.
      simple induction s; simpl; auto; unfold For_all.
      intros x l Hrec f Hf.
      generalize (Hf x); case (f x); simpl.
      auto.
      intros; rewrite (H x); auto; reflexivity.
    Qed.

    Lemma for_all_2 :
      forall (s : t) (f : elt -> bool) `{Proper _ (_eq ==> (@eq bool)) f},
        for_all f s = true -> For_all (fun x => f x = true) s.
    Proof.
      simple induction s; simpl; auto; unfold For_all.
      intros; inversion H1.
      intros x l Hrec f Hf.
      intros Z a; intros.
      assert (f x = true).
      generalize Z; case (f x); auto.
      rewrite H0 in Z; simpl in Z.
      inversion_clear H; auto.
      rewrite (Hf a x); auto.
    Qed.

    Lemma exists_1 :
      forall (s : t) (f : elt -> bool) `{Proper _ (_eq ==> (@eq bool)) f},
        Exists (fun x => f x = true) s -> exists_ f s = true.
    Proof.
      simple induction s; simpl; auto; unfold Exists.
      intros.
      elim H0; intuition.
      inversion H2.
      intros x l Hrec f Hf.
      generalize (Hf x); case (f x); simpl.
      auto.
      destruct 2 as [a (A1,A2)].
      inversion_clear A1.
      rewrite <- (H a (symmetry H0)) in A2; discriminate.
      apply Hrec; auto.
      exists a; auto.
    Qed.

    Lemma exists_2 :
      forall (s : t) (f : elt -> bool) `{Proper _ (_eq ==> (@eq bool)) f},
        exists_ f s = true -> Exists (fun x => f x = true) s.
    Proof.
      simple induction s; simpl; auto; unfold Exists.
      intros; discriminate.
      intros x l Hrec f Hf.
      case_eq (f x); intros.
      exists x; auto.
      destruct (Hrec f Hf H0) as [a (A1,A2)].
      exists a; auto.
    Qed.

    Lemma partition_Inf_1 :
      forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
        Inf x s -> Inf x (fst (partition f s)).
    Proof.
      simple induction s; simpl.
      intuition.
      intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
      generalize (Hrec H f a).
      case (f x); case (partition f l); simpl.
      auto.
      intros; apply H2; apply Inf_lt with x; auto.
    Qed.

    Lemma partition_Inf_2 :
      forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
        Inf x s -> Inf x (snd (partition f s)).
    Proof.
      simple induction s; simpl.
      intuition.
      intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
      generalize (Hrec H f a).
      case (f x); case (partition f l); simpl.
      intros; apply H2; apply Inf_lt with x; auto.
      auto.
    Qed.

    Lemma partition_sort_1 :
      forall (s : t) (Hs : Sort s) (f : elt -> bool),
        Sort (fst (partition f s)).
    Proof.
      simple induction s; simpl.
      auto.
      intros x l Hrec Hs f; inversion_clear Hs.
      generalize (Hrec H f); generalize (partition_Inf_1 H f).
      case (f x); case (partition f l); simpl; auto.
    Qed.

    Lemma partition_sort_2 :
      forall (s : t) (Hs : Sort s) (f : elt -> bool),
        Sort (snd (partition f s)).
    Proof.
      simple induction s; simpl.
      auto.
      intros x l Hrec Hs f; inversion_clear Hs.
      generalize (Hrec H f); generalize (partition_Inf_2 H f).
      case (f x); case (partition f l); simpl; auto.
    Qed.

    Lemma partition_1 :
      forall (s : t) (f : elt -> bool) `{Proper _ (_eq ==> (@eq bool)) f},
        Equal (fst (partition f s)) (filter f s).
    Proof.
      simple induction s; simpl; auto; unfold Equal.
      split; auto.
      intros x l Hrec f Hf.
      generalize (Hrec f Hf); clear Hrec.
      destruct partition as [s1 s2]; simpl; intros.
      case (f x); simpl; auto.
      split; inversion_clear 1; auto.
      constructor 2; generalize (proj1 (H a)); auto.
      constructor 2; generalize (proj2 (H a)); auto.
    Qed.

    Lemma partition_2 :
      forall (s : t) (f : elt -> bool) `{Proper _ (_eq ==> (@eq bool)) f},
        Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
    Proof.
      simple induction s; simpl; auto; unfold Equal.
      split; auto.
      intros x l Hrec f Hf.
      generalize (Hrec f Hf); clear Hrec.
      destruct partition as [s1 s2]; simpl; intros.
      case (f x); simpl; auto.
      split; inversion_clear 1; auto.
      constructor 2; generalize (proj1 (H a)); auto.
      constructor 2; generalize (proj2 (H a)); auto.
    Qed.

    Lemma map_monotonic_Inf `{OrderedType B} :
      forall (s : t) (Hs : Sort s) (x : elt)
        (f : elt -> B) `{Proper _ (_lt ==> _lt) f},
        Inf x s -> lelistA _lt (f x) (map_monotonic f s).
    Proof.
      simple induction s; simpl.
      intuition.
      intros x l Hrec Hs a f Hf Ha; inversion_clear Hs; inversion_clear Ha.
      constructor; auto.
    Qed.

    Lemma map_monotonic_sort `{OrderedType B} :
      forall (s : t) (Hs : Sort s)
        (f : elt -> B) `{Proper _ (_lt ==> _lt) f},
        sort _lt (map_monotonic f s).
    Proof.
      simple induction s; simpl.
      auto.
      intros x l Hrec Hs f Hf; inversion_clear Hs.
      constructor; auto.
      apply map_monotonic_Inf; auto.
    Qed.
  End SetSpecs.

  Definition In `{OrderedType A} (x : A) (s : set A) := InA _eq x s.
End SetList.

Module S := SetList.

Structure set (A : Type) `{OrderedType A}
  := Build_set {this :> list A; sorted : sort _lt this}.
Arguments this {A H}.
Arguments Build_set {A H this}.
Arguments sorted {A H}.

Section SetDefinitions.
  Variable A : Type.
  Hypothesis (comparedec : OrderedType A).

  Let elt := A.
  Let t := set elt.

  Definition empty : t := Build_set (@S.empty_sort _ _).
  Definition is_empty (s : t) : bool := S.is_empty s.
  Definition mem (x : elt) (s : t) : bool := S.mem x s.
  Definition add (x : elt) (s : t) : t :=
    Build_set (S.add_sort (sorted s) x).
  Definition singleton (x : elt) : t :=
    Build_set (S.singleton_sort _ x).
  Definition remove (x : elt) (s : t) : t :=
    Build_set (S.remove_sort (sorted s) x).
  Definition union (s s' : t) : t :=
    Build_set (S.union_sort (sorted s) (sorted s')).
  Definition inter (s s' : t) : t :=
    Build_set (S.inter_sort (sorted s) (sorted s')).
  Definition diff (s s' : t) : t :=
    Build_set (S.diff_sort (sorted s) (sorted s')).

  Definition equal (s s' : t) : bool := S.equal s s'.
  Definition subset (s s' : t) : bool := S.subset s s'.

  Definition fold {B : Type} (f : elt -> B -> B) (s : t) : B -> B :=
    S.fold f s.
(*   Definition map {B : Type} (f : elt -> B) (s : t) : set B := *)
(*     Build_set (S.map f s. *)
  Definition map_monotonic {B : Type} `{OrderedType B}
    (f : elt -> B) `{Mono : Proper _ (_lt ==> _lt) f} (s : t) : set B :=
      Build_set (S.map_monotonic_sort (sorted s)).

  Definition filter (f : elt -> bool) (s : t) : t :=
    Build_set (S.filter_sort (sorted s) f).
  Definition for_all (f : elt -> bool) (s : t) : bool := S.for_all f s.
  Definition exists_ (f : elt -> bool) (s : t) : bool := S.exists_ f s.
  Definition partition (f : elt -> bool) (s : t) : t * t :=
    let p := S.partition f s in
      (Build_set (this:=fst p) (S.partition_sort_1 (sorted s) f),
        Build_set (this:=snd p) (S.partition_sort_2 (sorted s) f)).

  Definition cardinal (s : t) : nat := S.cardinal s.
  Definition elements (x : t) : list elt := S.elements x.

  Definition min_elt (s : t) : option elt := S.min_elt s.
  Definition max_elt (s : t) : option elt := S.max_elt s.
  Definition choose := min_elt.
End SetDefinitions.

Arguments empty {A comparedec}.
Arguments is_empty {A comparedec}.
Arguments mem {A comparedec}.
Arguments add {A comparedec}.
Arguments singleton {A comparedec}.
Arguments remove {A comparedec}.
Arguments union {A comparedec}.
Arguments inter {A comparedec}.
Arguments diff {A comparedec}.
Arguments equal {A comparedec}.
Arguments subset {A comparedec}.
Arguments map_monotonic {A comparedec B H} _ {Mono}.
Arguments fold {A comparedec B}.
Arguments filter {A comparedec}.
Arguments for_all {A comparedec}.
Arguments exists_ {A comparedec}.
Arguments partition {A comparedec}.
Arguments cardinal {A comparedec}.
Arguments elements {A comparedec}.
Arguments min_elt {A comparedec}.
Arguments max_elt {A comparedec}.
Arguments choose {A comparedec}.

Set Implicit Arguments.
Unset Strict Implicit.

Section Spec.
  Variable A : Type.
  Hypothesis (comparedec : OrderedType A).

  Let elt := A.
  Let t := (set elt).

  Variable s s' s'': t.
  Variable x y : elt.

  Definition In (x : elt) (s : t) : Prop := InA _eq x s.(this).
  Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'.
  Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'.
  Definition Empty (s:t) : Prop := forall a : elt, ~ In a s.
  Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x.
  Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x.

  Lemma In_1 : x === y -> In x s -> In y s.
  Proof. exact (fun H H' => S.In_eq H H'). Qed.

  Lemma mem_1 : In x s -> mem x s = true.
  Proof. exact (fun H => S.mem_1 s.(sorted) H). Qed.
  Lemma mem_2 : mem x s = true -> In x s.
  Proof. exact (fun H => S.mem_2 H). Qed.

  Lemma equal_1 : Equal s s' -> equal s s' = true.
  Proof. exact (S.equal_1 s.(sorted) s'.(sorted)). Qed.
  Lemma equal_2 : equal s s' = true -> Equal s s'.
  Proof. exact (fun H => S.equal_2 H). Qed.

  Lemma subset_1 : Subset s s' -> subset s s' = true.
  Proof. exact (S.subset_1 s.(sorted) s'.(sorted)). Qed.
  Lemma subset_2 : subset s s' = true -> Subset s s'.
  Proof. exact (fun H => S.subset_2 H). Qed.

  Lemma empty_1 : Empty empty.
  Proof. eapply S.empty_1. Qed.

  Lemma is_empty_1 : Empty s -> is_empty s = true.
  Proof. exact (fun H => S.is_empty_1 H). Qed.
  Lemma is_empty_2 : is_empty s = true -> Empty s.
  Proof. exact (fun H => S.is_empty_2 H). Qed.

  Lemma add_1 : x === y -> In y (add x s).
  Proof. exact (fun H => S.add_1 s.(sorted) H). Qed.
  Lemma add_2 : In y s -> In y (add x s).
  Proof. exact (fun H => S.add_2 s.(sorted) x H). Qed.
  Lemma add_3 : x =/= y -> In y (add x s) -> In y s.
  Proof. exact (fun H => S.add_3 s.(sorted) H). Qed.

  Lemma remove_1 : x === y -> ~ In y (remove x s).
  Proof. exact (fun H => S.remove_1 s.(sorted) H). Qed.
  Lemma remove_2 : x =/= y -> In y s -> In y (remove x s).
  Proof. exact (fun H H' => S.remove_2 s.(sorted) H H'). Qed.
  Lemma remove_3 : In y (remove x s) -> In y s.
  Proof. exact (fun H => S.remove_3 s.(sorted) H). Qed.

  Lemma singleton_1 : In y (singleton x) -> x === y.
  Proof. exact (fun H => S.singleton_1 H). Qed.
  Lemma singleton_2 : x === y -> In y (singleton x).
  Proof. exact (fun H => S.singleton_2 H). Qed.

  Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
  Proof. exact (fun H => S.union_1 s.(sorted) s'.(sorted) H). Qed.
  Lemma union_2 : In x s -> In x (union s s').
  Proof. exact (fun H => S.union_2 s.(sorted) s'.(sorted) H). Qed.
  Lemma union_3 : In x s' -> In x (union s s').
  Proof. exact (fun H => S.union_3 s.(sorted) s'.(sorted) H). Qed.

  Lemma inter_1 : In x (inter s s') -> In x s.
  Proof. exact (fun H => S.inter_1 s.(sorted) s'.(sorted) H). Qed.
  Lemma inter_2 : In x (inter s s') -> In x s'.
  Proof. exact (fun H => S.inter_2 s.(sorted) s'.(sorted) H). Qed.
  Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
  Proof. exact (fun H => S.inter_3 s.(sorted) s'.(sorted) H). Qed.

  Lemma diff_1 : In x (diff s s') -> In x s.
  Proof. exact (fun H => S.diff_1 s.(sorted) s'.(sorted) H). Qed.
  Lemma diff_2 : In x (diff s s') -> ~ In x s'.
  Proof. exact (fun H => S.diff_2 s.(sorted) s'.(sorted) H). Qed.
  Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
  Proof. exact (fun H => S.diff_3 s.(sorted) s'.(sorted) H). Qed.

  Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (fun a e => f e a) (elements s) i.
  Proof. exact (S.fold_1 s.(sorted)). Qed.

  Lemma cardinal_1 : cardinal s = length (elements s).
  Proof. exact (S.cardinal_1 s.(sorted)). Qed.

  Section Filter.

    Variable f : elt -> bool.
    Lemma filter_1 `{Proper _ (_eq ==> (@eq bool)) f} :
      In x (filter f s) -> In x s.
    Proof. intros; eapply S.filter_1 with (f := f); auto. Qed.
    Lemma filter_2 `{Proper _ (_eq ==> (@eq bool)) f} :
      In x (filter f s) -> f x = true.
    Proof. intros; eapply S.filter_2 with (s := s); auto. Qed.
    Lemma filter_3 `{Proper _ (_eq ==> (@eq bool)) f} :
      In x s -> f x = true -> In x (filter f s).
    Proof. apply S.filter_3; auto. Qed.

    Lemma for_all_1 `{Proper _ (_eq ==> (@eq bool)) f} :
      For_all (fun x => f x = true) s -> for_all f s = true.
    Proof. apply S.for_all_1; auto. Qed.
    Lemma for_all_2 `{Proper _ (_eq ==> (@eq bool)) f} :
      for_all f s = true -> For_all (fun x => f x = true) s.
    Proof. apply S.for_all_2; auto. Qed.

    Lemma exists_1 `{Proper _ (_eq ==> (@eq bool)) f} :
      Exists (fun x => f x = true) s -> exists_ f s = true.
    Proof. apply S.exists_1; auto. Qed.
    Lemma exists_2 `{Proper _ (_eq ==> (@eq bool)) f} :
      exists_ f s = true -> Exists (fun x => f x = true) s.
    Proof. apply S.exists_2; auto. Qed.

    Lemma partition_1 `{Proper _ (_eq ==> (@eq bool)) f} :
      Equal (fst (partition f s)) (filter f s).
    Proof. apply (@S.partition_1 _ _ s f); auto. Qed.
    Lemma partition_2 `{Proper _ (_eq ==> (@eq bool)) f} :
      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
    Proof. apply (@S.partition_2 _ _ s f); auto. Qed.

  End Filter.

  Lemma elements_1 : In x s -> InA _eq x (elements s).
  Proof. exact (fun H => S.elements_1 H). Qed.
  Lemma elements_2 : InA _eq x (elements s) -> In x s.
  Proof. exact (fun H => S.elements_2 H). Qed.
  Lemma elements_3 : sort _lt (elements s).
  Proof. exact (S.elements_3 s.(sorted)). Qed.
  Lemma elements_3w : NoDupA _eq (elements s).
  Proof. exact (S.elements_3w s.(sorted)). Qed.

  Lemma min_elt_1 : min_elt s = Some x -> In x s.
  Proof. exact (fun H => S.min_elt_1 H). Qed.
  Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ y <<< x.
  Proof. exact (fun H => S.min_elt_2 s.(sorted) H). Qed.
  Lemma min_elt_3 : min_elt s = None -> Empty s.
  Proof. exact (fun H => S.min_elt_3 H). Qed.

  Lemma max_elt_1 : max_elt s = Some x -> In x s.
  Proof. exact (fun H => S.max_elt_1 H). Qed.
  Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ x <<< y.
  Proof. exact (fun H => S.max_elt_2 s.(sorted) H). Qed.
  Lemma max_elt_3 : max_elt s = None -> Empty s.
  Proof. exact (fun H => S.max_elt_3 H). Qed.

  Lemma choose_1 : choose s = Some x -> In x s.
  Proof. exact (fun H => S.choose_1 H). Qed.
  Lemma choose_2 : choose s = None -> Empty s.
  Proof. exact (fun H => S.choose_2 H). Qed.
  Lemma choose_3 : choose s = Some x -> choose s' = Some y ->
    Equal s s' -> x === y.
  Proof. eapply S.choose_3; apply sorted. Qed.
End Spec.
Unset Implicit Arguments.

Require SetInterface.
(** Sets seen as an OrderedType with equality the pointwise equality [Equal] *)
Definition Equal_Equivalence `{OrderedType A} : Equivalence (@Equal A _) :=
  SetInterface.Equal_pw_Equivalence (set A) A (@In _ H).

Lemma Equal_set_eq `{HA : OrderedType A} :
  forall s s', Equal s s' <-> S.set_eq s s'.
Proof.
  intros [s Hs] [s' Hs']; simpl.
  unfold Equal, In; simpl; unfold SetList.set_eq.
  revert s' Hs Hs'; induction s; destruct s'; intros Hs Hs'; split; intro H.
  constructor.
  intro; split; intro abs; inversion abs.
  assert (abs : InA _eq a nil). rewrite H; constructor; auto. inversion abs.
  inversion H.
  assert (abs : InA _eq a nil). rewrite <-H; constructor; auto. inversion abs.
  inversion H.

  inversion Hs; inversion Hs'; subst.
  rewrite Inf_alt in H3 by auto; rewrite Inf_alt in H7 by auto.
  assert (Heq : a === a0).
  assert (Ha : InA _eq a (a0 :: s')). rewrite <- H; constructor; auto.
  assert (Ha' : InA _eq a0 (a :: s)). rewrite H; constructor; auto.
  inversion Ha; inversion Ha'; subst; auto.
  apply False_rec; apply (lt_not_gt (x:=a) (y:=a0)); auto.
  constructor; auto; rewrite <- IHs; auto.
  intro z; split; intro Hz.
  assert (Rz : InA _eq z (a0::s')). rewrite <- H; constructor 2; auto.
  inversion Rz; subst; auto;
    contradiction (lt_not_eq (H3 z Hz)); transitivity a0; auto.
  assert (Rz : InA _eq z (a::s)). rewrite H; constructor 2; auto.
  inversion Rz; subst; auto;
    contradiction (lt_not_eq (H7 z Hz)); transitivity a; auto.

  inversion H; subst; inversion Hs; inversion Hs'; subst.
  rewrite Inf_alt in H4 by auto; rewrite Inf_alt in H9 by auto.
  rewrite <- IHs in H5 by auto.
  intro z; split; intro Hz; inversion Hz; subst.
  constructor; transitivity a; auto.
  constructor 2; rewrite <- H5; auto.
  constructor; transitivity a0; auto.
  constructor 2; rewrite H5; auto.
Qed.

Definition set_lt `{OrderedType A} : relation (set A) := S.set_lt.
Program Definition set_StrictOrder `{OrderedType A} :
  @StrictOrder _ set_lt (@Equal A _) Equal_Equivalence :=
  Build_StrictOrder _ _ _ _ _ _.
Next Obligation.
  intros x y z H1 H2. unfold set_lt, S.set_lt in *.
  now transitivity y.
Qed.
Next Obligation.
  change (~Equal x y); rewrite Equal_set_eq.
  apply lt_not_eq; auto.
Qed.

Definition set_compare `{OrderedType A} : set A -> set A -> comparison :=
  S.set_compare.

Program Instance set_OrderedType `{OrderedType A} :
  SpecificOrderedType (set A) (@Equal A _) := {
    SOT_Equivalence := Equal_Equivalence;
    SOT_lt := set_lt;
    SOT_StrictOrder := set_StrictOrder;
    SOT_cmp := set_compare
}.
Next Obligation.
  change (compare_spec (@Equal _ _) set_lt x y ((this x) =?= (this y))).
  destruct (compare_dec (this x) (this y)); constructor; auto.
  rewrite Equal_set_eq; auto.
Qed.


Require Export SpecSyntax.
Require Export BoilerplateFunctions.
Set Implicit Arguments.

(******************************************************************************)
(* Context insertions.                                                        *)
(******************************************************************************)

Inductive shift_evar : nat → Env → Env → Prop :=
  | shift_evar_here {Γ T} :
      shift_evar 0 Γ (evar Γ T)
  | shift_evar_there_evar {Γ1 Γ2 c T} :
      shift_evar c Γ1 Γ2 →
      shift_evar (S c) (evar Γ1 T) (evar Γ2 T).
Hint Constructors shift_evar.

(******************************************************************************)
(* Lemmas about shifting and context lookups.                                 *)
(******************************************************************************)

Lemma shift_evar_lookup_evar {Γ1 Γ2 c} (iv : shift_evar c Γ1 Γ2) :
  ∀ x T, lookup_evar Γ1 x T → lookup_evar Γ2 (shiftIndex c x) T.
Proof.
  induction iv; inversion 1; simpl; eauto.
Qed.
Hint Resolve shift_evar_lookup_evar.

(******************************************************************************)
(* Context substitutions                                                      *)
(******************************************************************************)

Inductive subst_evar (Γ: Env) (U : Ty) : nat → Env → Env → Prop :=
  | subst_evar_here :
      subst_evar Γ U 0 (evar Γ U) Γ
  | subst_evar_there_evar {Γ1 Γ2 : Env} {x T} :
      subst_evar Γ U x     Γ1           Γ2 →
      subst_evar Γ U (S x) (evar Γ1 T) (evar Γ2 T).
Hint Constructors subst_evar.


Require Import Frap.

Set Implicit Arguments.
(* This command sets up automatic inference of tedious arguments. *)

(* Our first example: the [option] type family.  While Java and friends force
 * all sorts of different types to include the special value [null], in Coq we
 * request that option explicitly by wrapping a type in [option].  Specifically,
 * any value of type [option A], for some type [A], is either [None] (sort of
 * like [null]) or [Some v] for a [v] of type [A]. *)
Inductive option (A : Set) : Set :=
| None
| Some (v : A).

Arguments None [A].
(* This command asks Coq to *infer* the [A] type for each specific use of
 * [None]. *)

(* Here are a few example terms using [option]. *)
Example no_number : option nat := None.
Example a_number : option nat := Some 42.
Example no_number_squared : option (option nat) := None.
Example no_number_squared_inside : option (option nat) := Some None.
Example a_number_squared : option (option nat) := Some (Some 42).

(* Pattern matching is the key ingredient for working with inductive definitions
 * of all sorts.  Here are some examples matching on [option]s. *)

Definition increment_optional (no : option nat) : option nat :=
  match no with
  | None => None
  | Some n => Some (n + 1)
  end.

(* Here we use type [A * B] of *pairs*, inhabited by values [(a, b)], with
 * [a : A] and [b : B]. *)
Definition add_optional (po : option (nat * nat)) : option nat :=
  match po with
  | None => None
  | Some (n, m) => Some (n + m)
  end.

(** * Lists *)

(* For functional programming (as in Coq), the king of all generic data
 * structures is the *list*, which you explored a bit in the first problem set.
 * Let's recap that type definition. *)
Inductive list (A : Set) : Set :=
| nil
| cons (hd : A) (tl : list A).

Arguments nil [A].

(* [nil] is the empty list, while [cons], standing for "construct," extends a
 * list of length [n] into one of length [n+1]. *)

(* Here are some simple lists. *)

Example nats0 : list nat := nil.
Example nats1 : list nat := cons 1 nil.
Example nats2 : list nat := cons 1 (cons 2 nil).

(* Coq features a wonderful notation system, to help us write more concise and
 * readable code after introducing new syntactic forms.  We will not give a
 * systematic presentation of the notation system, but we will show many
 * examples, from which it is possible to infer generality by scientific
 * induction.  And, of course, the interested reader can always check the
 * notations chapter of the Coq reference manual. *)

(* First, our examples can get more readable with an infix operator for [cons]. *)

Infix "::" := cons.

Example nats1' : list nat := 1 :: nil.
Example nats2' : list nat := 1 :: 2 :: nil.

(* Getting even more fancy, we declare a notation for list literals. *)

Notation "[ ]" := nil.
Notation "[ x1 ; .. ; xN ]" := (cons x1 (.. (cons xN nil) ..)).

Example nats0'' : list nat := [].
Example nats1'' : list nat := [1].
Example nats2'' : list nat := [1; 2].
Example nats3'' : list nat := [1; 2; 3].

(* Here are some classic recursive functions that operate over lists.
 * First, here is how to compute the length of a list.  Recall that we put
 * *implicit* function arguments in curly braces, asking Coq to infer them at
 * call sites. *)

Fixpoint length {A} (ls : list A) : nat :=
  match ls with
  | nil => 0
  | _ :: ls' => 1 + length ls'
  end.

(* More familiar operations from Pset1 *)

Fixpoint app {A} (ls1 ls2 : list A) : list A :=
  match ls1 with
  | nil => ls2
  | x :: ls1' => x :: app ls1' ls2
  end.

Infix "++" := app.

Fixpoint rev {A} (ls : list A) : list A :=
  match ls with
  | nil => nil
  | x :: ls' => rev ls' ++ [x]
  end.

Theorem length_app : forall A (ls1 ls2 : list A),
    length (ls1 ++ ls2) = length ls1 + length ls2.
Admitted.

(* One of the classic gotchas in functional-programming class is how slow this
 * naive [rev] is.  Each [app] operation requires linear time, so running
 * linearly many [app]s brings us to quadratic time for [rev].  Using a helper
 * function, we can bring [rev] to its optimal linear time. *)

Fixpoint rev_append {A} (ls acc : list A) : list A :=
  match ls with
  | nil => acc
  | x :: ls' => rev_append ls' (x :: acc)
  end.

(* This function [rev_append] takes an extra *accumulator* argument, in which we
 * gradually build up the original input in reversed order.  The base case just
 * returns the accumulator.  Now reversal just needs to do a [rev_append] with
 * an empty initial accumulator. *)

Definition rev' {A} (ls : list A) : list A :=
  rev_append ls [].

(* A few test cases can help convince us that this seems to work. *)

Compute rev [1; 2; 3; 4].
Compute rev' [1; 2; 3; 4].
Compute rev ["hi"; "bye"; "sky"].
Compute rev' ["hi"; "bye"; "sky"].

(* OK, great.  Now it seems worth investing in a correctness proof.  We'll
 * discover it interactively in class, but here's a worked-out final
 * answer, with the several lemmas that we discover are useful. *)

Theorem rev'_ok : forall A (ls : list A),
    rev' ls = rev ls.
Proof.
Admitted.

(** ** Zipping and unzipping *)

(* Another classic pair of list operations is zipping and unzipping.
 * These functions convert between pairs of lists and lists of pairs. *)

Fixpoint zip {A1 A2} (ls1 : list A1) (ls2 : list A2) : list (A1 * A2) :=
  match ls1, ls2 with
  | x1 :: ls1', x2 :: ls2' => (x1, x2) :: zip ls1' ls2'
  | _, _ => []
  end.
(* Note how, when passed two lengths of different lists, [zip] drops the
 * mismatched suffix of the longer list. *)

(* An explicit [Set] annotation is needed here, for obscure type-inference
 * reasons. *)
Fixpoint unzip {A1 A2 : Set} (ls : list (A1 * A2)) : list A1 * list A2 :=
  match ls with
  | [] => ([], [])
  | (x1, x2) :: ls' =>
    let (ls1, ls2) := unzip ls' in
    (x1 :: ls1, x2 :: ls2)
  end.

(* A few common-sense properties hold of these definitions. *)

Theorem length_zip : forall A1 A2 (ls1 : list A1) (ls2 : list A2),
    length (zip ls1 ls2) = 7.
Proof.
Admitted.

(* We write [fst] and [snd] for the first and second projection operators on
 * pairs, respectively. *)

Theorem length_unzip1 : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    length (fst (unzip ls)) = length ls.
Proof.
Admitted.

Theorem length_unzip2 : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    length (snd (unzip ls)) = length ls.
Proof.
Admitted.

Theorem zip_unzip : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    (let (ls1, ls2) := unzip ls in zip ls1 ls2) = ls.
Proof.
Admitted.

(* There are also interesting interactions with [app] and [rev]. *)

Theorem unzip_app : forall (A1 A2 : Set) (x y : list (A1 * A2)),
    unzip (x ++ y)
    = (let (x1, x2) := unzip x in
       let (y1, y2) := unzip y in
       (x1 ++ y1, x2 ++ y2)).
Proof.
Admitted.

Theorem unzip_rev : forall (A1 A2 : Set) (ls : list (A1 * A2)),
    unzip (rev ls) = (let (ls1, ls2) := unzip ls in
                      (rev ls1, rev ls2)).
Proof.
Admitted.

(** * Binary trees *)

(* Another classic datatype is binary trees, which we can define like so. *)
Inductive tree (A : Set) : Set :=
| Leaf
| Node (l : tree A) (d : A) (r : tree A).

Arguments Leaf [A].

Example tr1 : tree nat := Node (Node Leaf 7 Leaf) 8 (Node Leaf 9 (Node Leaf 10 Leaf)).

(* There is a natural notion of size of a tree. *)
Fixpoint size {A} (t : tree A) : nat :=
  match t with
  | Leaf => 0
  | Node l _ r => 1 + size l + size r
  end.

(* There is also a natural sense of reversing a tree, flipping it around its
 * vertical axis. *)
Fixpoint reverse {A} (t : tree A) : tree A :=
  match t with
  | Leaf => Leaf
  | Node l d r => Node (reverse r) d (reverse l)
  end.

(* There is a natural relationship between the two. *)
Theorem size_reverse : forall A (t : tree A),
    size (reverse t) = size t.
Proof.
Admitted.

(* Another classic tree operation is flattening into lists. *)
Fixpoint flatten {A} (t : tree A) : list A :=
  match t with
  | Leaf => []
  | Node l d r => flatten l ++ d :: flatten r
  end.
(* Note here that operators [++] and [::] are right-associative. *)

Theorem length_flatten : forall A (t : tree A),
    length (flatten t) = size t.
Proof.
Admitted.

Theorem rev_flatten : forall A (t : tree A),
    rev (flatten t) = flatten (reverse t).
Proof.
Admitted.

(** * Syntax trees *)

(* Trees are particularly important to us in studying program proof, since it is
 * natural to represent programs as *syntax trees*.  Here's a quick example, for
 * a tiny imperative language. *)

Inductive expression : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : expression)
| Minus (e1 e2 : expression)
| Times (e1 e2 : expression)
| GreaterThan (e1 e2 : expression)
| Not (e : expression).

Inductive statement : Set :=
| Assign (x : var) (e : expression)
| Sequence (s1 s2 : statement)
| IfThenElse (e : expression) (s1 s2 : statement)
| WhileLoop (e : expression) (s : statement).

(* First, here's a quick sample of nifty notations to write
 * almost-natural-looking embedded programs in Coq. *)
Coercion Const : nat >-> expression.
Coercion Var : string >-> expression.
Infix "+" := Plus : embedded_scope.
Infix "-" := Minus : embedded_scope.
Infix "*" := Times : embedded_scope.
Infix ">" := GreaterThan : embedded_scope.
Infix "<-" := Assign (at level 75) : embedded_scope.
Infix ";" := Sequence (at level 76) : embedded_scope.
Notation "'If' e {{ s1 }} 'else' {{ s2 }}" := (IfThenElse e s1 s2) (at level 75) : embedded_scope.
Notation "'While' e {{ s }}" := (WhileLoop e s) (at level 75) : embedded_scope.
Delimit Scope embedded_scope with embedded.

Example factorial :=
  ("answer" <- 1;
   While ("input" > 0) {{
     "answer" <- "answer" * "input";
     "input" <- "input" - 1
   }})%embedded.

(* A variety of compiler-style operations can be coded on top of this type.
 * Here's one to count total variable occurrences. *)

Fixpoint varsInExpression (e : expression) : nat :=
  match e with
  | Const _ => 0
  | Var _ => 1
  | Plus e1 e2
  | Minus e1 e2
  | Times e1 e2
  | GreaterThan e1 e2 => varsInExpression e1 + varsInExpression e2
  | Not e1 => varsInExpression e1
  end.

Fixpoint varsInStatement (s : statement) : nat :=
  match s with
  | Assign _ e => 1 + varsInExpression e
  | Sequence s1 s2 => varsInStatement s1 + varsInStatement s2
  | IfThenElse e s1 s2 => varsInExpression e + varsInStatement s1 + varsInStatement s2
  | WhileLoop e s1 => varsInExpression e + varsInStatement s1
  end.

(* We will need to wait for a few more lectures' worth of conceptual progress
 * before we can prove that transformations on programs preserve meaning, but we
 * do already have enough tools that prove that transformations preserve more
 * basic properties, like number of variables.  Here's one such transformation,
 * which flips "then" and "else" cases while also negating "if" conditions. *)
Fixpoint flipper (s : statement) : statement :=
  match s with
  | Assign _ _ => s
  | Sequence s1 s2 => Sequence (flipper s1) (flipper s2)
  | IfThenElse e s1 s2 => IfThenElse (Not e) (flipper s2) (flipper s1)
  | WhileLoop e s1 => WhileLoop e (flipper s1)
  end.

Theorem varsIn_flipper : forall s,
    varsInStatement (flipper s) = varsInStatement s.
Proof.
Admitted.

(* Just for the sheer madcap fun of it, let's write some translations of
 * programs into our lists from before, with variables as data values. *)

Fixpoint listifyExpression (e : expression) : list var :=
  match e with
  | Const _ => []
  | Var x => [x]
  | Plus e1 e2
  | Minus e1 e2
  | Times e1 e2
  | GreaterThan e1 e2 => listifyExpression e1 ++ listifyExpression e2
  | Not e1 => listifyExpression e1
  end.

Fixpoint listifyStatement (s : statement) : list var :=
  match s with
  | Assign x e => x :: listifyExpression e
  | Sequence s1 s2 => listifyStatement s1 ++ listifyStatement s2
  | IfThenElse e s1 s2 => listifyExpression e ++ listifyStatement s1 ++ listifyStatement s2
  | WhileLoop e s1 => listifyExpression e ++ listifyStatement s1
  end.

Compute listifyStatement factorial.

(* At this point, I can't resist switching to a more automated proof style,
 * though still a pretty tame one. *)

Theorem length_listifyStatement : forall s,
    length (listifyStatement s) = varsInStatement s.
Proof.
Admitted.

(* Other transformations are also possible, like the Swedish-Chef optimization,
 * that turns every variable into "bork".  It saves many bits when most variable
 * names are longer than 4 characters. *)

Fixpoint swedishExpression (e : expression) : expression :=
  match e with
  | Const _ => e
  | Var _ => Var "bork"
  | Plus e1 e2 => Plus (swedishExpression e1) (swedishExpression e2)
  | Minus e1 e2 => Minus (swedishExpression e1) (swedishExpression e2)
  | Times e1 e2 => Times (swedishExpression e1) (swedishExpression e2)
  | GreaterThan e1 e2 => GreaterThan (swedishExpression e1) (swedishExpression e2)
  | Not e1 => Not (swedishExpression e1)
  end.

Fixpoint swedishStatement (s : statement) : statement :=
  match s with
  | Assign _ e => Assign "bork" (swedishExpression e)
  | Sequence s1 s2 => Sequence (swedishStatement s1) (swedishStatement s2)
  | IfThenElse e s1 s2 => IfThenElse (swedishExpression e) (swedishStatement s1) (swedishStatement s2)
  | WhileLoop e s1 => WhileLoop (swedishExpression e) (swedishStatement s1)
  end.

Compute swedishStatement factorial.

Fixpoint swedishList (ls : list var) : list var :=
  match ls with
  | [] => []
  | _ :: ls => "bork" :: swedishList ls
  end.

Lemma listifyStatement_swedishStatement : forall s,
    listifyStatement (swedishStatement s) = swedishList (listifyStatement s).
Proof.
Admitted.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require Import Rbasic_fun.
Require Import R_sqrt.
Require Import Rtrigo.
Require Import AltSeries. (* for def of pi *)
Require real.Real.
Require real.Abs.
Require real.FromInt.
Require int.Int.
Require real.Square.
Require floating_point.Rounding.
Require floating_point.SingleFormat.
Require floating_point.Single.

Axiom Pi_interval : ((314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196 / 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%R < PI)%R /\
  (PI < (314159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038197 / 100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%R)%R.

Axiom Cos_plus_pi : forall (x:R),
  ((Rtrigo_def.cos (x + PI)%R) = (-(Rtrigo_def.cos x))%R).

Axiom Sin_plus_pi : forall (x:R),
  ((Rtrigo_def.sin (x + PI)%R) = (-(Rtrigo_def.sin x))%R).

Axiom Cos_plus_pi2 : forall (x:R),
  ((Rtrigo_def.cos (x + ((05 / 10)%R * PI)%R)%R) = (-(Rtrigo_def.sin x))%R).

Axiom Sin_plus_pi2 : forall (x:R),
  ((Rtrigo_def.sin (x + ((05 / 10)%R * PI)%R)%R) = (Rtrigo_def.cos x)).

Axiom Cos_neg : forall (x:R), ((Rtrigo_def.cos (-x)%R) = (Rtrigo_def.cos x)).

Axiom Sin_neg : forall (x:R),
  ((Rtrigo_def.sin (-x)%R) = (-(Rtrigo_def.sin x))%R).

Axiom Cos_sum : forall (x:R) (y:R),
  ((Rtrigo_def.cos (x + y)%R) = (((Rtrigo_def.cos x) * (Rtrigo_def.cos y))%R - ((Rtrigo_def.sin x) * (Rtrigo_def.sin y))%R)%R).

Axiom Sin_sum : forall (x:R) (y:R),
  ((Rtrigo_def.sin (x + y)%R) = (((Rtrigo_def.sin x) * (Rtrigo_def.cos y))%R + ((Rtrigo_def.cos x) * (Rtrigo_def.sin y))%R)%R).

Parameter atan: R -> R.

Axiom Tan_atan : forall (x:R), ((Rtrigo.tan (atan x)) = x).

Require Import Interval_tactic.

(* Why3 goal *)
Theorem MethodError : forall (x:R), ((Rabs x) <= (1 / 32)%R)%R ->
  ((Rabs ((1%R - ((05 / 10)%R * (x * x)%R)%R)%R - (Rtrigo_def.cos x))%R) <= (1 / 16777216)%R)%R.
(* YOU MAY EDIT THE PROOF BELOW *)
intros x H.
interval with (i_bisect_diff x).
Qed.


(** This file contains extensions of the [ConstructiveEpsilon] library
    of Coq. Primarily, this is about supporting the [DProp] library
    instead of explicit usage of [sumbool]. In addition this files
    provides additional lemmas about [ConstructiveEpsilon], in
    particular the extensionality of the choice procedure. *)

Require Coq.Logic.ConstructiveEpsilon.
Require Import FinSet.Lib.DProp.
Import Coq.Classes.Morphisms.

(** * A [DProp] interface *)

Section Choice.

Context {A:Type} (to_nat:A->nat) (of_nat:nat->A).
Context (retract:forall x, of_nat(to_nat x) = x).
Context(P:A->DProp).

(** Indefinite description for inhabited countable types. *)
Definition choice : (exists x, P x) -> { x:A | P x } :=
  ConstructiveEpsilon.constructive_indefinite_ground_description
            A to_nat of_nat retract P (fun x=> dec_alt (P x))
.

(** [choose] is a choice operator on every inhabited countable
    type. The main result in this file is that [choose] only depends
    on the extension of [P] (and the encoding). *)
Definition choose (h:exists x, P x) : A := proj1_sig (choice h).

Lemma choose_spec : forall h, P (choose h).
Proof.
  intros **. unfold choose.
  apply proj2_sig.
Qed.

End Choice.
Arguments choose_spec A to_nat of_nat retract P h : clear implicits.

(** * [choose] is extensional *)

Lemma linear_search_ext : forall P P_dec Q Q_dec n w v, (forall x, P x <-> Q x) ->
         proj1_sig (ConstructiveEpsilon.linear_search P P_dec n w) =
         proj1_sig (ConstructiveEpsilon.linear_search Q Q_dec n v).
Proof.
  intros until Q_dec. fix 2. intros n [h₀ | h₁] [h₀'|h₁'] h.
  all:cbn.
  all:destruct (P_dec n) as [p|np], (Q_dec n) as [q|nq];cbn.
  all:try reflexivity.
  all:try solve[rewrite h in p; destruct (nq p)].
  all:try solve[rewrite <- h in q; destruct (np q)].
  all:apply linear_search_ext. all: assumption.
Qed.

Section ChoiceExt.

Context (A:Type).

Local Notation "'Π' x y ':' R ',' S" := (respectful_hetero _ _ _ _ R%signature (fun x y => S)%signature) (at level 200, x ident, y ident).

Lemma choose_ext : Proper
  (Π to_nat₁ to_nat₂ : eq==>eq,
   Π of_nat₁ of_nat₂ : eq==>eq,
   Π _ _ : (fun _ _ => True),
   Π P P' : eq==>eq_dprop,
   Π _ _ : (fun _ _ => True),
   @eq A) choose.
Proof.
  unfold Proper, respectful_hetero, respectful.
  intros to_nat₁ to_nat₂ h_to_nat
         of_nat₁ of_nat₂ h_of_nat
         retract₁ retract₂ _
         P P' hp
         [x hx] [y hy] _.
  unfold choose,choice,
         ConstructiveEpsilon.constructive_indefinite_ground_description.
  cbn.
  unfold ConstructiveEpsilon.P', ConstructiveEpsilon.P'_decidable.
  match goal with
  | |- proj1_sig (let (_,_) := ?X in _) = proj1_sig (let (_,_) := ?Y in _) =>
    enough (proj1_sig X = proj1_sig Y) as h₀
                  by (destruct X,Y;cbn in h₀|-*;now eauto)
  end.
  apply linear_search_ext. intros **.
  apply hp. eauto.
Qed.

End ChoiceExt.


Require Import
  HoTT.Classes.interfaces.abstract_algebra
  HoTT.Classes.theory.fields
  HoTT.Classes.theory.apartness.
Require Export
  HoTT.Classes.theory.rings.

Generalizable Variables F f R.

Section contents.
Context `{IsDecField F} `{forall x y: F, Decidable (x = y)}.

(* Add Ring F : (stdlib_ring_theory F). *)

Global Instance decfield_zero_product : ZeroProduct F.
Proof.
intros x y E.
destruct (dec (x = 0)) as [? | Ex];auto.
right.
rewrite <-(mult_1_r y), <-(dec_recip_inverse x) by assumption.
rewrite associativity, (commutativity y), E.
apply mult_0_l.
Qed.

Global Instance decfield_integral_domain : IsIntegralDomain F.
Proof.
split; try apply _.
Qed.

Lemma dec_recip_1: / 1 = 1.
Proof.
rewrite <-(rings.mult_1_l (/1)).
apply dec_recip_inverse.
solve_propholds.
Qed.

Lemma dec_recip_distr (x y: F): / (x * y) = / x * / y.
Proof.
destruct (dec (x = 0)) as [Ex|Ex].
- rewrite Ex, left_absorb, dec_recip_0. apply symmetry,mult_0_l.
- destruct (dec (y = 0)) as [Ey|Ey].
  + rewrite Ey, dec_recip_0, !mult_0_r. apply dec_recip_0.
  + assert (x * y <> 0) as Exy by (apply mult_ne_0;trivial).
    apply (left_cancellation_ne_0 (.*.) (x * y)); trivial.
    transitivity (x / x * (y / y)).
    * rewrite !dec_recip_inverse by assumption. rewrite mult_1_l;apply reflexivity.
    * rewrite !dec_recip_inverse by assumption.
      rewrite mult_assoc, (mult_comm x), <-(mult_assoc y).
      rewrite dec_recip_inverse by assumption.
      rewrite (mult_comm y), <-mult_assoc.
      rewrite dec_recip_inverse by assumption. reflexivity.
Qed.

Lemma dec_recip_zero x : / x = 0 <-> x = 0.
Proof.
split; intros E.
- apply stable. intros Ex.
  destruct (is_ne_0 1).
  rewrite <-(dec_recip_inverse x), E by assumption.
  apply mult_0_r.
- rewrite E. apply dec_recip_0.
Qed.

Lemma dec_recip_ne_0_iff x : / x <> 0 <-> x <> 0.
Proof.
split; intros E1 E2; destruct E1; apply dec_recip_zero;trivial.
do 2 apply (snd (dec_recip_zero _)). trivial.
Qed.

Instance dec_recip_ne_0 x : PropHolds (x <> 0) -> PropHolds (/x <> 0).
Proof.
intro.
apply (snd (dec_recip_ne_0_iff _)).
trivial.
Qed.

Lemma equal_by_one_quotient (x y : F) : x / y = 1 -> x = y.
Proof.
intro Exy.
destruct (dec (y = 0)) as [Ey|Ey].
- destruct (is_ne_0 1).
  rewrite <- Exy, Ey, dec_recip_0. apply mult_0_r.
- apply (right_cancellation_ne_0 (.*.) (/y)).
  + apply dec_recip_ne_0. trivial.
  + rewrite dec_recip_inverse;trivial.
Qed.

Global Instance dec_recip_inj: IsInjective (/).
Proof.
repeat (split; try apply _).
intros x y E.
destruct (dec (y = 0)) as [Ey|Ey].
- rewrite Ey in *. rewrite dec_recip_0 in E.
  apply dec_recip_zero. trivial.
- apply (right_cancellation_ne_0 (.*.) (/y)).
  + apply dec_recip_ne_0. trivial.
  + rewrite dec_recip_inverse by assumption.
    rewrite <-E, dec_recip_inverse;trivial.
    apply dec_recip_ne_0_iff. rewrite E.
    apply dec_recip_ne_0. trivial.
Qed.

Global Instance dec_recip_involutive: Involutive (/).
Proof.
intros x. destruct (dec (x = 0)) as [Ex|Ex].
- rewrite Ex, !dec_recip_0. trivial.
- apply (right_cancellation_ne_0 (.*.) (/x)).
  + apply dec_recip_ne_0. trivial.
  + rewrite dec_recip_inverse by assumption.
    rewrite mult_comm, dec_recip_inverse.
    * reflexivity.
    * apply dec_recip_ne_0. trivial.
Qed.

Lemma equal_dec_quotients (a b c d : F) : b <> 0 -> d <> 0 ->
  (a * d = c * b <-> a / b = c / d).
Proof.
split; intro E.
- apply (right_cancellation_ne_0 (.*.) b);trivial.
  apply (right_cancellation_ne_0 (.*.) d);trivial.
  transitivity (a * d * (b * /b));[|
  transitivity (c * b * (d * /d))].
  + rewrite <-!(mult_assoc a). apply ap.
    rewrite (mult_comm d), (mult_comm _ b).
    reflexivity.
  + rewrite E, dec_recip_inverse, dec_recip_inverse;trivial.
  + rewrite <-!(mult_assoc c). apply ap.
    rewrite (mult_comm d), mult_assoc, (mult_comm b).
    reflexivity.
- transitivity (a * d * 1);[rewrite mult_1_r;reflexivity|].
  rewrite <-(dec_recip_inverse b);trivial.
  transitivity (c * b * 1);[|rewrite mult_1_r;reflexivity].
  rewrite <-(dec_recip_inverse d);trivial.
  rewrite mult_comm, <-mult_assoc, (mult_assoc _ a), (mult_comm _ a), E.
  rewrite <-mult_assoc. rewrite (mult_comm _ d).
  rewrite mult_assoc, (mult_comm c). reflexivity.
Qed.

Lemma dec_quotients (a c b d : F)
  : b <> 0 -> d <> 0 -> a / b + c / d = (a * d + c * b) / (b * d).
Proof.
intros A B.
assert (a / b = (a * d) / (b * d)) as E1.
- apply equal_dec_quotients;auto.
  + solve_propholds.
  + rewrite (mult_comm b);apply associativity.
- assert (c / d = (b * c) / (b * d)) as E2.
  + apply equal_dec_quotients;trivial.
    * solve_propholds.
    * rewrite mult_assoc, (mult_comm c). reflexivity.
  + rewrite E1, E2.
    rewrite (mult_comm c b).
    apply symmetry, simple_distribute_r.
Qed.

Lemma dec_recip_swap_l x y: x / y = / (/ x * y).
Proof.
rewrite dec_recip_distr, involutive. reflexivity.
Qed.

Lemma dec_recip_swap_r x y: / x * y = / (x / y).
Proof.
rewrite dec_recip_distr, involutive.
reflexivity.
Qed.

Lemma dec_recip_negate x : -(/ x) = / (-x).
Proof.
destruct (dec (x = 0)) as [Ex|Ex].
- rewrite Ex, negate_0, dec_recip_0, negate_0. reflexivity.
- apply (left_cancellation_ne_0 (.*.) (-x)).
  + apply (snd (flip_negate_ne_0 _)). trivial.
  + rewrite dec_recip_inverse.
    * rewrite negate_mult_negate. apply dec_recip_inverse. trivial.
    * apply (snd (flip_negate_ne_0 _)). trivial.
Qed.
End contents.

(* Due to bug #2528 *)
#[export]
Hint Extern 7 (PropHolds (/ _ <> 0)) =>
  eapply @dec_recip_ne_0 : typeclass_instances.

(* Given a decidable field we can easily construct a constructive field. *)
Section is_field.
  Context `{IsDecField F} `{Apart F} `{!TrivialApart F}
    `{Decidable.DecidablePaths F}.

  Global Instance recip_dec_field: Recip F := fun x => / x.1.

  Local Existing Instance dec_strong_setoid.

  Global Instance decfield_field : IsField F.
  Proof.
  split; try apply _.
  - apply (dec_strong_binary_morphism (+)).
  - apply (dec_strong_binary_morphism (.*.)).
  - intros [x Px]. rapply (dec_recip_inverse x).
    apply trivial_apart. trivial.
  Qed.

  Lemma dec_recip_correct (x : F) Px : / x = // (x;Px).
  Proof.
  apply (left_cancellation_ne_0 (.*.) x).
  - apply trivial_apart. trivial.
  - rewrite dec_recip_inverse, reciperse_alt by (apply trivial_apart;trivial).
    reflexivity.
  Qed.
End is_field.

(* Definition stdlib_field_theory F `{DecField F} :
  Field_theory.field_theory 0 1 (+) (.*.) (fun x y => x - y)
    (-) (fun x y => x / y) (/) (=).
Proof with auto.
  intros.
  constructor.
     apply (theory.rings.stdlib_ring_theory _).
    apply (is_ne_0 1).
   reflexivity.
  intros.
  rewrite commutativity. now apply dec_recip_inverse.
Qed. *)

(* Section from_stdlib_field_theory.
  Context `(ftheory : @field_theory F Fzero Fone Fplus Fmult Fminus Fnegate
    Fdiv Frecip Fe)
    (rinv_0 : Fe (Frecip Fzero) Fzero)
    `{!@Setoid F Fe}
    `{!Proper (Fe ==> Fe ==> Fe) Fplus}
    `{!Proper (Fe ==> Fe ==> Fe) Fmult}
    `{!Proper (Fe ==> Fe) Fnegate}
    `{!Proper (Fe ==> Fe) Frecip}.

  Add Field F2 : ftheory.

  Definition from_stdlib_field_theory: @DecField F Fe Fplus Fmult
    Fzero Fone Fnegate Frecip.
  Proof with auto.
   destruct ftheory.
   repeat (constructor; try assumption); repeat intro
   ; unfold equiv, mon_unit, sg_op, zero_is_mon_unit, plus_is_sg_op,
     one_is_mon_unit, mult_is_sg_op, plus, mult, recip, negate; try field.
   unfold recip, mult.
   simpl.
   assert (Fe (Fmult x (Frecip x)) (Fmult (Frecip x) x)) as E by ring.
   rewrite E.
  Qed.
End from_stdlib_field_theory. *)

Section morphisms.
  Context  `{IsDecField F} `{TrivialApart F} `{Decidable.DecidablePaths F}.

  Global Instance dec_field_to_domain_inj `{IsIntegralDomain R}
    `{!IsSemiRingPreserving (f : F -> R)} : IsInjective f.
  Proof.
  apply injective_preserves_0.
  intros x Efx.
  apply stable. intros Ex.
  destruct (is_ne_0 (1:R)).
  rewrite <-(rings.preserves_1 (f:=f)).
  rewrite <-(dec_recip_inverse x) by assumption.
  rewrite rings.preserves_mult, Efx.
  apply left_absorb.
  Qed.

  Lemma preserves_dec_recip `{IsDecField F2} `{forall x y: F2, Decidable (x = y)}
    `{!IsSemiRingPreserving (f : F -> F2)} x : f (/ x) = / f x.
  Proof.
  case (dec (x = 0)) as [E | E].
  - rewrite E, dec_recip_0, preserves_0, dec_recip_0. reflexivity.
  - intros.
    apply (left_cancellation_ne_0 (.*.) (f x)).
    + apply isinjective_ne_0. trivial.
    + rewrite <-preserves_mult, 2!dec_recip_inverse.
      * apply preserves_1.
      * apply isinjective_ne_0. trivial.
      * trivial.
  Qed.

  Lemma dec_recip_to_recip `{IsField F2} `{!IsSemiRingStrongPreserving (f : F -> F2)}
    x Pfx : f (/ x) = // (f x;Pfx).
  Proof.
  assert (x <> 0).
  - intros Ex.
    destruct (apart_ne (f x) 0 Pfx).
    rewrite Ex, (preserves_0 (f:=f)). reflexivity.
  - apply (left_cancellation_ne_0 (.*.) (f x)).
    + apply isinjective_ne_0. trivial.
    + rewrite <-preserves_mult, dec_recip_inverse, reciperse_alt by assumption.
      apply preserves_1.
  Qed.
End morphisms.


Require Export XR_Rminus.
Require Export XR_Rplus_opp_r.

Local Open Scope R_scope.
Implicit Type r : R.

Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> R0 -> r1 <> r2.
Proof.
  intros x y.
  intro hneq.
  unfold not.
  intro heq.
  subst y.
  unfold not in hneq.
  apply hneq.
  unfold Rminus.
  rewrite Rplus_opp_r.
  reflexivity.
Qed.