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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj17eqsynthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 lv1) (plus lv1 lv0)).
Admitted.
QuickChick conj17eqsynthconj6.


Require Import List Arith.
Require Import FSets FSetAVL FSetFacts FSetEqProperties FSetProperties.
Require Import Tools Model Patterns.

Definition P00 (u2 : schedule) :=
  exists i v, u2 = (Wm,i)::v++(Wm,i)::nil /\ ~ In (Dm,i) v.

Definition f00 (u2 :schedule) := tl u2.

Lemma red_fun_f00 :
  reducing_function P00 (fun _ => True) f00.
Proof.
  exists (length % list op);split.
  unfold mesure; apply app_length.
  intros u2 _ u3 (i & v & hu2 & hv).
  destruct u2;cauto.
  split;[|split;[split|split]];unfold f00;
  try rewrite cost_unit; auto with arith;
  inversion hu2.
  intros e h;simpl.
  split;auto.
  inversion h;cauto.
  repeat split;
  simpl;auto;try apply NP.subset_refl;
  intro h1;try (apply NP.Dec.F.add_iff;right;auto).
  rewrite NP.Dec.F.add_iff in h1; destruct h1 as [->|ha];auto.
  cut (forall i v e w, ~ In (Dm,i) v ->
                   NSet.MSet.In i (get_memory (e ⇒ (v ++ (Wm,i)::w)))).
  intros hh;apply hh;auto.
  clear o u2 u3 v hu2 hv H0 H1 e h a.
  induction v;intros e w h;simpl.
  rewrite NP.Dec.F.add_iff in *;auto.
  destruct a as (o,k);destruct o; simpl;
  try (apply IHv;intro h';apply h;simpl;right;assumption);
  case (eq_nat_dec k i) as [->|hk].
  rewrite NP.Dec.F.add_iff in *;auto.
  rewrite NP.Dec.F.add_iff in *;right;
  apply IHv;intro h';apply h;simpl;right;assumption.
  exfalso;apply h;left;auto.
  rewrite NP.Dec.F.remove_iff in *;split;auto.
  apply IHv;intro h';apply h;simpl;right;assumption.
Qed.

Lemma dec_P00 : forall u, Decidable.decidable (P00 u).
Proof.
  intro u.
  unfold P00.
  cut (Decidable.decidable
         (exists v w,
            u=v++w
            /\ (exists v1 v2,
                  v=v1++v2
                  /\
                  (exists i,
                     v1=(Wm,i)::nil
                     /\ ~ In (Dm,i) v2
                     /\ w=(Wm,i)::nil)))).
  intros [(v & w & -> & v1 & v2 & -> & i & -> & hv2 & -> )|h].
  left;exists i; exists v2;repeat split;simpl;auto.
  right; intros (i & v & -> & hv).
  apply h; exists ((Wm,i)::v); exists ((Wm,i)::nil);
  split;auto;exists ((Wm,i)::nil);exists v;split;auto;
  exists i;repeat split;auto.

  apply app_prop_dec.
  intros v w;apply app_prop_dec.
  intros v1 v2.
  destruct v1 as [|(o & i) v1].
  right;intros (i & h1 & h2 & h3);cauto.
  destruct o;
    try (right;intros (k & h1 & h2 & h3);blast).
  destruct w as [|(o & j) w];
    try (right;intros (k & h1 & h2 & h3);blast).
  destruct o;
    try (right;intros (k & h1 & h2 & h3);blast).
  case (eq_nat_dec i j) as [->|hij];
    [|right;intros (k & h1 & h2 & h3);
      inversion h1;inversion h3;rewrite H0 in *;
      rewrite H2 in *;cauto].
  destruct v1 as [|a v1];
    try (right;intros (k & h1 & h2 & h3);blast).
  destruct w as [|b w];
    try (right;intros (k & h1 & h2 & h3);blast).
  case (in_dec eq_op_dec (Dm,j) v2) as [h|h].
  right;intros (k & h1 & h2 & h3);
      inversion h1;rewrite H0 in *;cauto.
  left;exists j;repeat split;auto.
Qed.

Definition K00 u := ~ pattern P00 u.

Lemma lem00 :
  (exists u : schedule, good u) ->
  exists v, good v /\ K00 v.
Proof.
  intros (u & hu).
  assert (reducing_function P00 (fun _ => True) f00) as h.
  apply red_fun_f00.
  eapply (fun_no_pattern P00 _ f00) in h.
  destruct h as (v & hp & hb & _).
  exists v; split;auto.
  eapply better_good;eauto.
  apply dec_P00.
Qed.

Lemma preserve00_tl (P : schedule -> Prop) f :
  (forall u, f u = tl u) ->
  (forall o i u, P ((o,i)::u) -> o<>Wm /\ o<> Dm) ->
  forall u2 u1 u3 : schedule,
    P u2 ->
    K00 (u1 ++ u2 ++ u3) -> K00 (u1 ++ f u2 ++ u3).
Proof.
  intros hf hP u2 u1 u3 hu2 hk00.
  apply (f_preserve_pat_tail _ P);auto;
  [intros a b
  |
  |intros a u v w h1 (i & v' & h3 & h4) h5 h6
  |intros a u v w h1 (i & v' & h3 & h4) h5 h6];
  try rewrite hf in *; simpl in *;auto;
  clear u1 u2 u3 hk00 hu2.

  destruct a; apply hP in h1;destruct h1 as (h1 & h2);
  destruct w;[contradict h6;auto|]; inversion h3 as ( (ho & h7) ).
  apply app_inv_tail in h7 as (u' & -> & ->);auto.
  exists i;exists (w++(o,n)::u');split;
  [rewrite app_ass ;auto|].

  intro h;apply in_app_or in h; case h as [h|[h|h]];cauto;
  [|inversion h;auto|];
  apply h4;apply in_or_app;[left|right];auto.

  destruct a; apply hP in h1;destruct h1 as (h1 & h2);
  destruct v;[contradict h6;auto|]; inversion h3 as ( (ho & h7) ).
  apply app_inv_tail in h7 as (u' & -> & ->);auto.
  exists i;exists (v++(o,n)::u');split;
  [rewrite app_ass ;auto|].

  intro h;apply in_app_or in h; case h as [h|[h|h]];cauto;
  [|inversion h;auto|];
  apply h4;apply in_or_app;[left|right];auto.
Qed.

Definition P01 (u : schedule) := exists i, u=(Dd,i)::nil.

Definition f01 (u : schedule) : schedule := tl u.

Definition K01 u := ~ pattern P01 u /\ K00 u.

Lemma red_fun_f01 :
  reducing_function P01 K00 f01.
Proof.
  exists (length % list op).
  split.
  unfold mesure;apply app_length.
  intros u1 u2 u3 (i & ->).
  repeat split;auto.
  simpl.
  apply NP.subset_remove_3;apply NP.subset_refl.
  apply (preserve00_tl P01);intros;auto.
  destruct H as (j & h );inversion h;split;intro;cauto.
  exists i;auto.
Qed.

Lemma P01_equiv_In u :
  pattern P01 u <-> exists i, In (Dd,i) u.
Proof.
  split;[intros (u1 & u2 & u3 & -> & i & ->)|intros (i&h)].
  exists i;apply in_or_app; right;apply in_or_app;left;left;auto.
  apply in_split in h as (u1 & u3 & ->) ;exists u1;
  exists ((Dd,i)::nil);exists u3;split;auto;exists i;auto.
Qed.

Lemma preserve_01 P f :
  (forall u i, P u -> In (Dd,i) (f u) -> In (Dd,i) u)
  -> forall u1 u2 u3, P u2 ->
                      ~pattern P01 (u1++u2++u3) ->
                      ~pattern P01 (u1++f u2++u3).
Proof.
  intros hf u1 u2 u3 hp hk hu.
  rewrite P01_equiv_In in *.
  destruct hu as (i & h);apply in_app_or in h as [h|h].
  apply hk;exists i;apply in_or_app;left;auto.
  apply in_app_or in h as [h|h].
  apply hk;exists i;apply in_or_app;right;apply in_or_app;left;auto.
  apply hk;exists i;apply in_or_app;right;apply in_or_app;right;auto.
Qed.


Require Import Coq.Lists.List.
Import ListNotations.
Definition SetVars  := nat.
Definition FuncSymb := nat.
Definition PredSymb := nat.
Record FSV := {
 fs : FuncSymb;
 fsv : nat;
}.
Record PSV := MPSV{
 ps : PredSymb;
 psv : nat;
}.
Inductive preTerms :=
|Vari : SetVars -> preTerms
|Node : FSV -> list preTerms -> preTerms.
Fixpoint isNTerm (n:nat) (x : preTerms) {struct n}: Prop
:=match n with
  | 0 => True
  | S n =>
   match x with
   | Vari v => True
   | Node f lp => (and ((length lp)=(fsv f)) (Forall (isNTerm n) lp))
   end
  end.
Notation isTerm := (fun x =>  (forall (n:nat), isNTerm n x)).
Record Terms := {
 Terms_x : preTerms;
 Terms_H : isTerm Terms_x;
}.
Check Build_Terms.

(* Good *)
Theorem VariIsTerm s y: isNTerm y (Vari s).
Proof.
destruct y.
exact I.
simpl in * |- *.
exact I.
Show Proof.
Defined.

Definition make_visible {X} (f : X) := f.

Notation "` f" := (make_visible f) (at level 5, format "` f").

Tactic Notation "unfold" "notation" constr(f) :=
  change f with (`f).
Tactic Notation "fold" "notation" constr(f) :=
  unfold make_visible.
(*
Fixpoint ListInst A P (t:A) ls :
(Forall P ls)->(In t ls)->(P t).
intros z w.
unfold In in w.
destruct ls.
destruct w.
destruct w.
rewrite <- H.
eapply Forall_inv.
exact z.
eapply ListInst.
2 : { exact H. }*)

(* \u0422\u0435\u043f\u0435\u0440\u044c \u043d\u0430\u0434\u043e \u043f\u043e\u043a\u0430\u0437\u0430\u0442\u044c, \u0447\u0442\u043e \u0435\u0441\u043b\u0438 \u043d\u0435\u043a\u043e\u0442\u043e\u0440\u044b\u0439 \u043f\u0440\u0435\u0442\u0435\u0440\u043c \u044f\u0432\u043b\u044f\u0435\u0442\u0441\u044f \u0442\u0435\u0440\u043c\u043e\u043c, \u0442\u043e
\u0438 \u0435\u0433\u043e \u0430\u0440\u0433\u0443\u043c\u0435\u043d\u0442\u044b-\u043f\u0440\u0435\u0442\u0435\u0440\u043c\u044b \u0442\u043e\u0436\u0435 \u044f\u0432\u043b\u044f\u044e\u0442\u0441\u044f \u0442\u0435\u0440\u043c\u0430\u043c\u0438.
\u041f\u0443\u0441\u0442\u044c A - \u043f\u0440\u0435\u0442\u0435\u0440\u043c, \u0442\u043e\u0433\u0434\u0430 (isTerm f ls)/\(In A ls) -> (isTerm A).
*)
Fixpoint ArgIsTerm (f:FSV) (ls:_) A:
(isTerm (Node f ls)) -> (In A ls) -> (isTerm A).
Proof.
intros H H0.
destruct A. (* \u041a\u0430\u043a\u043e\u0433\u043e \u0432\u0438\u0434\u0430 \u0442\u0435\u0440\u043c? *)
- apply VariIsTerm. (* \u041e\u043a!*)
- intro n.
  pose (Q:= H (S n)).
  destruct H.
Check Forall_forall.
pose (GQ := Forall_forall (isNTerm n) ls).
destruct GQ.
apply H1.
assumption.
assumption.
Defined.

Fixpoint Another (f:FSV) (ls:_) : (isTerm (Node f ls)) -> (In A ls).

(* \u0422\u0435\u043f\u0435\u0440\u044c \u043f\u0440\u0435\u043e\u0431\u0440\u0430\u0437\u043e\u0432\u0430\u043d\u0438\u044f \u0441\u043f\u0438\u0441\u043a\u0430 \u043f\u0440\u0435\u0442\u0435\u0440\u043c\u043e\u0432. *)
Check True.
Notation W := ArgIsTerm.
Definition W' f ls A x y := W f ls A y x.

Fixpoint preobr (f : FSV) (ls : list preTerms)
(H:forall n : nat, isNTerm n (Node f ls))
{struct ls}: list Terms.
destruct f.
destruct fsv0.
exact [].
destruct ls as [|p ls0].
exact [].
simpl in H.
assert (G: forall n : nat, isNTerm n (Node {| fs := fs0; fsv := fsv0 |} ls0)).
2 : { exact (preobr {| fs := fs0; fsv := fsv0 |} ls0 G). }
simpl in * |- *.

intro y.
induction y; simpl.
exact I.
pose (NQ:= H y ).
(*pose (NQ:= H (S fsv0)).*)
simpl in * |- *.
(*destruct NQ.*)
split.
auto.

Check Forall_inv.

arith.
exact H0.
destruct (H y).
split.
admit.
Admitted.

refine (
match ls with
| [] => []
| a::q => preobr f q _
end ).
destruct n; simpl.
exact I. (* Interesting *)

Definition preobr : forall (f : FSV) (ls : list preTerms) (A : preTerms),
       In A ls ->
       (forall n : nat, isNTerm n (Node f ls)) -> forall n : nat, isNTerm n A.

Fixpoint Com :
Check True.
(*
assert (Y:isTerm (Node f ls)).
unfold notation isTerm.
change isTerm with (fun x =>  (forall (n:nat), isNTerm n x)) in * |- *.
unfold notation isTerm.
intro y.
destruct y.
simpl in * |- *.
Section heredity.
(* 1 Context (t:Terms). *)
(* 2 Context (f:FSV) (l :list preTerms).
Context (H: isTerm (Node f l)). *)
(* 3 *)
Context (f:FSV) (a:preTerms) (l0 :list preTerms).
Context (H: isTerm (Node f (a::l0))).
Theorem thm : isTerm a.
unfold isTerm.
fix K 1.
intro n.
pose (G := H n).
*)
Check True.

Fixpoint Make_TermsList f (l:list preTerms)(H:isTerm (Node f l)) {struct l}: list Terms.

Fixpoint Make_TermsList (t:Terms) : list Terms.
elim t;intros.
destruct Terms_x0 eqn: g.
(*destruct Terms_x0.*)
(*elim Terms_x0;intros.*)
exact [].
change Terms_x0 with (Node f l) in Terms_H0.
(*rewrite <- g in Terms_H0.*)
pose (fu:= (fun A => W _ _ A Terms_H0)).

unshelve eapply (List.map  _ l).
intros p.
simple refine ((Build_Terms _ _)).
exact p.
intro c.
Check W f (p::l) p.
(*
simple eapply (W f (l) ).
assumption.
simple eapply (W f (p::l) p ).
simpl.

intro NN.

Print Node.
constructor.
simpl.

 BAD *)

destruct l.
exact [].
simple refine ((Build_Terms _ _) :: _ ).
exact p.
intro c.
simple eapply (W f (p::l) p Terms_H0).

firstorder. (*GOOD*)

Show Proof.

eapply Make_TermsList.

eapply fu.

unfold isTerm in * |- *.
revert l Terms_H0; fix W 1; intros l Terms_H0.
elim l.
exact [].
intros.
refine ((Build_Terms a _)  :: (W l0 _)).
intro m.
induction m.
simpl in * |- *.
trivial.
 (Terms_H0 m).

2 : {

destruct (Terms_H0 2).
simpl in * |- *.
Fixpoint isParamT (xi : SetVars) (t : Terms) {struct t} : bool :=
   match t.(Terms_x) with
   | Vari s => PeanoNat.Nat.eqb s xi
   | Node f t0 => List.fold_left orb (List.map (isParamT xi) t0) false
   end.


(*|
################################################################################
Retrieving constraints from GADT to ensure exhaustion of pattern matching in Coq
################################################################################

:Link: https://stackoverflow.com/q/56525092
|*)

(*|
Question
********

Let's define two helper types:
|*)

Inductive AB : Set := A | B.
Inductive XY : Set := X | Y.

(*| Then two other types that depend on ``XY`` and ``AB`` |*)

Inductive Wrapped : AB -> XY -> Set :=
| W : forall (ab : AB) (xy : XY), Wrapped ab xy
| WW : forall (ab : AB), Wrapped ab (match ab with A => X | B => Y end).

Inductive Wrapper : XY -> Set :=
  WrapW : forall (xy : XY), Wrapped A xy -> Wrapper xy.

(*|
Note the ``WW`` constructor – it can only be value of types ``Wrapped
A X`` and ``Wrapped B Y``.

Now I would like to pattern match on ``Wrapper Y``:

.. coq:: unfold fails
|*)

Fail Definition test (wr : Wrapper Y) : nat :=
  match wr with
  | WrapW Y w =>
    match w with
    | W A Y => 27
    end
  end.

(*|
Why does it happen? ``Wrapper`` forces contained ``Wrapped`` to be
``A`` version, the type signature forces ``Y`` and ``WW`` constructor
forbids being ``A`` and ``Y`` simultaneously. I don't understand why
this case is being even considered, while I am forced to check it
which seems to be impossible.

How to workaround this situation?
|*)

(*|
Answer (HTNW)
*************

Let's simplify:
|*)

Inductive MyTy : Set -> Type :=
  MkMyTy : forall (A : Set), A -> MyTy A.

Fail Definition extract (m : MyTy nat) : nat :=
  match m with MkMyTy _ x => S x end. (* .unfold .fails *)

(*|
This is because I said

.. code-block:: coq

    Inductive MyTy : Set -> Type

This made the first argument to ``MyTy`` an index of ``MyTy``, as
opposed to a parameter. An inductive type with a parameter may look
like this:
|*)

Inductive list (A : Type) : Type :=
| nil : list A
| cons : A -> list A -> list A.

(*|
Parameters are named on the left of the ``:``, and are not
``forall``-d in the definition of each constructor. (They are still
present in the constructors' types outside of the definition: ``cons :
forall (A : Type), A -> list A -> list A``.) If I make the ``Set`` a
parameter of ``MyTy``, then ``extract`` can be defined:
|*)

Reset Initial. (* .none *)
Inductive MyTy (A : Set) : Type :=
  MkMyTy : A -> MyTy A.

Definition extract (m : MyTy nat) : nat :=
  match m with MkMyTy _ x => S x end.

(*|
The reason for this is that, on the inside, a ``match`` *ignores*
anything you know about the indices of the scrutinee from the outside.
(Or, rather, the underlying ``match`` expression in Gallina ignores
the indices. When you write a ``match`` in the source code, Coq tries
to convert it into the primitive form while incorporating information
from the indices, but it often fails.) The fact that ``m : MyTy nat``
in the first version of ``extract`` simply did not matter. Instead,
the match gave me ``S : Set`` (the name was automatically chosen by
Coq) and ``x : S``, as per the constructor ``MkMyTy``, with no mention
of ``nat``. Meanwhile, because ``MyTy`` has a parameter in the second
version, I actually get ``x : nat``. The ``_`` is really a placeholder
this time; it is mandatory to write it as ``_``, because there's
nothing to match, and you can ``Set Asymmetric Patterns`` to make it
disappear.

The reason we distinguish between parameters and indices is because
parameters have a lot of restrictions—most notably, if ``I`` is an
inductive type with parameters, then the parameters must appear as
variables in the return type of each constructor:

.. coq:: fails
|*)

Fail Inductive F (A : Set) : Set := MkF : list A -> F (list A).
                                                 (* ^--------^
                                                    BAD: must appear as F A *)

(*|
In your problem, we should make parameters where we can. E.g. the
``match wr with Wrap Y w => _ end`` bit is wrong, because the ``XY``
argument to ``Wrapper`` is an index, so the fact that ``wr : Wrapper
Y`` is ignored; you would need to handle the ``Wrap X w`` case too.
Coq hasn't gotten around to telling you that.
|*)

Reset Wrapped. (* .none *)
Inductive Wrapped (ab : AB) : XY -> Set :=
| W : forall (xy : XY), Wrapped ab xy
| WW : Wrapped ab (match ab with A => X | B => Y end).

Inductive Wrapper (xy : XY) : Set := WrapW : Wrapped A xy -> Wrapper xy.

(*| And now your ``test`` compiles (almost): |*)

Definition test (wr : Wrapper Y) : nat :=
  match wr with
  | WrapW _ w => (* mandatory _ *)
    match w with
    | W _ Y => 27 (* mandatory _ *)
    end
  end.

(*|
because having the parameters gives Coq enough information for its
``match``-elaboration to use information from ``Wrapped``'s index. If
you issue ``Print test.``, you can see that there's a bit of
hoop-jumping to pass information about the index ``Y`` through the
primitive ``match``\ s which would otherwise ignore it. `See the
reference manual for more information.
<https://coq.inria.fr/refman/addendum/extended-pattern-matching.html>`__
|*)

(*|
Answer (radrow)
***************

The solution turned out to be simple but tricky:

.. coq:: none
|*)

Reset Initial.
Inductive AB : Set := A | B.
Inductive XY : Set := X | Y.

Inductive Wrapped : AB -> XY -> Set :=
| W : forall (ab : AB) (xy : XY), Wrapped ab xy
| WW : forall (ab : AB), Wrapped ab (match ab with A => X | B => Y end).

Inductive Wrapper : XY -> Set :=
  WrapW : forall (xy : XY), Wrapped A xy -> Wrapper xy.

(*||*)

Definition test (wr : Wrapper Y): nat.
  refine (match wr with
          | WrapW Y w =>
            match w in Wrapped ab xy return ab = A -> xy = Y -> nat with
            | W A Y => fun _ _ => 27
            | _ => fun _ _ => _
            end eq_refl eq_refl
          end);
    [ | | destruct a]; congruence.
Defined.

(*|
The issue was that Coq didn't infer some necessary invariants to
realize that ``WW`` case is ridiculous. I had to explicitly give it a
proof for it.

In this solution I changed ``match`` to return a function that takes
two proofs and brings them to the context of our actual result:

- ``ab`` is apparently ``A``
- ``xy`` is apparently ``Y``

I have covered real cases ignoring these assumptions, and I deferred
"bad" cases to be proven false later which turned to be trivial. I was
forced to pass the ``eq_refl``\ s manually, but it worked and does not
look that bad.
|*)


From Coq Require Import
     Relation_Definitions
     RelationClasses
.

Require Import Fix.
Require Import GHC.Base.

Variant RefinesOrder {F : Set -> Set}
        (Kr : forall (A : Set), relation (F A))
        {A : Set} : relation (F A) :=
| RefinesRefl : forall (a : F A), RefinesOrder Kr a a
| RefinesTrans : forall (a b c : F A),
    Kr _ a b -> Kr _ b c -> RefinesOrder Kr a c.

#[export] Instance FunctorRel__RefinesOrder {F : Set -> Set} :
  FunctorRel (F:=F) RefinesOrder.
constructor. intros. destruct H0.
- apply RefinesRefl.
- eapply RefinesTrans; apply H; eassumption.
Qed.

Section RefinesOrder_SmartConstructors.

  Variable F : Set -> Set.
  Variable R : (forall (A : Set), relation (F A)) ->
               forall (A : Set), relation (F A).

  Context `{FunctorRel F R} `{RefinesOrder -⋘ R}.

  Lemma refinesRefl : forall {A : Set} (a : F A),
      FixRel R _ a a.
  Proof.
    intros. apply inFRel, injRel.
    apply RefinesRefl.
  Qed.

  Lemma refinesTrans : forall {A : Set} (a b c : F A),
      FixRel R _ a b -> FixRel R _ b c -> FixRel R _ a c.
  Proof.
    intros. apply inFRel, injRel.
    eapply RefinesTrans; eassumption.
  Qed.

  Global Instance PreOrder_RefinesOrder {A : Set} : PreOrder (FixRel R A).
  Proof.
    constructor.
    - intros a. apply refinesRefl.
    - intros a b c. apply refinesTrans.
  Qed.

End RefinesOrder_SmartConstructors.


(** Coq coding by choukh, Oct 2021 **)

Require Import BBST.Axiom.Meta.
Require Import BBST.Axiom.Separation.
Require Import BBST.Axiom.Infinity.
Require Import BBST.Definition.Singleton.
Require Import BBST.Definition.Omega.

Module 错误示范.

Axiom ℕ : 集合.

Axiom 零是自然数 : ∅ ∈ ℕ.
Axiom 一是自然数 : ∅⁺ ∈ ℕ.
Axiom 二是自然数 : ∅⁺⁺ ∈ ℕ.
Axiom 三是自然数 : ∅⁺⁺⁺ ∈ ℕ.

Axiom 以此类推 : ∀n ∈ ℕ, n⁺ ∈ ℕ.

Axiom 这不是自然数 : {{∅,},} ∉ ℕ.
Axiom 这也不是自然数 : {{{∅,},},} ∉ ℕ.
(* ヽ(`Д´)ﾉ *)

End 错误示范.

Theorem 非零自然数的前驱存在 : ∀n ∈ ω, n ≠ ∅ → ∃k ∈ ω, n = k⁺.
Proof.
  set (λ n, n ≠ ∅ → ∃k ∈ ω, n = k⁺) as P.
  apply (归纳法 P).
  - (* n = ∅ *)
    intros 矛盾. easy.
  - (* n = m⁺ *) intros n Hn 归纳假设.
    intros _. exists n. split; easy.
Qed.

(* 练习5-1 *)
Fact 零小于后继数 : ∀n ∈ ω, ∅ ∈ n⁺.
Proof.
  (* 不使用auto *)
Admitted.


(* SLOT, proofs about distributed systems design
   Copyright (C) 2019-2021  0k2

   This program is free software: you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation, version 3 of the License.

   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program.  If not, see <https://www.gnu.org/licenses/>.
 *)

(** * Fundamental definitions for modeling the nondeterminisic concurrent systems
 *)

(* begin hide *)
From Coq Require Import
     Program
     List
     Ensembles.

Import ListNotations.

Declare Scope slot_scope.
Open Scope slot_scope.
(* end hide *)

(** ** State space

[StateSpace] class is an abstraction used to describe side effects of
syscalls.

*** Parameters:

 - <<State>> — set of points of the state space

 - <<Event>> — set of events

*** Methods:

[state_transition s e s'] is a type of statements that read as "Event
[e] can transition the system from state [s] to [s']".

 *)
Class StateSpace (State Event : Type) :=
  { state_transition : State -> Event -> State -> Prop;
  }.

Notation "a '~[' b ']~>' c" := (state_transition a b c)(at level 40) : slot_scope.

(** For example suppose <<S>> is [nat] and <<TE>> is [Inductive TE := increment.]

Then the state transition method for the side effects of <<TE>> can be defined like this:

[[
state_transition s event s' =
  match event with
  | increment => s' = s + 1
  end.
]]

Note that side effects can be nondeterminisic. Let's extend our definition
of TE with "Russian roulette" operation that either leaves the state unchanged
or sets it to zero:

[[
Inductive TE := increment
              | rr.
]]

State transition predicate for this operation will look like this:

[[
state_transition s event s'  =
  match event with
  | increment => s' = s + 1
  | rr        => s' = s \/ s' = 0
  end.
]]

*)

(** ** Paths through the state space

[ReachableByTrace] is a datatype describing paths through the state space. Its
first constructor [rbt_nil] states the fact that the empty trace
doesn't change the state of the system. In other words, state of the
system doesn't drift by itself.

The second constructor [rbt_cons] declares that performing a syscall
[te] transitioning the system from [s] to [s'] followed by execution
of all syscalls in [trace], transitioning the system from [s'] to
[s''], is equivalent to executing a path [te :: trace] from [s] to
[s''] *)

Section reachable_by_trace.
  Context `{StateSpace}.

  Inductive ReachableByTrace : State -> list Event -> State -> Prop :=
  | rbt_nil : forall s,
      ReachableByTrace s [] s
  | rbt_cons : forall s s' s'' evt trace,
      s ~[evt]~> s' ->
      ReachableByTrace s' trace  s'' ->
      ReachableByTrace s (evt :: trace) s''.
End reachable_by_trace.

(** ** Hoare logic of traces

    [HoareTriple] is a type of judgments about trace execution,
    stating that if precondition [pre] holds for the initial state
    [s], and there is path [trace] through the state space leading
    to a point [s'], then postcondition [post] must hold for
    [s']. *)
Section hoare.
  Context `{StateSpace}.

  Definition HoareTriple (precondition  : State -> Prop)
                         (trace         : list Event)
                         (postcondition : State -> Prop) :=
    forall s s',
      ReachableByTrace s trace s' -> precondition s ->
      postcondition s'.
End hoare.

(* begin details *)
Notation "'{{' a '}}' t '{{' b '}}'" := (HoareTriple a t b) (at level 40) : slot_scope.
Notation "'{{}}' t '{{' b '}}'" := (HoareTriple (const True) t b) (at level 39) : slot_scope.
(* end details *)

(** ** Invariants

  [TraceInvariant] is a type of judgments stating that if execution
  of a trace starts in a state where property [prop] holds, then the
  same property will hold for each intermediate state during
  execution of the trace. In other words: [prop] is a subset of the
  state space, and if the system starts off in this subset, it always
  stays in it.
*)

Inductive TraceInvariant `{StateSpace} (prop : State -> Prop) : list Event -> Prop :=
| inv_nil :
    TraceInvariant prop []
| inv_cons : forall te t,
    {{prop}} [te] {{prop}} ->
    TraceInvariant prop t ->
    TraceInvariant prop (te :: t).

(** * Ensembles of traces

    Trace ensembles play one of central roles in SLOT, because from
    SLOT point of view any system is nothing but a collection of event
    traces that it can produce.
 *)

(* begin hide *)
Global Arguments In {_}.
Global Arguments Complement {_}.
Global Arguments Disjoint {_}.
(* end hide *)

Section ensembles.
  Context `{StateSpace}.

  Definition TraceEnsemble := Ensemble (list Event).

  (** Hoare logic of trace ensembles consists of a single rule: *)
  Definition EHoareTriple (precondition  : State -> Prop)
                          (ensemble      : TraceEnsemble)
                          (postcondition : State -> Prop) :=
    forall t, In ensemble t ->
         {{ precondition }} t {{ postcondition }}.

  Definition EnsembleInvariant (prop : State -> Prop) (ens : TraceEnsemble) : Prop :=
    forall (t : list Event), ens t -> TraceInvariant prop t.
End ensembles.

(* begin details *)
Global Arguments TraceEnsemble : clear implicits.

Notation "'-{{' a '}}' e '{{' b '}}'" := (EHoareTriple a e b)(at level 40) : slot_scope.
Notation "'-{{}}' e '{{' b '}}'" := (EHoareTriple (const True) e b)(at level 40) : slot_scope.
Notation "'-{{}}' e '{{}}'" := (forall t, e t -> exists s s', ReachableByTrace s t s')(at level 38) : slot_scope.
(* end details *)

(** ** Process ID in SLOT is a natural number: *)
Definition PID := nat.

Record ProcessEvent {Event : Type} :=
  proc_te { te_pid : PID;
            te_event : Event
          }.

(* begin hide *)
Global Arguments ProcessEvent : clear implicits.
Global Arguments proc_te {_}.
(* end hide *)

(* begin details *)
Notation "p @ t" := (proc_te p t) (at level 50) : slot_scope.
(* end details *)

(** * Input/output

 *)

Record IOp (Request : Type) (Reply : Request -> Type) :=
  iop { iop_req : Request;
        iop_rep : Reply iop_req;
      }.

Global Arguments iop {_ _} iop_req iop_rep.

Notation "a <~ b" := (iop b a) (at level 49).

Definition TraceElem (Request : Type) (Reply : Request -> Type) := ProcessEvent (IOp Request Reply).
Definition Trace (Request : Type) (Reply : Request -> Type) := list (TraceElem Request Reply).

Class IOHandler {Request : Type} {Reply : Request -> Type} : Type :=
  mkHandler
    { h_state : Type;
      h_state_transition : h_state -> TraceElem Request Reply -> h_state -> Prop;
    }.

Global Instance handlerStateSpace `{IOHandler} : StateSpace h_state (TraceElem Request Reply) :=
  {| state_transition := h_state_transition |}.

(** * Single thread program

 *)

CoInductive Program {Request : Type} {Reply : Request -> Type} : Type :=
| p_dead : (* Program terminted *)
    Program
| p_cont : (* Program is doing I/O *)
    forall (pending_req : Request)
      (continuation : Reply pending_req -> Program)
    , Program.

(* begin details *)
Notation "'do' V '<-' I ; C" := (p_cont (I) (fun V => C))
    (at level 100, C at next level, V ident, right associativity) : slot_scope.

Notation "'done' I" := (p_cont (I) (fun _ => p_dead))
    (at level 100, right associativity) : slot_scope.

Notation "'call' V '<-' I ; C" := (I (fun V => C))
    (at level 100, C at next level, V ident,
     right associativity,
     only parsing) : slot_scope.
(* end details *)

(** * Concurrency

 Now let's introduce concurrency. We represent concurrent processes by
 interleaving of traces.

 *)

Section interleaving.
  Context {Event : Type}.

  (** Set of all possible interleaving of two traces is a trace
  ensemble. As we later prove in [interleaving_to_permutation], this
  definition is dual to [Permutation] of two traces. *)
  Inductive Interleaving : list Event -> list Event -> TraceEnsemble Event :=
  | ilv_cons_l : forall te t1 t2 t,
      Interleaving t1 t2 t ->
      Interleaving (te :: t1) t2 (te :: t)
  | ilv_cons_r : forall te t1 t2 t,
      Interleaving t1 t2 t ->
      Interleaving t1 (te :: t2) (te :: t)
  | ilv_nil : Interleaving [] [] [].
End interleaving.


(* Tactics used to manipulate and reason about distributions corresponding to computations. *)

Set Implicit Arguments.

Require Import Rat.
Require Import Comp.
Require Import DistRules.
Require Import DistSem.
Require Import StdNat.
Require Import Fold.

Local Open Scope rat_scope.
Local Open Scope comp_scope.

Definition leftc := false.
Definition rightc := true.

(* wftac -- A tactic for deciding well-formedness *)
Hint Resolve posnat_pos : wftac.

Ltac pairInv :=
  match goal with
    | [H : (_, _) = (_, _) |- _] =>
      inversion H; clear H; subst
  end.

Ltac simp_ret :=
  match goal with
    | [H : In _ (getSupport (ret _)) |- _] =>
      simpl in H; intuition; pairInv
  end.

Ltac wftac_one :=
  match goal with
    | [|- well_formed_comp (Bind _ _) ] => eapply well_formed_Bind
    | [|- well_formed_comp (Ret _ _ ) ] => eapply well_formed_Ret
    | [|- well_formed_comp (Rnd _) ] => eapply well_formed_Rnd
    | [|- well_formed_comp (let (_,_) := ?y in _ ) ] => destruct y
    | [|- well_formed_comp (if ?x then _ else _) ] => destruct x
  end.

Ltac wftac :=
  repeat (unfold setLet; intuition; eauto with wftac; try simp_ret; wftac_one).

Ltac destructLet_1 :=
  match goal with
    | [|- context[match ?x with | pair _ _ => _ end]] => destruct x
  end.

Ltac destructLet := repeat destructLet_1.

(* tactics *)

Ltac dist_ret_l :=
  match goal with
      | [ |- ?rel (evalDist (Bind (Ret _ _) ?f) _) _ ] =>
        eapply trans; [eapply (@evalDist_left_ident rel _ _ _ _ f); eauto with typeclass_instances | idtac]
  end.

Ltac dist_ret_r :=
  match goal with
      | [ |- ?rel _ (evalDist (Bind (Ret _ _) ?f) _) ] =>
        eapply trans; [idtac | eapply (@evalDist_left_ident (Basics.flip rel) _ _ _ _ f);  eauto with typeclass_instances]
  end.

Ltac dist_simp_1 := unfold setLet; try dist_ret_l; try dist_ret_r; cbv beta iota; destructLet. (* we only want to destruct identifiers, so we must cbv first*)

Ltac dist_simp := repeat dist_simp_1.

Ltac dist_simp_weak_1 := unfold setLet; try dist_ret_l.

Ltac dist_simp_weak := repeat dist_simp_weak_1.

Ltac dist_inline_l :=
  match goal with
      | [ |- ?rel _ _ ] =>
        eapply trans; [ eapply (@evalDist_assoc rel);  eauto with typeclass_instances | idtac]
  end; dist_simp_weak.

Ltac dist_inline_r :=
  match goal with
      | [ |- ?rel _ _ ] =>
        eapply trans; [ idtac | eapply (@evalDist_assoc (Basics.flip rel));  eauto with typeclass_instances]
  end; dist_simp_weak.

Ltac dist_inline s :=
  match s with
    | leftc => dist_inline_l
    | rightc => dist_inline_r
  end.

Ltac dist_ret s :=
  match s with
      | leftc => dist_ret_l
      | rightc => dist_ret_r
  end.

Ltac dist_inline_first_1 := try dist_inline_l; try dist_inline_r.
Ltac dist_inline_first := repeat (dist_simp_weak_1; dist_inline_first_1).

Ltac dist_swap_l :=
  match goal with
    | [ |- ?rel (evalDist (Bind ?c1 (fun x => (Bind ?c2 _))) _) _ ] =>
      eapply trans; [eapply (@evalDist_commute rel _ _ c1 c2); eauto with typeclass_instances | idtac]
  end.

Ltac dist_swap_r :=
  match goal with
    | [ |- ?rel _ (evalDist (Bind ?c1 (fun x => (Bind ?c2 _))) _) ] =>
      eapply trans; [ idtac | eapply (@evalDist_commute (Basics.flip rel) _ _ c1 c2);  eauto with typeclass_instances]
  end; dist_simp_weak.

Ltac dist_swap side :=
  match side with
    | leftc => dist_swap_l
    | rightc => dist_swap_r
  end.

Ltac dist_at_l tac line :=
  match line with
    | O => tac leftc
    | S ?line' => eapply trans; [ eapply rel_seq; intuition; dist_at_l tac line'; eapply refl; eapply eqRat_refl | idtac]
  end; dist_simp_weak.

Ltac dist_at_r tac line :=
  match line with
    | O => tac rightc
    | S ?line' =>
      eapply trans; [idtac |
                     eapply rel_seq; [ intuition | intuition; (dist_at_r tac line'); eapply refl; eapply eqRat_refl] ]
  end; dist_simp.

Ltac dist_at tac side line :=
  match side with
    | leftc => dist_at_l tac (line)%nat
    | rightc => dist_at_r tac (line)%nat
  end.

Ltac dist_skip :=
  eapply evalDist_seq; [ idtac | eauto with typeclass_instances | idtac] ; intuition; subst; dist_simp_weak; intuition.

Ltac dist_irr_l :=
  eapply evalDist_irr_l; [  eauto with typeclass_instances | simpl | idtac] ; intuition; dist_simp_weak.

Ltac dist_irr_r :=
  eapply evalDist_irr_r; [  eauto with typeclass_instances | simpl | idtac] ; intuition; dist_simp_weak.

Lemma eqb_true_False :
  forall (A : Set)(eqd : EqDec A) (a1 a2 : A),
    (eqb a1 a2 = true -> False) ->
    a1 <> a2.

  intuition.
  subst.
  eapply H.
  eapply eqb_refl.

Qed.

Ltac dist_compute_1 :=
  match goal with
    | [H : RatRel ?rel |- ?rel ?x ?x ] => eapply refl
    | [|- context[if ?a then _ else _ ]] => destruct a
    | [H : context[if ?a then _ else _ ] |- _] => destruct a
    | [H : eqb _ _ = true |- _ ] => rewrite eqb_leibniz in H; subst
    | [H : eqb _ _ = true -> False |- _] => apply eqb_true_False in H
    | [H1 : true = ?b -> False, H2 : false = ?b -> False |- _] => destruct b
  end.

Ltac dist_compute_simp := simpl; unfold Fold.sumList; try rewrite <- ratAdd_0_l; try rewrite <- ratAdd_0_r; try rewrite ratMult_1_l; try rewrite ratMult_1_r; try rewrite ratMult_0_r; try rewrite ratMult_0_l.

Ltac dist_compute := repeat
  (dist_compute_simp; try dist_compute_1; try congruence; intuition).


Require Import Coq.Vectors.Vector.
Require Import Coq.Lists.List.
Require Import Coq.NArith.BinNatDef.
Require Import String.
Require Import Coq.Arith.Compare_dec. (* nat_compare *)

(* version 8.7: Require Import FunInd. *)

Notation vec := Vector.t.
Notation LB := (list bool).
Notation ll := List.length.
Notation lb := (ll (A:=bool)).

Notation Bnil := (nil (A := bool)).
Notation VecLB := (vec LB).

(* BYTE1 *)
Notation Byte := (vec bool 8).
(* BYTE2 *)

Notation LByte := (list Byte).

Notation Vnth := Vector.nth.

Notation Vnil := (@Vector.nil _).
Notation Vcons := (@Vector.cons _).
Notation Vmap := Vector.map.

Notation fin_rect2 := Fin.rect2.
Notation FS_inj := Fin.FS_inj.
Notation fin := Fin.t.
Notation FinLR := Fin.L_R.
Notation FinFS := Fin.FS.
Notation FinF1 := Fin.F1.

(** The n-th element of the given vector is the given element. This is so we can
use natural numbers instead of Fin.t as indices *)
(* TODO: This should be obsolete when we use maps *)
Inductive Vnth_is {A : Type} : forall (n : nat), nat -> vec A n -> A -> Prop :=
| vnthIsZero : forall a n b, Vnth_is (S n) 0 (Vcons a _ b) a
| vnthIsCons : forall a n m x b, Vnth_is n m b a -> Vnth_is (S n) (S m) (Vcons
x _ b) a.

Fixpoint Vnth_err {A : Type} {n : nat} (v : vec A n) (m : nat) : option A :=
  match nat_compare m n as nc return (nat_compare m n = nc -> _) with
    | Eq => fun _ => None
    | Gt => fun _ => None
    | Lt => fun eq =>
              Some (Vnth v (Fin.of_nat_lt (nat_compare_Lt_lt _ _ eq)))
  end eq_refl.

Function pi2 {A B} (x : A) (y : B) := y.

Fixpoint blstring (l : LB) : string :=
  match l with
    | nil => ""%string
    | (b :: L) =>
      ((match b with
          | false => "0"%string
          | true => "1"%string
        end) ++ blstring L)%string
  end.

(** From http://poleiro.info/posts/2013-04-03-parse-errors-as-type-errors.html *)

Definition forceOption A Err (o : option A) (err : Err) : match o with
                                                            | Some _ => A
                                                            | None => Err
                                                          end :=
  match o with
    | Some a => a
    | None => err
  end.

Inductive parseError := ParseError.

Fixpoint strToNat (strn : string) : option nat :=
  (fix rc str n :=
   match str with
     | EmptyString => Some n
     | String "0" str => rc str ((10 * n) + 0)
     | String "1" str => rc str ((10 * n) + 1)
     | String "2" str => rc str ((10 * n) + 2)
     | String "3" str => rc str ((10 * n) + 3)
     | String "4" str => rc str ((10 * n) + 4)
     | String "5" str => rc str ((10 * n) + 5)
     | String "6" str => rc str ((10 * n) + 6)
     | String "7" str => rc str ((10 * n) + 7)
     | String "8" str => rc str ((10 * n) + 8)
     | String "9" str => rc str ((10 * n) + 9)
     | _ => None
   end) strn 0.

Definition d (s : string) :=
  forceOption nat parseError (strToNat s) ParseError.

Example e1 : (d"22" : nat) = 22.
Proof. reflexivity. Qed.

Example e3 : (d"1O" : parseError) = ParseError.
Proof. reflexivity. Qed.

Function bbyte (a b c d e f g h : bool) : Byte :=
  Vcons a _
        (Vcons b _
               (Vcons c _
                      (Vcons d _
                             (Vcons e _
                                    (Vcons f _
                                           (Vcons g _
                                                  (Vcons h _ Vnil))))))).
Definition NullByte := bbyte false false false false false false false false.


(*
 * © 2019 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     String
     Sumbool
     Morphisms.

From SPICY Require Import
     MyPrelude
     Maps
     Tactics.

Set Implicit Arguments.

Definition key_identifier := nat.

Inductive key_usage :=
| Encryption
| Signing.

Lemma key_usage_eq_dec :
  forall u1 u2 : key_usage, { u1 = u2 } + { u1 <> u2 }.
  decide equality.
Defined.

Inductive key_type :=
| SymKey
| AsymKey.

Lemma key_type_eq_dec :
  forall kt1 kt2 : key_type, { kt1 = kt2 } + { kt1 <> kt2 }.
  decide equality.
Defined.

Record key :=
  MkCryptoKey { keyId    : key_identifier
              ; keyUsage : key_usage
              ; keyType  : key_type
              }.

Lemma key_eq_dec :
  forall k1 k2 : key, { k1 = k2 } + { k1 <> k2 }.
  decide equality; auto using Nat.eq_dec, key_usage_eq_dec, key_type_eq_dec.
Defined.

Definition key_permission : Set := key_identifier * bool.

Lemma key_permission_eq_dec :
  forall kp1 kp2 : key_permission, { kp1 = kp2 } + { kp1 <> kp2 }.
  decide equality; auto using Nat.eq_dec, Bool.bool_dec.
Defined.

Notation "x ==kk y" := (key_eq_dec x y) (right associativity, at level 75).
Notation "x ==ku y" := (key_usage_eq_dec x y) (right associativity, at level 75).
Notation "x ==kt y" := (key_type_eq_dec x y) (right associativity, at level 75).
Notation "x ==kp y" := (key_permission_eq_dec x y) (right associativity, at level 75).

Definition keys            := NatMap.t key.
Definition key_perms       := NatMap.t bool.

Definition greatest_permission (kp1 kp2 : bool) : bool :=
  kp1 || kp2.

Definition add_key_perm (k : key_identifier)(kp : bool) (perms : key_perms) : key_perms :=
    match perms $? k with
    | None     => perms $+ (k, kp)
    | Some kp' => perms $+ (k, greatest_permission kp kp')
    end.

Lemma greatest_permission_refl :
  forall k,
    greatest_permission k k = k.
Proof.
  unfold greatest_permission; auto using orb_diag.
Qed.

Lemma greatest_permission_symm :
  forall kp1 kp2,
    greatest_permission kp1 kp2 = greatest_permission kp2 kp1.
Proof.
  unfold greatest_permission; auto using orb_comm.
Qed.

Definition merge_perms (ks ks' : key_perms) : key_perms :=
  Map.fold add_key_perm ks ks'.

Notation "m1 $k++ m2" := (merge_perms m2 m1) (at level 50, left associativity).

Lemma add_key_perm_proper :
  Proper (eq  ==>  eq  ==>  eq  ==>  eq ) add_key_perm.
Proof.
  solve_proper.
Qed.

Require Import Coq.Classes.RelationClasses.

Lemma add_key_perm_proper_Equal :
  Proper (eq  ==>  eq  ==>  Equal  ==>  Equal ) add_key_perm.
Proof.
  unfold Proper, respectful; intros; Equal_eq;
    unfold Equal; intros; trivial.
Qed.

Lemma add_key_perm_transpose :
  transpose_neqkey eq add_key_perm.
Proof.
  unfold transpose_neqkey, add_key_perm; intros.
  apply map_eq_Equal; unfold Equal; intros;
    solve_simple_maps; eauto.
Qed.

Lemma add_key_perm_transpose_Equal :
  transpose_neqkey Equal add_key_perm.
Proof.
  unfold transpose_neqkey, add_key_perm; intros.
  unfold Equal; intros;
      solve_simple_maps; eauto.
Qed.

#[export] Hint Resolve
     add_key_perm_proper       add_key_perm_transpose
     add_key_perm_proper_Equal add_key_perm_transpose_Equal
  : core.

Section KeyMergeTheorems.
  Variable all_keys : keys.
  Variable honestk advk : key_perms.

  Hint Resolve empty_Empty : core.

  Lemma merge_perms_notation :
    forall ks1 ks2,
      fold add_key_perm ks2 ks1 = ks1 $k++ ks2.
    unfold merge_perms; trivial.
  Qed.

  Ltac progress_fold_add1 :=
    match goal with
    | [ H : fold add_key_perm (_ $+ (_,_)) _ $? _ = _ |- _ ] => rewrite fold_add in H
    | [ H : _ $k++ (_ $+ (_,_)) $? _ = _ |- _ ] => unfold merge_perms in H; rewrite fold_add in H
    | [ |- context[ fold add_key_perm (_ $+ (_,_)) _ ] ] => rewrite fold_add
    | [ |- context[ _ $k++ (_ $+ (_,_))] ] => unfold merge_perms; rewrite fold_add
    end.

  Ltac process_perm_merge1 :=
    match goal with
    | [ H : fold add_key_perm (_ $+ (_,_)) _ $? _ = _ |- _ ] => rewrite fold_add in H; auto 2
    | [ H : _ $k++ (_ $+ (_,_)) $? _ = _ |- _ ] => unfold merge_perms in H
    | [ |- context[ fold add_key_perm (_ $+ (_,_)) _ ] ] => rewrite fold_add; auto 2
    | [ |- context[ _ $k++ (_ $+ (_,_))] ] => unfold merge_perms
    | [ H : context[ fold add_key_perm ?ks2 ?ks1 ] |- _] => rewrite merge_perms_notation in H
    | [ |- context[ fold add_key_perm ?ks2 ?ks1 ] ] => rewrite merge_perms_notation
    | [ H : ?ks1 $k++ ?ks2 = _ |- context [ ?ks1 $k++ ?ks2 ] ] => rewrite H
    | [ H: context [ add_key_perm ] |- _ ] => unfold add_key_perm in H
    | [ |- context [ add_key_perm ] ] => unfold add_key_perm
    end.

  Ltac process_perm_merge := repeat (process_perm_merge1).

  Lemma merge_perms_left_identity :
    forall ks,
      $0 $k++ ks = ks.
  Proof.
    induction ks using P.map_induction_bis; intros; Equal_eq; auto;
      process_perm_merge;
      solve_simple_maps;
      eauto.
  Qed.

  Lemma merge_perms_right_identity :
    forall ks,
      ks $k++ $0 = ks.
  Proof.
    unfold merge_perms; intros; rewrite fold_Empty; eauto.
  Qed.

  Hint Rewrite merge_perms_right_identity merge_perms_left_identity : core.

  Lemma merge_perms_adds_no_new_perms :
    forall ks2 k ks1,
        ks1 $? k = None
      -> ks2 $? k = None
      -> (ks1 $k++ ks2) $? k = None.
  Proof.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; auto;
      process_perm_merge;
      solve_simple_maps;
      eauto.
  Qed.

  Hint Resolve merge_perms_adds_no_new_perms : core.

  Lemma merge_perms_came_from_somewhere1 :
    forall ks2 ks1 k v,
        ks1 $k++ ks2 $? k = Some v
      -> ks2 $? k = None
      -> ks1 $? k = Some v.
  Proof.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; auto;
      process_perm_merge;
      solve_simple_maps;
      eauto.
  Qed.

  Lemma merge_perms_came_from_somewhere2 :
    forall ks2 ks1 k v,
        ks1 $k++ ks2 $? k = Some v
      -> ks1 $? k = None
      -> ks2 $? k = Some v.
  Proof.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; eauto;
      process_perm_merge;
      solve_simple_maps;
      eauto.

    - rewrite merge_perms_right_identity in *; clean_map_lookups.
    - pose proof (merge_perms_adds_no_new_perms _ _ _ H1 H);
        clean_map_lookups.
  Qed.

  Hint Resolve merge_perms_came_from_somewhere1 merge_perms_came_from_somewhere2 : core.

  Lemma merge_perms_adds_ks1 :
    forall ks2 ks1 k v ks,
        ks1 $? k = Some v
      -> ks2 $? k = None
      -> ks = ks1 $k++ ks2
      -> ks $? k = Some v.
  Proof.
    unfold merge_perms.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; eauto;
      process_perm_merge;
      solve_simple_maps;
      eauto.

    - rewrite merge_perms_right_identity in *; subst; eauto.
    - unfold merge_perms;
        process_perm_merge;
        solve_simple_maps;
        eauto.
  Qed.

  Lemma merge_perms_adds_ks2 :
    forall ks2 ks1 k v ks,
        ks1 $? k = None
      -> ks2 $? k = Some v
      -> ks = ks1 $k++ ks2
      -> ks $? k = Some v.
  Proof.
    unfold merge_perms.
    induction ks2 using P.map_induction_bis; intros; Equal_eq;
      process_perm_merge;
      solve_simple_maps;
      eauto;
      unfold merge_perms;
      process_perm_merge;
      solve_simple_maps;
      eauto.

    pose proof (merge_perms_adds_no_new_perms _ _ _ H0 H);
        clean_map_lookups.
  Qed.

  Hint Resolve merge_perms_adds_ks1 merge_perms_adds_ks2 : core.

  Lemma merge_perms_no_disappear_perms :
    forall ks2 k ks1,
      ks1 $k++ ks2 $? k = None
    -> ks1 $? k = None
    /\ ks2 $? k = None.
  Proof.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; auto;
      process_perm_merge;
      solve_simple_maps;
      eauto.
  Qed.

  Lemma merge_perms_chooses_greatest :
    forall ks2 ks1 k k' kp kp',
        ks1 $? k = Some kp
      -> ks2 $? k' = Some kp'
      -> k = k'
      -> (ks1 $k++ ks2) $? k = Some (greatest_permission kp kp').
  Proof.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; eauto;
      process_perm_merge;
      solve_simple_maps;
      eauto.

    - pose proof (merge_perms_came_from_somewhere1 _ _ _ Heq H);
        clean_map_lookups;
        rewrite greatest_permission_symm;
        eauto.

    - pose proof (merge_perms_no_disappear_perms _ _ _ Heq);
        split_ands;
        clean_map_lookups.
  Qed.

  Hint Resolve merge_perms_chooses_greatest : core.

  Lemma merge_perms_some_inv :
    forall ks1 ks2 k p,
      ks1 $k++ ks2 $? k = Some p
      -> ( ks1 $? k = Some p /\ ks2 $? k = None )
      \/ ( ks1 $? k = None /\ ks2 $? k = Some p )
      \/ ( exists p1 p2, ks1 $? k = Some p1 /\ ks2 $? k = Some p2 /\ p = greatest_permission p1 p2).
  Proof.
    intros.
    cases (ks1 $? k); cases (ks2 $? k);
      match goal with
      | [ H1 : ks1 $? k = _, H2 : ks2 $? k = _ |- _ ] =>
          (pose proof (merge_perms_chooses_greatest _ _ H1 H2 (eq_refl k)))
        || (pose proof (merge_perms_adds_ks1 _ _ _ H1 H2 (eq_refl (ks1 $k++ ks2))))
        || (pose proof (merge_perms_adds_ks2 _ _ _ H1 H2 (eq_refl (ks1 $k++ ks2))))
        || (pose proof (merge_perms_adds_no_new_perms _ _ _ H1 H2))
      end; clean_map_lookups; eauto 12.
  Qed.

  Lemma merge_perms_split :
    forall ks2 ks1 k kp,
      ks1 $k++ ks2 $? k = Some kp
      -> ks1 $? k = Some kp
      \/ ks2 $? k = Some kp.
  Proof.
    induction ks2 using P.map_induction_bis; intros; Equal_eq; auto;
      process_perm_merge;
      solve_simple_maps;
      eauto.

    match goal with
    | [ H : (forall _ _ _, (_ $k++ _ $? _ = Some _) -> _)
            , ARG : _ $k++ _ $? _ = Some _
        |- context [ greatest_permission ?b1 ?b2 ] ] =>
      specialize (H _ _ _ ARG);
        split_ors;
        clean_map_lookups;
        unfold greatest_permission;
        destruct b1; destruct b2
    end; eauto.
  Qed.

End KeyMergeTheorems.

Local Ltac build_merge_term ks kid :=
  match goal with
  | [ H : ks $? kid = _ |- _ ] => fail 1
  | _ =>
    match ks with
    | (?ks1 $k++ ?ks2) =>
      try (build_merge_term ks1 kid); (* subterms need to be created before unification variables *)
      try (build_merge_term ks2 kid);
      let kp' := fresh "kp" in
      evar (kp' : option bool);
      let kp := eval unfold kp' in kp' in
          clear kp'; assert (ks1 $k++ ks2 $? kid = kp)
    | _ => cases (ks $? kid)
    end
  end.

Ltac merge_perms_recur1 :=
  match goal with
  (* Identities *)
  | [ H : context [ _ $k++ $0 ] |- _ ] => rewrite merge_perms_right_identity in H
  | [ |- context [ _ $k++ $0 ] ] => rewrite merge_perms_right_identity
  | [ H : context [ $0 $k++ _ ] |- _ ] => rewrite merge_perms_left_identity in H
  | [ |- context [ $0 $k++ _ ] ] => rewrite merge_perms_left_identity

  | [ H : (if ?b then _ else _) = _ |- _ ] => is_var b; destruct b; try discriminate

  | [ |- context [ greatest_permission ] ] => unfold greatest_permission
  | [ |- context [ _ || true ] ] => rewrite orb_true_r
  | [ |- context [ true || _ ] ] => rewrite orb_true_l
  | [ |- context [ _ || false ] ] => rewrite orb_false_r
  | [ |- context [ false || _ ] ] => rewrite orb_false_l
  | [ |- context [ ?b || ?b ] ] => rewrite orb_diag
  | [ H : context [ _ || true ] |- _  ] => rewrite orb_true_r in H
  | [ H : context [ true || _ ] |- _  ] => rewrite orb_true_l in H
  | [ H : context [ _ || false ] |- _  ] => rewrite orb_false_r in H
  | [ H : context [ false || _ ] |- _  ] => rewrite orb_false_l in H
  | [ H : context [ ?b || ?b ] |- _ ] => rewrite orb_diag in H
  | [ H : true = _ || _ |- _ ] => symmetry in H; simpl in H
  | [ H : ?b1 || ?b2 = true |- _ ] => first [
                                       is_not_var b1; is_not_var b2
                                     | rewrite orb_true_iff in H; split_ors; subst
                                     ]

  | [ |- Some _ = _ ] => reflexivity
  | [ |- _ = Some _ ] => reflexivity
  | [ |- Some _ = Some _ ] => f_equal
  | [ |- None = _ ] => reflexivity
  | [ |- _ = None ] => reflexivity
  (* canonicalize ordering of orb so variables are in same order as lhs, and left associated *)
  | [ |- ?lhs = ?rhs ] =>
    match lhs with
    | ?x || ?y =>
      match rhs with
      | y || x => rewrite (orb_comm y x)
      end
    | _ => rewrite orb_assoc
    end

  | [ H1 : ?ks1 $? ?kid = Some _
    , H2 : ?ks2 $? ?kid = Some _ |- context [ ?ks1 $k++ ?ks2 $? ?kid ]]
    => rewrite (merge_perms_chooses_greatest _ _ H1 H2) by trivial; unfold greatest_permission; simpl
  | [ H1 : ?ks1 $? ?kid = Some _
    , H2 : ?ks2 $? ?kid = None |- context [ ?ks1 $k++ ?ks2 $? ?kid ]]
    => rewrite (merge_perms_adds_ks1 _ _ _ H1 H2) by trivial
  | [ H1 : ?ks1 $? ?kid = None
    , H2 : ?ks2 $? ?kid = Some _ |- context [ ?ks1 $k++ ?ks2 $? ?kid ]]
    => rewrite (merge_perms_adds_ks2 _ _ _ H1 H2) by trivial
  | [ H1 : ?ks1 $? ?kid = None
    , H2 : ?ks2 $? ?kid = None |- context [ ?ks1 $k++ ?ks2 $? ?kid ]]
    => rewrite (merge_perms_adds_no_new_perms _ _ _ H1 H2) by trivial

  (* we now know ks1 or ks2 is not in the context, or we have some other sort of problem *)
  | [ |- ?ks1 $k++ ?ks2 $? ?kid = _ ] =>
    build_merge_term ks1 kid
    || build_merge_term ks2 kid
    || (unify ks1 ks2; match goal with
                      | [ H : ks1 $? kid = _ |- _ ] => generalize H; intro
                      end)
  | [ |- _ = ?ks1 $k++ ?ks2 $? ?kid ] =>
    (does_not_unify ks1 ks2; (build_merge_term ks1 kid || build_merge_term ks2 kid))
    || match goal with
      | [ H : ks1 $? kid = _ |- _ ] => generalize H; intro
      end
  end.

Lemma merge_perms_neq_add_ok :
  forall ks2 ks1 k k' kp,
    k <> k'
    -> ks1 $+ (k,kp) $k++ ks2 $? k' = ks1 $k++ ks2 $? k'.
Proof.
  intros.
  repeat (merge_perms_recur1 || solve_simple_maps1); trivial.
Qed.

Lemma merge_perms_pull1 :
  forall ks2 ks1 k kp kp' gkp,
    ks2 $? k = Some kp'
    -> gkp = greatest_permission kp kp'
    -> (ks1 $+ (k, kp)) $k++ ks2 = ks1 $k++ ks2 $+ (k, gkp).
Proof.
  intros.
  apply map_eq_Equal; unfold Equal; intros kid.
  repeat (merge_perms_recur1 || solve_simple_maps1); trivial.
Qed.

Lemma merge_perms_pull2 :
  forall ks2 ks1 k kp gkp,
    ks2 $? k = None
    -> gkp = kp
    -> (ks1 $+ (k, kp)) $k++ ks2 = ks1 $k++ ks2 $+ (k, gkp).
Proof.
  intros.
  apply map_eq_Equal; unfold Equal; intros kid.
  repeat (merge_perms_recur1 || solve_simple_maps1); trivial.
Qed.

Lemma merge_perms_sym :
  forall ks2 ks1,
    ks1 $k++ ks2 = ks2 $k++ ks1.
Proof.
  intros.
  apply map_eq_Equal; unfold Equal; intros kid.
  repeat merge_perms_recur1; trivial.
Qed.

Lemma merge_perms_refl :
  forall ks,
    ks $k++ ks = ks.
Proof.
  intros.
  apply map_eq_Equal; unfold Equal; intros kid.
  repeat merge_perms_recur1.
Qed.

Lemma merge_perms_assoc :
  forall ks3 ks1 ks2,
    ks1 $k++ ks2 $k++ ks3 = ks1 $k++ (ks2 $k++ ks3).
Proof.
  intros.
  apply map_eq_Equal; unfold Equal; intros kid.
  repeat merge_perms_recur1; trivial.
Qed.

Lemma merge_perms_repl_add : forall ks k v,
    ks $k++ ($0 $+ (k, v)) = add_key_perm k v ks.
Proof.
  intros; unfold merge_perms, add_key_perm, fold; simpl; reflexivity.
Qed.

Lemma merge_perms_distr_add : forall ks ks' k v,
    add_key_perm k v ks $k++ ks' = add_key_perm k v (ks $k++ ks').
Proof.
  intros
  ; rewrite <- !merge_perms_repl_add, merge_perms_assoc
  ; replace ($0 $+ (k, v) $k++ ks') with (ks' $k++ ($0 $+ (k, v)))
  ; [rewrite <- merge_perms_assoc | rewrite merge_perms_sym]
  ; reflexivity.
Qed.

Lemma add_true_lookup_yields_true : forall ks k,
    add_key_perm k true ks $? k = Some true.
Proof.
  intros
  ; unfold add_key_perm
  ; destruct (ks $? k)
  ; simpl
  ; clean_map_lookups
  ; auto.
Qed.

(* Key Merge Automation
 *
 *  Strategy is going to be to pick apart the merge
 *  components and then leverage clean_map_lookups
 *)

Ltac split_perm_merge ks kid :=
  match ks with
  | context [ ?ks1 $k++ ?ks2 ] =>
    split_perm_merge ks1 kid;
    split_perm_merge ks2 kid
  | _ =>
    match goal with
    | [ H : ks $? kid = Some _ |- _ ] => idtac
    | [ H : ks $? kid = None |- _ ] => idtac
    | _ => cases (ks $? kid)
    end
  end.

Ltac solve_perm_merges1 :=
  merge_perms_recur1
  || match goal with
  | [ |- ?ks1 $k++ (?ks2 $k++ ?ks3) = ?ks1 $k++ ?ks2 $k++ ?ks3 ] => symmetry; apply merge_perms_assoc

  | [ H : add_key_perm _ _ _ $? _ = _ |- _ ] => unfold add_key_perm in H
  | [ H : ?ks1 $k++ ?ks2 $? ?kid = Some ?b |- _ ] =>
    (* Should we split? *)
    match goal with
    | [ |- context [ ks1 $k++ ks2 ]] =>
      match b with
      | true =>

        match goal with
        | [ H1 : ks1 $? kid = ?v1 |- _ ] =>
          match goal with
          | [ H2 : ks2 $? kid = ?v2 |- _ ] =>
            (* Only generalize if one or both isn't a variable *)
            first [
                match v1 with | Some ?vv1 => is_var vv1 end; match v2 with | Some ?vv2 => is_var vv2 end; fail 3 (* get out of here *)
              | match v1 with | Some ?vv1 => is_var vv1 end; fail 1 (* go to generalize branch *)
              | match v2 with | Some ?vv2 => is_var vv2 end; fail 1 (* go to generalize branch *)
              | fail 3  (* get out of here *)
              ]
          end
        | _ => generalize H; apply merge_perms_some_inv in H; intros; unfold greatest_permission in H; split_ors
        end

      | false =>

        match goal with
        | [ H1 : ks1 $? kid = ?v1 |- _ ] =>
          match goal with
          | [ H2 : ks2 $? kid = ?v2 |- _ ] =>
            (* Only generalize if one or both isn't a variable *)
            first [
                match v1 with | Some ?vv1 => is_var vv1 end; match v2 with | Some ?vv2 => is_var vv2 end; fail 3 (* get out of here *)
              | match v1 with | Some ?vv1 => is_var vv1 end; fail 1 (* go to generalize branch *)
              | match v2 with | Some ?vv2 => is_var vv2 end; fail 1 (* go to generalize branch *)
              | fail 3  (* get out of here *)
              ]
          end
        | _ => generalize H; apply merge_perms_some_inv in H; intros; unfold greatest_permission in H; split_ors
        end

      | _ => fail 3
      end

    | _ => apply merge_perms_some_inv in H; unfold greatest_permission in H; split_ors
    end

  | [ H : ?ks1 $k++ ?ks2 $? ?kid = None |- _ ] =>
    match goal with
    | [ |- context [ ks1 $k++ ks2 ]] =>
      match goal with
      | [ H1 : ks1 $? kid = None |- _ ] =>
        match goal with
        | [ H2 : ks2 $? kid = None |- _ ] => fail 2
        end
      | _ => generalize H; apply merge_perms_no_disappear_perms in H; intros; split_ands
      end
    | _ => apply merge_perms_no_disappear_perms in H; split_ors
    end
  end.

Ltac solve_perm_merges :=
  repeat ( maps_equal1 || solve_perm_merges1 ).

Ltac solve_greatest :=
  repeat
    match goal with
    | [ |- context [ greatest_permission ] ] => unfold greatest_permission
    | [ |- context [ _ || true ] ] => rewrite orb_true_r
    | [ |- context [ true || _ ] ] => rewrite orb_true_l
    | [ |- context [ ?b || ?b ] ] => rewrite orb_diag
    end; trivial.

#[export] Hint Extern 1 (_ = greatest_permission _ _) => solve_greatest : core.


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

(** * Finite set library *)

(** Set interfaces, inspired by the one of Ocaml. When compared with
    Ocaml, the main differences are:
    - the lack of [iter] function, useless since Coq is purely functional
    - the use of [option] types instead of [Not_found] exceptions
    - the use of [nat] instead of [int] for the [cardinal] function

    Several variants of the set interfaces are available:
    - [WSetsOn] : functorial signature for weak sets
    - [WSets]   : self-contained version of [WSets]
    - [SetsOn]  : functorial signature for ordered sets
    - [Sets]    : self-contained version of [Sets]
    - [WRawSets] : a signature for weak sets that may be ill-formed
    - [RawSets]  : same for ordered sets

    If unsure, [S = Sets] is probably what you're looking for: most other
    signatures are subsets of it, while [Sets] can be obtained from
    [RawSets] via the use of a subset type (see (W)Raw2Sets below).
*)

Require Export Bool SetoidList RelationClasses Morphisms
 RelationPairs Equalities Orders OrdersFacts.
Set Implicit Arguments.
Unset Strict Implicit.

Module Type TypElt.
 Parameters t elt : Type.
End TypElt.

Module Type HasWOps (Import T:TypElt).

  Parameter empty : t.
  (** The empty set. *)

  Parameter is_empty : t -> bool.
  (** Test whether a set is empty or not. *)

  Parameter mem : elt -> t -> bool.
  (** [mem x s] tests whether [x] belongs to the set [s]. *)

  Parameter add : elt -> t -> t.
  (** [add x s] returns a set containing all elements of [s],
  plus [x]. If [x] was already in [s], [s] is returned unchanged. *)

  Parameter singleton : elt -> t.
  (** [singleton x] returns the one-element set containing only [x]. *)

  Parameter remove : elt -> t -> t.
  (** [remove x s] returns a set containing all elements of [s],
  except [x]. If [x] was not in [s], [s] is returned unchanged. *)

  Parameter union : t -> t -> t.
  (** Set union. *)

  Parameter inter : t -> t -> t.
  (** Set intersection. *)

  Parameter diff : t -> t -> t.
  (** Set difference. *)

  Parameter equal : t -> t -> bool.
  (** [equal s1 s2] tests whether the sets [s1] and [s2] are
  equal, that is, contain equal elements. *)

  Parameter subset : t -> t -> bool.
  (** [subset s1 s2] tests whether the set [s1] is a subset of
  the set [s2]. *)

  Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A.
  (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
  where [x1 ... xN] are the elements of [s].
  The order in which elements of [s] are presented to [f] is
  unspecified. *)

  Parameter for_all : (elt -> bool) -> t -> bool.
  (** [for_all p s] checks if all elements of the set
  satisfy the predicate [p]. *)

  Parameter exists_ : (elt -> bool) -> t -> bool.
  (** [exists p s] checks if at least one element of
  the set satisfies the predicate [p]. *)

  Parameter filter : (elt -> bool) -> t -> t.
  (** [filter p s] returns the set of all elements in [s]
  that satisfy predicate [p]. *)

  Parameter partition : (elt -> bool) -> t -> t * t.
  (** [partition p s] returns a pair of sets [(s1, s2)], where
  [s1] is the set of all the elements of [s] that satisfy the
  predicate [p], and [s2] is the set of all the elements of
  [s] that do not satisfy [p]. *)

  Parameter cardinal : t -> nat.
  (** Return the number of elements of a set. *)

  Parameter elements : t -> list elt.
  (** Return the list of all elements of the given set, in any order. *)

  Parameter choose : t -> option elt.
  (** Return one element of the given set, or [None] if
  the set is empty. Which element is chosen is unspecified.
  Equal sets could return different elements. *)

End HasWOps.

Module Type WOps (E : DecidableType).
  Definition elt := E.t.
  Parameter t : Type. (** the abstract type of sets *)
  Include HasWOps.
End WOps.

(** ** Functorial signature for weak sets

    Weak sets are sets without ordering on base elements, only
    a decidable equality. *)

Module Type WSetsOn (E : DecidableType).
  (** First, we ask for all the functions *)
  Include WOps E.

  (** Logical predicates *)
  Parameter In : elt -> t -> Prop.
  Declare Instance In_compat : Proper (E.eq==>eq==>iff) In.

  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 := exists x, In x s /\ P x.

  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).

  Definition eq : t -> t -> Prop := Equal.
  Include IsEq. (** [eq] is obviously an equivalence, for subtyping only *)
  Include HasEqDec.

  (** Specifications of set operators *)

  Section Spec.
  Variable s s': t.
  Variable x y : elt.
  Variable f : elt -> bool.
  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).

  Parameter mem_spec : mem x s = true <-> In x s.
  Parameter equal_spec : equal s s' = true <-> s[=]s'.
  Parameter subset_spec : subset s s' = true <-> s[<=]s'.
  Parameter empty_spec : Empty empty.
  Parameter is_empty_spec : is_empty s = true <-> Empty s.
  Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s.
  Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
  Parameter singleton_spec : In y (singleton x) <-> E.eq y x.
  Parameter union_spec : In x (union s s') <-> In x s \/ In x s'.
  Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'.
  Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'.
  Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (flip f) (elements s) i.
  Parameter cardinal_spec : cardinal s = length (elements s).
  Parameter filter_spec : compatb f ->
    (In x (filter f s) <-> In x s /\ f x = true).
  Parameter for_all_spec : compatb f ->
    (for_all f s = true <-> For_all (fun x => f x = true) s).
  Parameter exists_spec : compatb f ->
    (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Parameter partition_spec1 : compatb f ->
    fst (partition f s) [=] filter f s.
  Parameter partition_spec2 : compatb f ->
    snd (partition f s) [=] filter (fun x => negb (f x)) s.
  Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s.
  (** When compared with ordered sets, here comes the only
      property that is really weaker: *)
  Parameter elements_spec2w : NoDupA E.eq (elements s).
  Parameter choose_spec1 : choose s = Some x -> In x s.
  Parameter choose_spec2 : choose s = None -> Empty s.

  End Spec.

End WSetsOn.

(** ** Static signature for weak sets

    Similar to the functorial signature [WSetsOn], except that the
    module [E] of base elements is incorporated in the signature. *)

Module Type WSets.
  Declare Module E : DecidableType.
  Include WSetsOn E.
End WSets.

(** ** Functorial signature for sets on ordered elements

    Based on [WSetsOn], plus ordering on sets and [min_elt] and [max_elt]
    and some stronger specifications for other functions. *)

Module Type HasOrdOps (Import T:TypElt).

  Parameter compare : t -> t -> comparison.
  (** Total ordering between sets. Can be used as the ordering function
  for doing sets of sets. *)

  Parameter min_elt : t -> option elt.
  (** Return the smallest element of the given set
  (with respect to the [E.compare] ordering),
  or [None] if the set is empty. *)

  Parameter max_elt : t -> option elt.
  (** Same as [min_elt], but returns the largest element of the
  given set. *)

End HasOrdOps.

Module Type Ops (E : OrderedType) := WOps E <+ HasOrdOps.

Module Type SetsOn (E : OrderedType).
  Include WSetsOn E <+ HasOrdOps <+ HasLt <+ IsStrOrder.

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

  Parameter compare_spec : CompSpec eq lt s s' (compare s s').

  (** Additional specification of [elements] *)
  Parameter elements_spec2 : sort E.lt (elements s).

  (** Remark: since [fold] is specified via [elements], this stronger
   specification of [elements] has an indirect impact on [fold],
   which can now be proved to receive elements in increasing order.
  *)

  Parameter min_elt_spec1 : min_elt s = Some x -> In x s.
  Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
  Parameter min_elt_spec3 : min_elt s = None -> Empty s.

  Parameter max_elt_spec1 : max_elt s = Some x -> In x s.
  Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
  Parameter max_elt_spec3 : max_elt s = None -> Empty s.

  (** Additional specification of [choose] *)
  Parameter choose_spec3 : choose s = Some x -> choose s' = Some y ->
    Equal s s' -> E.eq x y.

  End Spec.

End SetsOn.

(** ** Static signature for sets on ordered elements

    Similar to the functorial signature [SetsOn], except that the
    module [E] of base elements is incorporated in the signature. *)

Module Type Sets.
  Declare Module E : OrderedType.
  Include SetsOn E.
End Sets.

Module Type S := Sets.

(** ** Some subtyping tests
<<
WSetsOn ---> WSets
 |           |
 |           |
 V           V
SetsOn  ---> Sets

Module S_WS (M : Sets) <: WSets := M.
Module Sfun_WSfun (E:OrderedType)(M : SetsOn E) <: WSetsOn E := M.
Module S_Sfun (M : Sets) <: SetsOn M.E := M.
Module WS_WSfun (M : WSets) <: WSetsOn M.E := M.
>>
*)

(** ** Signatures for set representations with ill-formed values.

   Motivation:

   For many implementation of finite sets (AVL trees, sorted
   lists, lists without duplicates), we use the same two-layer
   approach:

   - A first module deals with the datatype (eg. list or tree) without
   any restriction on the values we consider. In this module (named
   "Raw" in the past), some results are stated under the assumption
   that some invariant (e.g. sortedness) holds for the input sets. We
   also prove that this invariant is preserved by set operators.

   - A second module implements the exact Sets interface by
   using a subtype, for instance [{ l : list A | sorted l }].
   This module is a mere wrapper around the first Raw module.

   With the interfaces below, we give some respectability to
   the "Raw" modules. This allows the interested users to directly
   access them via the interfaces. Even better, we can build once
   and for all a functor doing the transition between Raw and usual Sets.

   Description:

   The type [t] of sets may contain ill-formed values on which our
   set operators may give wrong answers. In particular, [mem]
   may not see a element in a ill-formed set (think for instance of a
   unsorted list being given to an optimized [mem] that stops
   its search as soon as a strictly larger element is encountered).

   Unlike optimized operators, the [In] predicate is supposed to
   always be correct, even on ill-formed sets. Same for [Equal] and
   other logical predicates.

   A predicate parameter [Ok] is used to discriminate between
   well-formed and ill-formed values. Some lemmas hold only on sets
   validating [Ok]. This predicate [Ok] is required to be
   preserved by set operators. Moreover, a boolean function [isok]
   should exist for identifying (at least some of) the well-formed sets.

*)

Module Type WRawSets (E : DecidableType).
  (** First, we ask for all the functions *)
  Include WOps E.

  (** Is a set well-formed or ill-formed ? *)

  Parameter IsOk : t -> Prop.
  Class Ok (s:t) : Prop := ok : IsOk s.

  (** In order to be able to validate (at least some) particular sets as
      well-formed, we ask for a boolean function for (semi-)deciding
      predicate [Ok]. If [Ok] isn't decidable, [isok] may be the
      always-false function. *)
  Parameter isok : t -> bool.
  (** MS:
    Dangerous instance, the [isok s = true] hypothesis cannot be discharged
   with typeclass resolution. Is it really an instance? *)
  Declare Instance isok_Ok s `(isok s = true) : Ok s | 10.

  (** Logical predicates *)
  Parameter In : elt -> t -> Prop.
  Declare Instance In_compat : Proper (E.eq==>eq==>iff) In.

  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 := exists x, In x s /\ P x.

  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).

  Definition eq : t -> t -> Prop := Equal.
  Declare Instance eq_equiv : Equivalence eq.

  (** First, all operations are compatible with the well-formed predicate. *)

  Declare Instance empty_ok : Ok empty.
  Declare Instance add_ok s x `(Ok s) : Ok (add x s).
  Declare Instance remove_ok s x `(Ok s) : Ok (remove x s).
  Declare Instance singleton_ok x : Ok (singleton x).
  Declare Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s').
  Declare Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
  Declare Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s').
  Declare Instance filter_ok s f `(Ok s) : Ok (filter f s).
  Declare Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
  Declare Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).

  (** Now, the specifications, with constraints on the input sets. *)

  Section Spec.
  Variable s s': t.
  Variable x y : elt.
  Variable f : elt -> bool.
  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).

  Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s.
  Parameter equal_spec : forall `{Ok s, Ok s'},
    equal s s' = true <-> s[=]s'.
  Parameter subset_spec : forall `{Ok s, Ok s'},
    subset s s' = true <-> s[<=]s'.
  Parameter empty_spec : Empty empty.
  Parameter is_empty_spec : is_empty s = true <-> Empty s.
  Parameter add_spec : forall `{Ok s},
    In y (add x s) <-> E.eq y x \/ In y s.
  Parameter remove_spec : forall `{Ok s},
    In y (remove x s) <-> In y s /\ ~E.eq y x.
  Parameter singleton_spec : In y (singleton x) <-> E.eq y x.
  Parameter union_spec : forall `{Ok s, Ok s'},
    In x (union s s') <-> In x s \/ In x s'.
  Parameter inter_spec : forall `{Ok s, Ok s'},
    In x (inter s s') <-> In x s /\ In x s'.
  Parameter diff_spec : forall `{Ok s, Ok s'},
    In x (diff s s') <-> In x s /\ ~In x s'.
  Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
    fold f s i = fold_left (flip f) (elements s) i.
  Parameter cardinal_spec : forall `{Ok s},
    cardinal s = length (elements s).
  Parameter filter_spec : compatb f ->
    (In x (filter f s) <-> In x s /\ f x = true).
  Parameter for_all_spec : compatb f ->
    (for_all f s = true <-> For_all (fun x => f x = true) s).
  Parameter exists_spec : compatb f ->
    (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Parameter partition_spec1 : compatb f ->
    fst (partition f s) [=] filter f s.
  Parameter partition_spec2 : compatb f ->
    snd (partition f s) [=] filter (fun x => negb (f x)) s.
  Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s.
  Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s).
  Parameter choose_spec1 : choose s = Some x -> In x s.
  Parameter choose_spec2 : choose s = None -> Empty s.

  End Spec.

End WRawSets.

(** From weak raw sets to weak usual sets *)

Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E.

 (** We avoid creating induction principles for the Record *)
 Local Unset Elimination Schemes.

 Definition elt := E.t.

 Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}.
 Definition t := t_.
 Arguments Mkt this {is_ok}.
 Hint Resolve is_ok : typeclass_instances.

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

 Definition mem (x : elt)(s : t) := M.mem x s.
 Definition add (x : elt)(s : t) : t := Mkt (M.add x s).
 Definition remove (x : elt)(s : t) : t := Mkt (M.remove x s).
 Definition singleton (x : elt) : t := Mkt (M.singleton x).
 Definition union (s s' : t) : t := Mkt (M.union s s').
 Definition inter (s s' : t) : t := Mkt (M.inter s s').
 Definition diff (s s' : t) : t := Mkt (M.diff s s').
 Definition equal (s s' : t) := M.equal s s'.
 Definition subset (s s' : t) := M.subset s s'.
 Definition empty : t := Mkt M.empty.
 Definition is_empty (s : t) := M.is_empty s.
 Definition elements (s : t) : list elt := M.elements s.
 Definition choose (s : t) : option elt := M.choose s.
 Definition fold (A : Type)(f : elt -> A -> A)(s : t) : A -> A := M.fold f s.
 Definition cardinal (s : t) := M.cardinal s.
 Definition filter (f : elt -> bool)(s : t) : t := Mkt (M.filter f s).
 Definition for_all (f : elt -> bool)(s : t) := M.for_all f s.
 Definition exists_ (f : elt -> bool)(s : t) := M.exists_ f s.
 Definition partition (f : elt -> bool)(s : t) : t * t :=
   let p := M.partition f s in (Mkt (fst p), Mkt (snd p)).

 Instance In_compat : Proper (E.eq==>eq==>iff) In.
 Proof. repeat red. intros; apply M.In_compat; congruence. Qed.

 Definition eq : t -> t -> Prop := Equal.

 Instance eq_equiv : Equivalence eq.
 Proof. firstorder. Qed.

 Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }.
 Proof.
  intros (s,Hs) (s',Hs').
  change ({M.Equal s s'}+{~M.Equal s s'}).
  destruct (M.equal s s') eqn:H; [left|right];
   rewrite <- M.equal_spec; congruence.
 Defined.

 Section Spec.
  Variable s s' : t.
  Variable x y : elt.
  Variable f : elt -> bool.
  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).

  Lemma mem_spec : mem x s = true <-> In x s.
  Proof. exact (@M.mem_spec _ _ _). Qed.
  Lemma equal_spec : equal s s' = true <-> Equal s s'.
  Proof. exact (@M.equal_spec _ _ _ _). Qed.
  Lemma subset_spec : subset s s' = true <-> Subset s s'.
  Proof. exact (@M.subset_spec _ _ _ _). Qed.
  Lemma empty_spec : Empty empty.
  Proof. exact M.empty_spec. Qed.
  Lemma is_empty_spec : is_empty s = true <-> Empty s.
  Proof. exact (@M.is_empty_spec _). Qed.
  Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
  Proof. exact (@M.add_spec _ _ _ _). Qed.
  Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
  Proof. exact (@M.remove_spec _ _ _ _). Qed.
  Lemma singleton_spec : In y (singleton x) <-> E.eq y x.
  Proof. exact (@M.singleton_spec _ _). Qed.
  Lemma union_spec : In x (union s s') <-> In x s \/ In x s'.
  Proof. exact (@M.union_spec _ _ _ _ _). Qed.
  Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'.
  Proof. exact (@M.inter_spec _ _ _ _ _). Qed.
  Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'.
  Proof. exact (@M.diff_spec _ _ _ _ _). Qed.
  Lemma fold_spec : 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 (@M.fold_spec _). Qed.
  Lemma cardinal_spec : cardinal s = length (elements s).
  Proof. exact (@M.cardinal_spec s _). Qed.
  Lemma filter_spec : compatb f ->
    (In x (filter f s) <-> In x s /\ f x = true).
  Proof. exact (@M.filter_spec _ _ _). Qed.
  Lemma for_all_spec : compatb f ->
    (for_all f s = true <-> For_all (fun x => f x = true) s).
  Proof. exact (@M.for_all_spec _ _). Qed.
  Lemma exists_spec : compatb f ->
    (exists_ f s = true <-> Exists (fun x => f x = true) s).
  Proof. exact (@M.exists_spec _ _). Qed.
  Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s).
  Proof. exact (@M.partition_spec1 _ _). Qed.
  Lemma partition_spec2 : compatb f ->
      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
  Proof. exact (@M.partition_spec2 _ _). Qed.
  Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s.
  Proof. exact (@M.elements_spec1 _ _). Qed.
  Lemma elements_spec2w : NoDupA E.eq (elements s).
  Proof. exact (@M.elements_spec2w _ _). Qed.
  Lemma choose_spec1 : choose s = Some x -> In x s.
  Proof. exact (@M.choose_spec1 _ _). Qed.
  Lemma choose_spec2 : choose s = None -> Empty s.
  Proof. exact (@M.choose_spec2 _). Qed.

 End Spec.

End WRaw2SetsOn.

Module WRaw2Sets (D:DecidableType)(M:WRawSets D) <: WSets with Module E := D.
  Module E := D.
  Include WRaw2SetsOn D M.
End WRaw2Sets.

(** Same approach for ordered sets *)

Module Type RawSets (E : OrderedType).
  Include WRawSets E <+ HasOrdOps <+ HasLt <+ IsStrOrder.

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

  (** Specification of [compare] *)
  Parameter compare_spec : forall `{Ok s, Ok s'}, CompSpec eq lt s s' (compare s s').

  (** Additional specification of [elements] *)
  Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s).

  (** Specification of [min_elt] *)
  Parameter min_elt_spec1 : min_elt s = Some x -> In x s.
  Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x.
  Parameter min_elt_spec3 : min_elt s = None -> Empty s.

  (** Specification of [max_elt] *)
  Parameter max_elt_spec1 : max_elt s = Some x -> In x s.
  Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y.
  Parameter max_elt_spec3 : max_elt s = None -> Empty s.

  (** Additional specification of [choose] *)
  Parameter choose_spec3 : forall `{Ok s, Ok s'},
    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.

  End Spec.

End RawSets.

(** From Raw to usual sets *)

Module Raw2SetsOn (O:OrderedType)(M:RawSets O) <: SetsOn O.
  Include WRaw2SetsOn O M.

  Definition compare (s s':t) := M.compare s s'.
  Definition min_elt (s:t) : option elt := M.min_elt s.
  Definition max_elt (s:t) : option elt := M.max_elt s.
  Definition lt (s s':t) := M.lt s s'.

  (** Specification of [lt] *)
  Instance lt_strorder : StrictOrder lt.
  Proof. constructor ; unfold lt; red.
    unfold complement. red. intros. apply (irreflexivity H).
    intros. transitivity y; auto.
  Qed.

  Instance lt_compat : Proper (eq==>eq==>iff) lt.
  Proof.
  repeat red. unfold eq, lt.
  intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl.
  change (M.eq s1 s2) in E.
  change (M.eq s1' s2') in E'.
  rewrite E,E'; intuition.
  Qed.

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

  Lemma compare_spec : CompSpec eq lt s s' (compare s s').
  Proof. unfold compare; destruct (@M.compare_spec s s' _ _); auto. Qed.

  (** Additional specification of [elements] *)
  Lemma elements_spec2 : sort O.lt (elements s).
  Proof. exact (@M.elements_spec2 _ _). Qed.

  (** Specification of [min_elt] *)
  Lemma min_elt_spec1 : min_elt s = Some x -> In x s.
  Proof. exact (@M.min_elt_spec1 _ _). Qed.
  Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x.
  Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed.
  Lemma min_elt_spec3 : min_elt s = None -> Empty s.
  Proof. exact (@M.min_elt_spec3 _). Qed.

  (** Specification of [max_elt] *)
  Lemma max_elt_spec1 : max_elt s = Some x -> In x s.
  Proof. exact (@M.max_elt_spec1 _ _). Qed.
  Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y.
  Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed.
  Lemma max_elt_spec3 : max_elt s = None -> Empty s.
  Proof. exact (@M.max_elt_spec3 _). Qed.

  (** Additional specification of [choose] *)
  Lemma choose_spec3 :
    choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y.
  Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed.

  End Spec.

End Raw2SetsOn.

Module Raw2Sets (O:OrderedType)(M:RawSets O) <: Sets with Module E := O.
  Module E := O.
  Include Raw2SetsOn O M.
End Raw2Sets.

(** It is in fact possible to provide an ordering on sets with
    very little information on them (more or less only the [In]
    predicate). This generic build of ordering is in fact not
    used for the moment, we rather use a simplier version
    dedicated to sets-as-sorted-lists, see [MakeListOrdering].
*)

Module Type IN (O:OrderedType).
 Parameter Inline t : Type.
 Parameter Inline In : O.t -> t -> Prop.
 Declare Instance In_compat : Proper (O.eq==>eq==>iff) In.
 Definition Equal s s' := forall x, In x s <-> In x s'.
 Definition Empty s := forall x, ~In x s.
End IN.

Module MakeSetOrdering (O:OrderedType)(Import M:IN O).
 Module Import MO := OrderedTypeFacts O.

 Definition eq : t -> t -> Prop := Equal.

 Instance eq_equiv : Equivalence eq.
 Proof. firstorder. Qed.

 Instance : Proper (O.eq==>eq==>iff) In.
 Proof.
 intros x x' Ex s s' Es. rewrite Ex. apply Es.
 Qed.

 Definition Below x s := forall y, In y s -> O.lt y x.
 Definition Above x s := forall y, In y s -> O.lt x y.

 Definition EquivBefore x s s' :=
   forall y, O.lt y x -> (In y s <-> In y s').

 Definition EmptyBetween x y s :=
   forall z, In z s -> O.lt z y -> O.lt z x.

 Definition lt s s' := exists x, EquivBefore x s s' /\
   ((In x s' /\ Below x s) \/
    (In x s  /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')).

 Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore.
 Proof.
  unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2.
  setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition.
 Qed.

 Instance : Proper (O.eq==>eq==>iff) Below.
 Proof.
  unfold Below. intros x x' Ex s s' Es.
  setoid_rewrite Ex; setoid_rewrite Es; intuition.
 Qed.

 Instance : Proper (O.eq==>eq==>iff) Above.
 Proof.
  unfold Above. intros x x' Ex s s' Es.
  setoid_rewrite Ex; setoid_rewrite Es; intuition.
 Qed.

 Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween.
 Proof.
  unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es.
  setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition.
 Qed.

 Instance lt_compat : Proper (eq==>eq==>iff) lt.
 Proof.
  unfold lt. intros s1 s1' E1 s2 s2' E2.
  setoid_rewrite E1; setoid_rewrite E2; intuition.
 Qed.

 Instance lt_strorder : StrictOrder lt.
 Proof.
  split.
  (* irreflexive *)
  intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]).
  specialize (Em x IN); order.
  specialize (Be x IN LT); order.
  (* transitive *)
  intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)])
                  (x' & EQ' & [(IN',Pre')|(IN',Lex')]).
  (* 1) Pre / Pre --> Pre *)
  assert (O.lt x x') by (specialize (Pre' x IN); auto).
  exists x; split.
  intros y Hy; rewrite <- (EQ' y); auto; order.
  left; split; auto.
  rewrite <- (EQ' x); auto.
  (* 2) Pre / Lex *)
  elim_compare x x'.
  (* 2a) x=x' --> Pre *)
  destruct Lex' as (y & INy & LT & Be).
  exists y; split.
  intros z Hz. split; intros INz.
   specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order.
   specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order.
  left; split; auto.
  intros z Hz. transitivity x; auto; order.
  (* 2b) x<x' --> Pre *)
  exists x; split.
  intros z Hz. rewrite <- (EQ' z) by order; auto.
  left; split; auto.
  rewrite <- (EQ' x); auto.
  (* 2c) x>x' --> Lex *)
  exists x'; split.
  intros z Hz. rewrite (EQ z) by order; auto.
  right; split; auto.
  rewrite (EQ x'); auto.
  (* 3) Lex / Pre --> Lex *)
  destruct Lex as (y & INy & LT & Be).
  specialize (Pre' y INy).
  exists x; split.
  intros z Hz. rewrite <- (EQ' z) by order; auto.
  right; split; auto.
  exists y; repeat split; auto.
  rewrite <- (EQ' y); auto.
  intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order.
  (* 4) Lex / Lex *)
  elim_compare x x'.
  (* 4a) x=x' --> impossible *)
  destruct Lex as (y & INy & LT & Be).
  setoid_replace x with x' in LT; auto.
  specialize (Be x' IN' LT); order.
  (* 4b) x<x' --> Lex *)
  exists x; split.
  intros z Hz. rewrite <- (EQ' z) by order; auto.
  right; split; auto.
  destruct Lex as (y & INy & LT & Be).
  elim_compare y x'.
   (* 4ba *)
   destruct Lex' as (y' & Iny' & LT' & Be').
   exists y'; repeat split; auto. order.
   intros z Hz LTz. specialize (Be' z Hz LTz).
    rewrite <- (EQ' z) in Hz by order.
    apply Be; auto. order.
   (* 4bb *)
   exists y; repeat split; auto.
   rewrite <- (EQ' y); auto.
   intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order.
   (* 4bc*)
   assert (O.lt x' x) by auto. order.
  (* 4c) x>x' --> Lex *)
  exists x'; split.
  intros z Hz. rewrite (EQ z) by order; auto.
  right; split; auto.
  rewrite (EQ x'); auto.
 Qed.

 Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'.
 Proof.
  intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]).
  elim (Hs' x IN).
  elim (Hs' y IN).
 Qed.

 Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s.

 Lemma lt_empty_l : forall x s1 s2 s2',
  Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'.
 Proof.
  intros x s1 s2 s2' Em Ab Ad.
  exists x; split.
  intros y Hy; split; intros IN.
  elim (Em y IN).
  rewrite (Ad y) in IN; destruct IN as [EQ|IN]. order.
  specialize (Ab y IN). order.
  left; split.
  rewrite (Ad x). now left.
  intros y Hy. elim (Em y Hy).
 Qed.

 Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2',
   Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' ->
   O.lt x1 x2 -> lt s1' s2'.
  Proof.
  intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT.
  exists x1; split; [ | right; split]; auto.
  intros y Hy. rewrite (Ad1 y), (Ad2 y).
  split; intros [U|U]; try order.
  specialize (Ab1 y U). order.
  specialize (Ab2 y U). order.
  rewrite (Ad1 x1); auto with *.
  exists x2; repeat split; auto.
  rewrite (Ad2 x2); now left.
  intros y. rewrite (Ad2 y). intros [U|U]. order.
  specialize (Ab2 y U). order.
  Qed.

  Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2',
   Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' ->
   O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'.
  Proof.
  intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj).
  assert (O.lt x1 x).
   destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto.
  exists x; split.
  intros z Hz. rewrite (Ad1 z), (Ad2 z).
  split; intros [U|U]; try (left; order); right.
  rewrite <- (EQ z); auto.
  rewrite (EQ z); auto.
  destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)].
  left; split; auto.
  rewrite (Ad2 x); auto.
  intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); auto; order.
  right; split; auto.
  rewrite (Ad1 x); auto.
  exists y; repeat split; auto.
  rewrite (Ad2 y); auto.
  intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); auto; order.
  Qed.

End MakeSetOrdering.

Module MakeListOrdering (O:OrderedType).
 Module MO:=OrderedTypeFacts O.

 Local Notation t := (list O.t).
 Local Notation In := (InA O.eq).

 Definition eq s s' := forall x, In x s <-> In x s'.

 Instance eq_equiv : Equivalence eq := _.

 Inductive lt_list : t -> t -> Prop :=
    | lt_nil : forall x s, lt_list nil (x :: s)
    | lt_cons_lt : forall x y s s',
        O.lt x y -> lt_list (x :: s) (y :: s')
    | lt_cons_eq : forall x y s s',
        O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s').
 Hint Constructors lt_list.

 Definition lt := lt_list.
 Hint Unfold lt.

 Instance lt_strorder : StrictOrder lt.
 Proof.
 split.
 (* irreflexive *)
 assert (forall s s', s=s' -> ~lt s s').
  red; induction 2.
  discriminate.
  inversion H; subst.
  apply (StrictOrder_Irreflexive y); auto.
  inversion H; subst; auto.
 intros s Hs; exact (H s s (eq_refl s) Hs).
 (* transitive *)
 intros s s' s'' H; generalize s''; clear s''; elim H.
 intros x l s'' H'; inversion_clear H'; auto.
 intros x x' l l' E s'' H'; inversion_clear H'; auto.
 constructor 2. transitivity x'; auto.
 constructor 2. rewrite <- H0; auto.
 intros.
 inversion_clear H3.
 constructor 2. rewrite H0; auto.
 constructor 3; auto. transitivity y; auto. unfold lt in *; auto.
 Qed.

 Instance lt_compat' :
  Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt.
 Proof.
 apply proper_sym_impl_iff_2; auto with *.
 intros s1 s1' E1 s2 s2' E2 H.
 revert s1' E1 s2' E2.
 induction H; intros; inversion_clear E1; inversion_clear E2.
 constructor 1.
 constructor 2. MO.order.
 constructor 3. MO.order. unfold lt in *; auto.
 Qed.

 Lemma eq_cons :
  forall l1 l2 x y,
  O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2).
 Proof.
  unfold eq; intros l1 l2 x y Exy E12 z.
  split; inversion_clear 1.
  left; MO.order. right; rewrite <- E12; auto.
  left; MO.order. right; rewrite E12; auto.
 Qed.
 Hint Resolve eq_cons.

 Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 ->
  CompSpec eq lt l1 l2 c -> CompSpec eq lt (x1::l1) (x2::l2) c.
 Proof.
  destruct c; simpl; inversion_clear 2; auto with relations.
 Qed.
 Hint Resolve cons_CompSpec.

End MakeListOrdering.


Require Import Fiat.QueryStructure.Automation.MasterPlan.

Definition MEMBERS := "Members".
Definition REPOSITORIES := "Repositories".
Definition COMMITS := "Commits".

Definition USERNAME := "Username".
Definition STAR := "Star".
Definition PROJECT_NAME := "ProjectName".
Definition HASH := "Hash".
Definition CREATED_AT := "CreatedAt".

Definition hash := list ascii.

Definition GithubSchema :=
  Query Structure Schema
        [ relation REPOSITORIES has
                   schema <PROJECT_NAME :: string,
                           STAR :: nat>;
          relation COMMITS has
                   schema <PROJECT_NAME :: string,
                           HASH :: hash,
                           CREATED_AT :: nat> ]
        enforcing [ attribute PROJECT_NAME for COMMITS references REPOSITORIES ].

Definition GithubSpec : ADT _ :=
  Def ADT {
    rep := QueryStructure GithubSchema,
    Def Constructor0 "Init" : rep := empty,,

    Def Method1 "AddRepository" (r : rep) (repository : GithubSchema#REPOSITORIES) : rep * bool :=
      Insert repository into r!REPOSITORIES,

    Def Method1 "AddCommit" (r : rep) (commit : GithubSchema#COMMITS) : rep * bool :=
      Insert commit into r!COMMITS,

    Def Method1 "PopularProjects" (r : rep) (star_threshold : nat) : rep * (list string) :=
        res <- For (repository in r!REPOSITORIES)
          Where (repository!STAR >= star_threshold)
          Return repository!PROJECT_NAME;
    ret (r, res),

    Def Method1 "ProjectCommits" (r : rep) (project : string) : rep * list hash :=
      res <- For (commit in r!COMMITS)
          Where (commit!PROJECT_NAME = project)
          Return commit!HASH;
    ret (r, res),

    Def Method1 "RecentProjects" (r : rep) (date_threshold : nat) : rep * list string :=
      res <- For (repository in r!REPOSITORIES) (
          c <- Count (For (commit in r!COMMITS)
                            Where (commit!PROJECT_NAME = repository!PROJECT_NAME)
                            Where (commit!CREATED_AT >= date_threshold)
                            Return ());
          If (c == 0) Then ret [ ]
          Else ret [repository!PROJECT_NAME]);
          ret (r, res)
}%methDefParsing.

Definition SharpenedGithub :
  FullySharpened GithubSpec.
Proof.
  start sharpening ADT.
  pose_string_hyps.
  eapply SharpenStep;
  [ match goal with
        |- context [@BuildADT (QueryStructure ?Rep) _ _ _ _ _ _] =>
        eapply refineADT_BuildADT_Rep_refine_All with (AbsR := @DropQSConstraints_AbsR Rep);
          [ repeat (first [eapply refine_Constructors_nil
                          | eapply refine_Constructors_cons;
                            [ simpl; intros;
                              match goal with
                              | |- refine _ (?E _ _ _ _) => let H := fresh in set (H := E)
                              | |- refine _ (?E _ _ _) => let H := fresh in set (H := E)
                              | |- refine _ (?E _ _) => let H := fresh in set (H := E)
                              | |- refine _ (?E _) => let H := fresh in set (H := E)
                              | |- refine _ (?E) => let H := fresh in set (H := E)
                              | _ => idtac
                              end;
                              (* Drop constraints from empty *)
                              try apply Constructor_DropQSConstraints;
                              cbv delta [GetAttribute] beta; simpl
                            | ] ])
          | repeat (first [eapply refine_Methods_nil
                          | eapply refine_Methods_cons;
                            [ simpl; intros;
                              match goal with
                              | |- refine _ (?E _ _ _ _) => let H := fresh in set (H := E)
                              | |- refine _ (?E _ _ _) => let H := fresh in set (H := E)
                              | |- refine _ (?E _ _) => let H := fresh in set (H := E)
                              | |- refine _ (?E _) => let H := fresh in set (H := E)
                              | |- refine _ (?E) => let H := fresh in set (H := E)
                              | _ => idtac
                              end;
                              cbv delta [GetAttribute] beta; simpl | ]
                          ])]
    end | ].
  - doAny drop_constraints
          master_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
  - doAny drop_constraints
           master_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
  - doAny drop_constraints
           master_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
  - doAny drop_constraints
          master_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
  - doAny drop_constraints
          master_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
  - hone representation using (@FiniteTables_AbsR GithubSchema).
    + simplify with monad laws.
      refine pick val _; simpl; intuition.
      eauto using FiniteTables_AbsR_QSEmptySpec.
    + doAny simplify_queries
             Finite_AbsR_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
    + doAny simplify_queries
             Finite_AbsR_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
    + doAny simplify_queries
             Finite_AbsR_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
    + doAny simplify_queries
            Finite_AbsR_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).
    + repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
      repeat simplify_queries.
      Finite_AbsR_rewrite_drill || (repeat subst_refine_evar; try finish honing).
    + simpl.
    + doAny simplify_queries
            Finite_AbsR_rewrite_drill ltac:(repeat subst_refine_evar; try finish honing).

    + simpl.

  master_plan
    ltac:(CombineIndexTactics RangeIndexTactics EqIndexTactics).
Time Defined.

Time Definition GithubImpl : ComputationalADT.cADT GithubSig :=
  Eval simpl in projT1 SharpenedGithub.

Print GithubImpl.