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.


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.


Require Import Fiat.QueryStructure.Automation.MasterPlan.

Definition PEOPLE := "People".
Definition CITIES := "Cities".
Definition FRIENDSHIPS := "Friendship".

Definition NAME := "Name".
Definition CITY := "City".
Definition LATITUDE := "Latitude".
Definition LONGITUDE := "Longitude".

Definition FriendFinderSchema :=
  Query Structure Schema
    [ relation PEOPLE has
              schema <NAME :: string,
                      CITY :: string>;
      relation CITIES has
              schema <CITY :: string,
                      LATITUDE :: nat,
                      LONGITUDE :: nat>
    ]
    enforcing [attribute CITY for PEOPLE references CITIES].

Definition FriendFinderSig : ADTSig :=
  ADTsignature {
      Constructor "Init"
           : unit                              -> rep,
      Method "AddPerson"
           : rep * (FriendFinderSchema#PEOPLE) -> rep * bool,
      Method "AddCity"
           : rep * (FriendFinderSchema#CITIES) -> rep * bool,
      Method "PeopleAround"
           : rep * string * nat              -> rep * (list string),
      Method "PeopleInCity"
           : rep * string                 -> rep * nat
    }.

Definition FriendFinderSpec : ADT _ :=
  Def ADT {
    rep := QueryStructure FriendFinderSchema,
    Def Constructor0 "Init"  : rep := empty,,

    Def Method1 "AddPerson" (r : rep) (person : FriendFinderSchema#PEOPLE) : rep * bool :=
      Insert person into r!PEOPLE,

    Def Method1 "AddCity" (r : rep) (city : FriendFinderSchema#CITIES) : rep * bool :=
      Insert city into r!CITIES,

    Def Method2 "PeopleAround" (r : rep) (name : string) (distance : nat) : rep * (list string) :=
        res <- For (person_me in r!PEOPLE)
          (person in r!PEOPLE)
          (city_me in r!CITIES)
          (city in r!CITIES)
          Where (person_me!NAME = name)
          Where (city_me!CITY = person_me!CITY)
          Where (city_me!LATITUDE - distance <=
                 city!LATITUDE <= city_me!LATITUDE + distance)
          Where (city_me!LONGITUDE - distance <=
                 city!LONGITUDE <= city_me!LONGITUDE + distance)
          Where (person!CITY = city!CITY)
          Return person!NAME;
    ret (r, res),

     Def Method1 "PeopleInCity" (r : rep) (city : string) : rep * nat :=
      res <- Count (For (person in r!PEOPLE)
                  Where (person!CITY = city)
                  Return ());
    ret (r, res)
}%methDefParsing.

Definition SharpenedFriendFinder :
  FullySharpened FriendFinderSpec.
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).
  - hone representation using (@FiniteTables_AbsR FriendFinderSchema).
    + 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).
    + simpl.

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

Time Definition FriendFinderImpl : ComputationalADT.cADT FriendFinderSig :=
  Eval simpl in (projT1 SharpenedFriendFinder).
Print FriendFinderImpl.