(*************************************************************************)
(* Copyright (C) 2013 - 2015                                             *)
(* Author C. Cohen                                                       *)
(* DRAFT - PLEASE USE WITH CAUTION                                       *)
(* License CeCILL-B                                                      *)
(*************************************************************************)
Set Warnings "-notation-incompatible-format".
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
Set Warnings "notation-incompatible-format".
From mathcomp Require Import choice path finset finfun fintype bigop tuple.
Require Import finmap.

(*****************************************************************************)
(* This file provides a representation of multisets based on fsfun           *)
(*   {mset T} == the type of multisets on a choiceType T                     *)
(* The following notations are in the %mset scope                            *)
(*             mset0 == the empty multiset                                   *)
(*          mset n a == the multiset with n times element a                  *)
(*          [mset a] == the singleton multiset {k} := mset 1 a               *)
(* [mset a1; ..; an] == the multiset obtained from the elements a1,..,an     *)
(*           A `&` B == the intersection of A and B (the min of each)        *)
(*           A `|` B == the union of A and B (the max of each)               *)
(*           A `+` B == the sum of A and B                                   *)
(*            a |` B == the union of singleton a and B                       *)
(*            a +` B == the addition of singleton a to B                     *)
(*           A `\` B == the difference A minus B                             *)
(*            A `\ b == A without one b                                      *)
(*           A `*` B == the product of A and B                               *)
(*  [disjoint A & B] := A `&` B == 0                                         *)
(*          A `<=` B == A is a sub-multiset of B                             *)
(*           A `<` B == A is a proper sub-multiset of B                      *)
(*****************************************************************************)

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

Lemma sumn_map I (f : I -> nat) s :
   sumn [seq f i | i <- s] = \sum_(i <- s) f i.
Proof. by elim: s => [|i s IHs] in f *; rewrite ?(big_nil, big_cons) //= IHs. Qed.

Lemma sumn_filter s P : sumn [seq i <- s | P i] = \sum_(i <- s | P i) i.
Proof. by rewrite -big_filter -sumn_map map_id. Qed.

Lemma sumn_map_filter I s (f : I -> nat) P :
   sumn [seq f i | i <- s & P i] = \sum_(i <- s | P i) f i.
Proof. by rewrite sumn_map big_filter. Qed.

Declare Scope mset_scope.
Delimit Scope mset_scope with mset.
Local Open Scope fset_scope.
Local Open Scope fmap_scope.
Local Open Scope mset_scope.
Local Open Scope nat_scope.

Definition multiset (T : choiceType) := {fsfun T -> nat with 0}.
Definition multiset_of (T : choiceType) of phant T := @multiset T.
Notation "'{mset' T }" := (@multiset_of _ (Phant T))
  (format "'{mset'  T }") : mset_scope.

Notation "[ 'mset[' key ] x 'in' aT => F ]" := ([fsfun[key] x in aT => F] : {mset _})
  (at level 0, x name, only parsing) : mset_scope.
Notation "[ 'mset' x 'in' aT => F ]" := ([fsfun x in aT => F] : {mset _})
  (at level 0, x name, only parsing) : mset_scope.
Notation "[ 'm' 'set' x 'in' aT => F ]" := ([fsfun[_] x in aT => F] : {mset _})
  (at level 0, x name, format "[ 'm' 'set'  x  'in'  aT  =>  F ]") : mset_scope.

Identity Coercion multiset_multiset_of : multiset_of >-> multiset.

Notation enum_mset_def A :=
  (flatten [seq nseq (A%mset x) x | x <- finsupp A%mset]).

Module Type EnumMsetSig.
Axiom f : forall K, multiset K -> seq K.
Axiom E : f = (fun K (A : multiset K) => enum_mset_def A).
End EnumMsetSig.
Module EnumMset : EnumMsetSig.
Definition f K (A : multiset K) := enum_mset_def A.
Definition E := (erefl f).
End EnumMset.
Notation enum_mset := EnumMset.f.
Coercion enum_mset : multiset >-> seq.
Canonical enum_mset_unlock := Unlockable EnumMset.E.

Canonical multiset_predType (K : choiceType) :=
  PredType (fun (A : multiset K) a => a \in enum_mset A).
Canonical mset_finpredType (T: choiceType) :=
  mkFinPredType (multiset T) (fun A => undup (enum_mset A))
                (fun _ => undup_uniq _) (fun _ _ => mem_undup _ _).

Section MultisetOps.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Definition mset0 : {mset K} := [fsfun].

Fact msetn_key : unit. Proof. exact: tt. Qed.
Definition msetn n a := [mset[msetn_key] x in [fset a] => n].

Fact seq_mset_key : unit. Proof. exact: tt. Qed.
Definition seq_mset (s : seq K) :=
  [mset[seq_mset_key] x in [fset x in s] => count (pred1 x) s].

Fact msetU_key : unit. Proof. exact: tt. Qed.
Definition msetU A B :=
  [mset[msetU_key] x in finsupp A `|` finsupp B => maxn (A x) (B x)].

Fact msetI_key : unit. Proof. exact: tt. Qed.
Definition msetI A B :=
  [mset[msetI_key] x in finsupp A `|` finsupp B => minn (A x) (B x)].

Fact msetD_key : unit. Proof. exact: tt. Qed.
Definition msetD A B :=
  [mset[msetD_key] x in finsupp A `|` finsupp B => A x + B x].

Fact msetB_key : unit. Proof. exact: tt. Qed.
Definition msetB A B :=
  [mset[msetB_key] x in finsupp A `|` finsupp B => A x - B x].

Fact msetM_key : unit. Proof. exact: tt. Qed.
Definition msetM A B :=
  [mset[msetM_key] x in finsupp A `*` finsupp B => A x.1 * B x.2].

Definition msubset A B := [forall x : finsupp A, A (val x) <= B (val x)].

Definition mproper A B := msubset A B && ~~ msubset B A.

Definition mdisjoint A B := (msetI A B == mset0).

End MultisetOps.

Notation "[ 'mset' a ]" := (msetn 1 a)
  (at level 0, a at level 99, format "[ 'mset'  a ]") : mset_scope.
Notation "[ 'mset' a : T ]" := [mset (a : T)]
  (at level 0, a at level 99, format "[ 'mset'  a   :  T ]") : mset_scope.
Notation "A `|` B" := (msetU A B) : mset_scope.
Notation "A `+` B" := (msetD A B) : mset_scope.
Notation "A `\` B" := (msetB A B) : mset_scope.
Notation "A `\ a" := (A `\` [mset a]) : mset_scope.
Notation "a |` A" := ([mset (a)] `|` A) : mset_scope.
Notation "a +` A" := ([mset (a)] `+` A) : mset_scope.
Notation "A `*` B" := (msetM A B) : mset_scope.

Notation "A `<=` B" := (msubset A B)
  (at level 70, no associativity) : mset_scope.

Notation "A `<` B" := (mproper A B)
  (at level 70, no associativity) : mset_scope.

(* This is left-associative due to historical limitations of the .. Notation. *)
Notation "[ 'mset' a1 ; a2 ; .. ; an ]" :=
  (msetD .. (a1 +` (msetn 1 a2)) .. (msetn 1 an))
  (at level 0, a1 at level 99,
   format "[ 'mset'  a1 ;  a2 ;  .. ;  an ]") : mset_scope.
Notation "A `&` B" := (msetI A B) : mset_scope.

Section MSupp.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Lemma enum_msetE a A :
   (a \in A) = (a \in flatten [seq nseq (A x) x | x <- finsupp A]).
Proof. by transitivity (a \in enum_mset A); rewrite // unlock. Qed.

Lemma msuppE a A : (a \in finsupp A) = (a \in A).
Proof.
rewrite enum_msetE.
apply/idP/flattenP => [aA|/=[_ /mapP[x xA -> /nseqP[->//]]]].
exists (nseq (A a) a); first by apply/mapP; exists a.
by apply/nseqP; split=> //; rewrite lt0n -mem_finsupp.
Qed.

End MSupp.

Section MSetTheory.

Context {K : choiceType}.
Implicit Types (a b c : K) (A B C D : {mset K}) (s : seq K).

Lemma msetP {A B} : A =1 B <-> A = B.
Proof. exact: fsfunP. Qed.

Lemma mset_neq0 a A : (A a != 0) = (a \in A).
Proof. by rewrite -msuppE mem_finsupp. Qed.

Lemma in_mset a A : (a \in A) = (A a > 0).
Proof. by rewrite -mset_neq0 lt0n. Qed.

Lemma mset_eq0 a A : (A a == 0) = (a \notin A).
Proof. by rewrite -mset_neq0 negbK. Qed.

Lemma mset_eq0P {a A} : reflect (A a = 0) (a \notin A).
Proof. by rewrite -mset_eq0; apply: eqP. Qed.

Lemma mset_gt0 a A : (A a > 0) = (a \in A).
Proof. by rewrite -in_mset. Qed.

Lemma mset_eqP {A B} : reflect (A =1 B) (A == B).
Proof. exact: (equivP eqP (iff_sym msetP)). Qed.

Lemma mset0E a : mset0 a = 0.
Proof. by rewrite /mset0 fsfunE. Qed.

Lemma msetnE n a b : (msetn n a) b = if b == a then n else 0.
Proof. by rewrite fsfunE inE. Qed.

Lemma msetnxx n a : (msetn n a) a = n. Proof. by rewrite msetnE eqxx. Qed.

Lemma msetE2 A B a :
 ((A `+` B) a = A a + B a) * ((A `|` B) a = maxn (A a) (B a))
* ((A `&` B) a = minn (A a) (B a)) * ((A `\` B) a = (A a) - (B a)).
Proof.
rewrite !fsfunE !inE !msuppE -!mset_neq0; case: ifPn => //.
by rewrite negb_or !negbK => /andP [/eqP-> /eqP->].
Qed.

Lemma count_mem_mset a A : count_mem a A = A a.
Proof.
rewrite unlock count_flatten sumn_map big_map.
rewrite (eq_bigr _ (fun _ _ => esym (sum1_count _ _))) /=.
rewrite (eq_bigr _ (fun _ _ => big_nseq_cond _ _ _ _ _ _)) /= -big_mkcond /=.
have [aNA|aA] := finsuppP.
  by rewrite big1_fset // => i iA /eqP eq_ia; rewrite -eq_ia iA in aNA.
rewrite big_fset_condE/= (big_fsetD1 a) ?inE ?eqxx ?andbT //= iter_addn mul1n.
rewrite (_ : (_ `\ _)%fset = fset0) ?big_seq_fset0 ?addn0//.
by apply/fsetP=> i; rewrite !inE; case: (i == a); rewrite ?(andbF, andbT).
Qed.

Lemma perm_undup_mset A : perm_eq (undup A) (finsupp A).
Proof.
apply: uniq_perm; rewrite ?undup_uniq // => a.
by rewrite mem_undup msuppE.
Qed.

Section big_com.
Variables (R : Type) (idx : R) (op : Monoid.com_law idx).
Implicit Types (X : {mset K}) (P : pred K) (F : K -> R).

Lemma big_mset X P F :
  \big[op/idx]_(i <- X | P i) F i =
  \big[op/idx]_(i <- finsupp X | P i) iterop (X i) op (F i) idx.
Proof.
rewrite [in RHS](perm_big (undup X)) 1?perm_sym ?perm_undup_mset//.
rewrite -[in LHS]big_undup_iterop_count; apply: eq_bigr => i _.
by rewrite count_mem_mset.
Qed.

End big_com.

Lemma sum_mset (X : {mset K}) (P : pred K) (F : K -> nat) :
  \sum_(i <- X | P i) F i = \sum_(i <- finsupp X | P i) X i * F i.
Proof.
rewrite big_mset; apply: eq_bigr => i _ //.
by rewrite Monoid.iteropE iter_addn addn0 mulnC.
Qed.

Lemma prod_mset (X : {mset K}) (P : pred K) (F : K -> nat) :
  \prod_(i <- X | P i) F i = \prod_(i <- finsupp X | P i) F i ^ X i.
Proof. by rewrite big_mset. Qed.

Lemma mset_seqE s a : (seq_mset s) a = count_mem a s.
Proof. by rewrite fsfunE inE/=; case: ifPn => // /count_memPn ->. Qed.

Lemma perm_eq_seq_mset s : perm_eq (seq_mset s) s.
Proof. by apply/allP => a _ /=; rewrite count_mem_mset mset_seqE. Qed.

Lemma seq_mset_id A : seq_mset A = A.
Proof. by apply/msetP=> a; rewrite mset_seqE count_mem_mset. Qed.

Lemma eq_seq_msetP s s' : reflect (seq_mset s = seq_mset s') (perm_eq s s').
Proof.
apply: (iffP idP) => [/permP perm_ss'|eq_ss'].
  by apply/msetP => a; rewrite !mset_seqE perm_ss'.
by apply/allP => a _ /=; rewrite -!mset_seqE eq_ss'.
Qed.

Lemma msetME A B (u : K * K) : (A `*` B) u = A u.1 * B u.2.
Proof.
rewrite !fsfunE inE; case: ifPn => //=.
by rewrite negb_and !memNfinsupp => /orP [] /eqP->; rewrite ?muln0.
Qed.

Lemma mset1DE a A b : (a +` A) b = (b == a) + A b.
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Lemma mset1UE a A b : (a |` A) b = maxn (b == a) (A b).
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Lemma msetB1E a A b : (A `\ a) b = (A b) - (b == a).
Proof. by rewrite msetE2 msetnE; case: (b == a). Qed.

Let msetE := (mset0E, msetE2, msetnE, msetnxx,
              mset1DE, mset1UE, msetB1E,
              mset_seqE, msetME).

Lemma in_mset0 a : a \in mset0 = false.
Proof. by rewrite in_mset !msetE. Qed.

Lemma in_msetn n a' a : a \in msetn n a' = (n > 0) && (a == a').
Proof. by rewrite in_mset msetE; case: (a == a'); rewrite ?andbT ?andbF. Qed.

Lemma in_mset1 a' a : a \in [mset a'] = (a == a').
Proof. by rewrite in_msetn. Qed.

Lemma in_msetD A B a : (a \in A `+` B) = (a \in A) || (a \in B).
Proof. by rewrite !in_mset !msetE addn_gt0. Qed.

Lemma in_msetU A B a : (a \in A `|` B) = (a \in A) || (a \in B).
Proof. by rewrite !in_mset !msetE leq_max. Qed.

Lemma in_msetDU A B a : (a \in A `+` B) = (a \in A `|` B).
Proof. by rewrite in_msetU in_msetD. Qed.

Lemma in_msetI A B a : (a \in A `&` B) = (a \in A) && (a \in B).
Proof. by rewrite !in_mset msetE leq_min. Qed.

Lemma in_msetB A B a : (a \in A `\` B) = (B a < A a).
Proof. by rewrite -mset_neq0 msetE subn_eq0 ltnNge. Qed.

Lemma in_mset1U a' A a : (a \in a' |` A) = (a == a') || (a \in A).
Proof. by rewrite in_msetU in_mset msetE; case: (_ == _). Qed.

Lemma in_mset1D a' A a : (a \in a' +` A) = (a == a') || (a \in A).
Proof. by rewrite in_msetDU in_mset1U. Qed.

Lemma in_msetB1 A b a : (a \in A `\ b) = ((a == b) ==> (A a > 1)) && (a \in A).
Proof.
by rewrite in_msetB msetE in_mset; case: (_ == _); rewrite -?geq_max.
Qed.

Lemma in_msetM A B (u : K * K) : (u \in A `*` B) = (u.1 \in A) && (u.2 \in B).
Proof. by rewrite -!msuppE !mem_finsupp msetE muln_eq0 negb_or. Qed.

Definition in_msetE := (in_mset0, in_msetn,
                        in_msetB1, in_msetU, in_msetI, in_msetD, in_msetM).

Let inE := (inE, in_msetE, (@msuppE K)).

Lemma enum_mset0 : mset0 = [::] :> seq K.
Proof. by rewrite unlock finsupp0. Qed.

Lemma msetn0 (a : K) : msetn 0 a = mset0.
Proof. by apply/msetP=> i; rewrite !msetE if_same. Qed.

Lemma finsupp_msetn n a : finsupp (msetn n a) = if n > 0 then [fset a] else fset0.
Proof.  by apply/fsetP => i; rewrite !inE; case: ifP => //=; rewrite inE. Qed.

Lemma enum_msetn n a : msetn n a = nseq n a :> seq K.
Proof.
case: n => [|n]; first by rewrite msetn0 /= enum_mset0.
rewrite unlock finsupp_msetn /= enum_fsetE /= enum_fset1 /= cats0.
by rewrite msetE eqxx.
Qed.

Section big.
Variables (R : Type) (idx : R) (op : Monoid.law idx).
Implicit Types (X : {mset K}) (P : pred K) (F : K -> R).

Lemma big_mset0 P F : \big[op/idx]_(i <- mset0 | P i) F i = idx.
Proof. by rewrite enum_mset0 big_nil. Qed.

Lemma big_msetn n a P F :
   \big[op/idx]_(i <- msetn n a | P i) F i =
   if P a then iterop n op (F a) idx else idx.
Proof. by rewrite enum_msetn big_nseq_cond Monoid.iteropE. Qed.
End big.

Lemma msetDC (A B : {mset K}) : A `+` B = B `+` A.
Proof. by apply/msetP=> a; rewrite !msetE addnC. Qed.

Lemma msetIC (A B : {mset K}) : A `&` B = B `&` A.
Proof. by apply/msetP=> a; rewrite !msetE minnC. Qed.

Lemma msetUC (A B : {mset K}) : A `|` B = B `|` A.
Proof. by apply/msetP => a; rewrite !msetE maxnC. Qed.

(* intersection *)

Lemma mset0I A : mset0 `&` A = mset0.
Proof. by apply/msetP => x; rewrite !msetE min0n. Qed.

Lemma msetI0 A : A `&` mset0 = mset0.
Proof. by rewrite msetIC mset0I. Qed.

Lemma msetIA A B C : A `&` (B `&` C) = A `&` B `&` C.
Proof. by apply/msetP=> x; rewrite !msetE minnA. Qed.

Lemma msetICA A B C : A `&` (B `&` C) = B `&` (A `&` C).
Proof. by rewrite !msetIA (msetIC A). Qed.

Lemma msetIAC A B C : A `&` B `&` C = A `&` C `&` B.
Proof. by rewrite -!msetIA (msetIC B). Qed.

Lemma msetIACA A B C D : (A `&` B) `&` (C `&` D) = (A `&` C) `&` (B `&` D).
Proof. by rewrite -!msetIA (msetICA B). Qed.

Lemma msetIid A : A `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE minnn. Qed.

Lemma msetIIl A B C : A `&` B `&` C = (A `&` C) `&` (B `&` C).
Proof. by rewrite msetIA !(msetIAC _ C) -(msetIA _ C) msetIid. Qed.

Lemma msetIIr A B C : A `&` (B `&` C) = (A `&` B) `&` (A `&` C).
Proof. by rewrite !(msetIC A) msetIIl. Qed.

(* union *)

Lemma mset0U A : mset0 `|` A = A.
Proof. by apply/msetP => x; rewrite !msetE max0n. Qed.

Lemma msetU0 A : A `|` mset0 = A.
Proof. by rewrite msetUC mset0U. Qed.

Lemma msetUA A B C : A `|` (B `|` C) = A `|` B `|` C.
Proof. by apply/msetP=> x; rewrite !msetE maxnA. Qed.

Lemma msetUCA A B C : A `|` (B `|` C) = B `|` (A `|` C).
Proof. by rewrite !msetUA (msetUC B). Qed.

Lemma msetUAC A B C : A `|` B `|` C = A `|` C `|` B.
Proof. by rewrite -!msetUA (msetUC B). Qed.

Lemma msetUACA A B C D : (A `|` B) `|` (C `|` D) = (A `|` C) `|` (B `|` D).
Proof. by rewrite -!msetUA (msetUCA B). Qed.

Lemma msetUid A : A `|` A = A.
Proof. by apply/msetP=> x; rewrite !msetE maxnn. Qed.

Lemma msetUUl A B C : A `|` B `|` C = (A `|` C) `|` (B `|` C).
Proof. by rewrite msetUA !(msetUAC _ C) -(msetUA _ C) msetUid. Qed.

Lemma msetUUr A B C : A `|` (B `|` C) = (A `|` B) `|` (A `|` C).
Proof. by rewrite !(msetUC A) msetUUl. Qed.

(* adjunction *)

Lemma mset0D A : mset0 `+` A = A.
Proof. by apply/msetP => x; rewrite !msetE add0n. Qed.

Lemma msetD0 A : A `+` mset0 = A.
Proof. by rewrite msetDC mset0D. Qed.

Lemma msetDA A B C : A `+` (B `+` C) = A `+` B `+` C.
Proof. by apply/msetP=> x; rewrite !msetE addnA. Qed.

Lemma msetDCA A B C : A `+` (B `+` C) = B `+` (A `+` C).
Proof. by rewrite !msetDA (msetDC B). Qed.

Lemma msetDAC A B C : A `+` B `+` C = A `+` C `+` B.
Proof. by rewrite -!msetDA (msetDC B). Qed.

Lemma msetDACA A B C D : (A `+` B) `+` (C `+` D) = (A `+` C) `+` (B `+` D).
Proof. by rewrite -!msetDA (msetDCA B). Qed.

(* adjunction, union and difference with one element *)

Lemma msetU1l x A B : x \in A -> x \in A `|` B.
Proof. by move=> Ax /=; rewrite inE Ax. Qed.

Lemma msetU1r A b : b \in A `|` [mset b].
Proof. by rewrite !inE eqxx orbT. Qed.

Lemma msetB1P x A b : reflect ((x = b -> A x > 1) /\ x \in A) (x \in A `\ b).
Proof.
rewrite !inE. apply: (iffP andP); first by move=> [/implyP Ax ->]; split => // /eqP.
by move=> [Ax ->]; split => //; apply/implyP => /eqP.
Qed.

Lemma msetB11 b A : (b \in A `\ b) = (A b > 1).
Proof. by rewrite inE eqxx /= in_mset -geq_max. Qed.

Lemma msetB1K a A : a \in A -> a +` (A `\ a) = A.
Proof.
move=> aA; apply/msetP=> x; rewrite !msetE subnKC //=.
by have [->|//] := altP eqP; rewrite mset_gt0.
Qed.

Lemma msetD1K a B : (a +` B) `\ a = B.
Proof. by apply/msetP => x; rewrite !msetE addKn. Qed.

Lemma msetU1K a B : a \notin B -> (a |` B) `\ a = B.
Proof.
move=> aB; apply/msetP=> x; rewrite !msetE.
have [->|] := altP eqP; first by rewrite (mset_eq0P _).
by rewrite max0n subn0.
Qed.

Lemma mset1U1 x B : x \in x |` B. Proof. by rewrite !inE eqxx. Qed.
Lemma mset1D1 x B : x \in x +` B. Proof. by rewrite !inE eqxx. Qed.

Lemma mset1Ur x a B : x \in B -> x \in a |` B.
Proof. by move=> Bx; rewrite !inE predU1r. Qed.
Lemma mset1Dr x a B : x \in B -> x \in a +` B.
Proof. by move=> Bx; rewrite !inE predU1r. Qed.

Lemma mset2P x a b : reflect (x = a \/ x = b) (x \in [mset a; b]).
Proof. by rewrite !inE; apply: (iffP orP) => [] [] /eqP; intuition. Qed.

Lemma in_mset2 x a b : (x \in [mset a; b]) = (x == a) || (x == b).
Proof. by rewrite !inE. Qed.

Lemma mset21 a b : a \in [mset a; b]. Proof. by rewrite mset1D1. Qed.

Lemma mset22 a b : b \in [mset a; b]. Proof. by rewrite in_mset2 eqxx orbT. Qed.

Lemma msetUP x A B : reflect (x \in A \/ x \in B) (x \in A `|` B).
Proof. by rewrite !inE; exact: orP. Qed.

Lemma msetDP x A B : reflect (x \in A \/ x \in B) (x \in A `+` B).
Proof. by rewrite !inE; exact: orP. Qed.

Lemma msetULVR x A B : x \in A `|` B -> (x \in A) + (x \in B).
Proof. by rewrite inE; case: (x \in A); [left|right]. Qed.

Lemma msetDLVR x A B : x \in A `+` B -> (x \in A) + (x \in B).
Proof. by rewrite inE; case: (x \in A); [left|right]. Qed.

(* distribute /cancel *)

Lemma msetIUr A B C : A `&` (B `|` C) = (A `&` B) `|` (A `&` C).
Proof. by apply/msetP=> x; rewrite !msetE minn_maxr. Qed.

Lemma msetIUl A B C : (A `|` B) `&` C = (A `&` C) `|` (B `&` C).
Proof. by apply/msetP=> x; rewrite !msetE minn_maxl. Qed.

Lemma msetUIr A B C : A `|` (B `&` C) = (A `|` B) `&` (A `|` C).
Proof. by apply/msetP=> x; rewrite !msetE maxn_minr. Qed.

Lemma msetUIl A B C : (A `&` B) `|` C = (A `|` C) `&` (B `|` C).
Proof. by apply/msetP=> x; rewrite !msetE maxn_minl. Qed.

Lemma msetUKC A B : (A `|` B) `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE maxnK. Qed.

Lemma msetUK A B : (B `|` A) `&` A = A.
Proof. by rewrite msetUC msetUKC. Qed.

Lemma msetKUC A B : A `&` (B `|` A) = A.
Proof. by rewrite msetIC msetUK. Qed.

Lemma msetKU A B : A `&` (A `|` B) = A.
Proof. by rewrite msetIC msetUKC. Qed.

Lemma msetIKC A B : (A `&` B) `|` A = A.
Proof. by apply/msetP=> x; rewrite !msetE minnK. Qed.

Lemma msetIK A B : (B `&` A) `|` A = A.
Proof. by rewrite msetIC msetIKC. Qed.

Lemma msetKIC A B : A `|` (B `&` A) = A.
Proof. by rewrite msetUC msetIK. Qed.

Lemma msetKI A B : A `|` (A `&` B) = A.
Proof. by rewrite msetIC msetKIC. Qed.

Lemma msetUKid A B : B `|` A `|` A = B `|` A.
Proof. by rewrite -msetUA msetUid. Qed.

Lemma msetUKidC A B : A `|` B `|` A = A `|` B.
Proof. by rewrite msetUAC msetUid. Qed.

Lemma msetKUid A B : A `|` (A `|` B) = A `|` B.
Proof. by rewrite msetUA msetUid. Qed.

Lemma msetKUidC A B : A `|` (B `|` A) = B `|` A.
Proof. by rewrite msetUCA msetUid. Qed.

Lemma msetIKid A B : B `&` A `&` A = B `&` A.
Proof. by rewrite -msetIA msetIid. Qed.

Lemma msetIKidC A B : A `&` B `&` A = A `&` B.
Proof. by rewrite msetIAC msetIid. Qed.

Lemma msetKIid A B : A `&` (A `&` B) = A `&` B.
Proof. by rewrite msetIA msetIid. Qed.

Lemma msetKIidC A B : A `&` (B `&` A) = B `&` A.
Proof. by rewrite msetICA msetIid. Qed.

Lemma msetDIr A B C : A `+` (B `&` C) = (A `+` B) `&` (A `+` C).
Proof. by apply/msetP=> x; rewrite !msetE addn_minr. Qed.

Lemma msetDIl A B C : (A `&` B) `+` C = (A `+` C) `&` (B `+` C).
Proof. by apply/msetP=> x; rewrite !msetE addn_minl. Qed.

Lemma msetDKIC A B : (A `+` B) `&` A = A.
Proof. by apply/msetP=> x; rewrite !msetE (minn_idPr _) // leq_addr. Qed.

Lemma msetDKI A B : (B `+` A) `&` A = A.
Proof. by rewrite msetDC msetDKIC. Qed.

Lemma msetKDIC A B : A `&` (B `+` A) = A.
Proof. by rewrite msetIC msetDKI. Qed.

Lemma msetKDI A B : A `&` (A `+` B) = A.
Proof. by rewrite msetDC msetKDIC. Qed.

(* adjunction / subtraction *)

Lemma msetDKB A : cancel (msetD A) (msetB^~ A).
Proof. by move=> B; apply/msetP => a; rewrite !msetE addKn. Qed.

Lemma msetDKBC A : cancel (msetD^~ A) (msetB^~ A).
Proof. by move=> B; rewrite msetDC msetDKB. Qed.

Lemma msetBSKl A B a : ((a +` A) `\` B) `\ a = A `\` B.
Proof.
apply/msetP=> b; rewrite !msetE; case: ifPn; rewrite ?add0n ?subn0 //.
by rewrite add1n subn1 subSKn.
Qed.

Lemma msetBDl C A B : (C `+` A) `\` (C `+` B) = A `\` B.
Proof. by apply/msetP=> a; rewrite !msetE subnDl. Qed.

Lemma msetBDr C A B : (A `+` C) `\` (B `+` C) = A `\` B.
Proof. by apply/msetP=> a; rewrite !msetE subnDr. Qed.

Lemma msetBDA A B C : B `\` (A `+` C) = B `\` A `\` C.
Proof. by apply/msetP=> a; rewrite !msetE subnDA. Qed.

Lemma msetUE A B C : msetU A B = A `+` (B `\` A).
Proof. by apply/msetP=> a; rewrite !msetE maxnE. Qed.

(* subset *)

Lemma msubsetP {A B} : reflect (forall x, A x <= B x) (A `<=` B).
Proof.
apply: (iffP forallP)=> // ? x; case: (in_fsetP (finsupp A) x) => //.
by rewrite msuppE => /mset_eq0P->.
Qed.

Lemma msubset_subset {A B} : A `<=` B -> {subset A <= B}.
Proof.
by move=> /msubsetP AB x; rewrite !in_mset => ?; exact: (leq_trans _ (AB _)).
Qed.

Lemma msetB_eq0 (A B : {mset K}) : (A `\` B == mset0) = (A `<=` B).
Proof.
apply/mset_eqP/msubsetP => AB a;
by have := AB a; rewrite !msetE -subn_eq0 => /eqP.
Qed.

Lemma msubset_refl A : A `<=` A. Proof. exact/msubsetP. Qed.
Hint Resolve msubset_refl : core.

Lemma msubset_trans : transitive (@msubset K).
Proof.
move=> y x z /msubsetP xy /msubsetP yz ; apply/msubsetP => a.
by apply: (leq_trans (xy _)).
Qed.
Arguments msubset_trans {C A B} _ _ : rename.

Lemma msetUS C A B : A `<=` B -> C `|` A `<=` C `|` B.
Proof.
move=> sAB; apply/msubsetP=> x; rewrite !msetE.
by rewrite geq_max !leq_max leqnn (msubsetP sAB) orbT.
Qed.

Lemma msetDS C A B : A `<=` B -> C `+` A `<=` C `+` B.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_add2l.
Qed.

Lemma msetSU C A B : A `<=` B -> A `|` C `<=` B `|` C.
Proof. by move=> sAB; rewrite -!(msetUC C) msetUS. Qed.

Lemma msetSD C A B : A `<=` B -> A `+` C `<=` B `+` C.
Proof. by move=> sAB; rewrite -!(msetDC C) msetDS. Qed.

Lemma msetUSS A B C D : A `<=` C -> B `<=` D -> A `|` B `<=` C `|` D.
Proof. by move=> /(msetSU B) /msubset_trans sAC /(msetUS C)/sAC. Qed.

Lemma msetDSS A B C D : A `<=` C -> B `<=` D -> A `+` B `<=` C `+` D.
Proof. by move=> /(msetSD B) /msubset_trans sAC /(msetDS C)/sAC. Qed.

Lemma msetIidPl {A B} : reflect (A `&` B = A) (A `<=` B).
Proof.
apply: (iffP msubsetP) => [?|<- a]; last by rewrite !msetE geq_min leqnn orbT.
by apply/msetP => a; rewrite !msetE (minn_idPl _).
Qed.

Lemma msetIidPr {A B} : reflect (A `&` B = B) (B `<=` A).
Proof. by rewrite msetIC; apply: msetIidPl. Qed.

Lemma msubsetIidl A B : (A `<=` A `&` B) = (A `<=` B).
Proof.
apply/msubsetP/msubsetP=> sAB a; have := sAB a; rewrite !msetE.
  by rewrite leq_min leqnn.
by move/minn_idPl->.
Qed.

Lemma msubsetIidr A B : (B `<=` A `&` B) = (B `<=` A).
Proof. by rewrite msetIC msubsetIidl. Qed.

Lemma msetUidPr A B : reflect (A `|` B = B) (A `<=` B).
Proof.
apply: (iffP msubsetP) => [AB|<- a]; last by rewrite !msetE leq_max leqnn.
by apply/msetP=> a; rewrite !msetE (maxn_idPr _).
Qed.

Lemma msetUidPl A B : reflect (A `|` B = A) (B `<=` A).
Proof. by rewrite msetUC; apply/msetUidPr. Qed.

Lemma msubsetUl A B : A `<=` A `|` B.
Proof. by apply/msubsetP=> a; rewrite !msetE leq_maxl. Qed.
Hint Resolve msubsetUl : core.

Lemma msubsetUr A B : B `<=` (A `|` B).
Proof. by rewrite msetUC. Qed.
Hint Resolve msubsetUr : core.

Lemma msubsetU1 x A : A `<=` (x |` A).
Proof. by rewrite msubsetUr. Qed.
Hint Resolve msubsetU1 : core.

Lemma msubsetU A B C : (A `<=` B) || (A `<=` C) -> A `<=` (B `|` C).
Proof. by move=> /orP [] /msubset_trans ->. Qed.

Lemma eqEmsubset A B : (A == B) = (A `<=` B) && (B `<=` A).
Proof.
apply/eqP/andP => [<-|[/msubsetP AB /msubsetP BA]]; first by split.
by apply/msetP=> a; apply/eqP; rewrite eqn_leq AB BA.
Qed.

Lemma msubEproper A B : A `<=` B = (A == B) || (A `<` B).
Proof. by rewrite eqEmsubset -andb_orr orbN andbT. Qed.

Lemma mproper_sub A B : A `<` B -> A `<=` B.
Proof. by rewrite msubEproper orbC => ->. Qed.

Lemma eqVmproper A B : A `<=` B -> A = B \/ A `<` B.
Proof. by rewrite msubEproper => /predU1P. Qed.

Lemma mproperEneq A B : A `<` B = (A != B) && (A `<=` B).
Proof. by rewrite andbC eqEmsubset negb_and andb_orr andbN. Qed.

Lemma mproper_neq A B : A `<` B -> A != B.
Proof. by rewrite mproperEneq; case/andP. Qed.

Lemma eqEmproper A B : (A == B) = (A `<=` B) && ~~ (A `<` B).
Proof. by rewrite negb_and negbK andb_orr andbN eqEmsubset. Qed.

Lemma msub0set A : msubset mset0 A.
Proof. by apply/msubsetP=> x; rewrite msetE. Qed.
Hint Resolve msub0set : core.

Lemma msubset0 A : (A `<=` mset0) = (A == mset0).
Proof. by rewrite eqEmsubset msub0set andbT. Qed.

Lemma mproper0 A : (mproper mset0 A) = (A != mset0).
Proof. by rewrite /mproper msub0set msubset0. Qed.

Lemma mproperE A B : (A `<` B) = (A `<=` B) && ~~ (msubset B A).
Proof. by []. Qed.

Lemma mproper_sub_trans B A C : A `<` B -> B `<=` C -> A `<` C.
Proof.
move=> /andP [AB NBA] BC; rewrite /mproper (msubset_trans AB) //=.
by apply: contra NBA=> /(msubset_trans _)->.
Qed.

Lemma msub_proper_trans B A C :
  A `<=` B -> B `<` C -> A `<` C.
Proof.
move=> AB /andP [CB NCB]; rewrite /mproper (msubset_trans AB) //=.
by apply: contra NCB=> /msubset_trans->.
Qed.

Lemma msubset_neq0 A B : A `<=` B -> A != mset0 -> B != mset0.
Proof. by rewrite -!mproper0 => sAB /mproper_sub_trans->. Qed.

(* msub is a morphism *)

Lemma msetBDKC A B : A `<=` B -> A `+` (B `\` A) = B.
Proof. by move=> /msubsetP AB; apply/msetP=> a; rewrite !msetE subnKC. Qed.

Lemma msetBDK A B : A `<=` B -> B `\` A `+` A = B.
Proof. by move=> /msubsetP AB; apply/msetP => a; rewrite !msetE subnK. Qed.

Lemma msetBBK A B : A `<=` B -> B `\` (B `\` A) = A.
Proof. by move=> /msubsetP AB; apply/msetP => a; rewrite !msetE subKn. Qed.

Lemma msetBD1K A B a : A `<=` B -> A a < B a -> a +` (B `\` (a +` A)) = B `\` A.
Proof.
move=> /msubsetP AB ABa; apply/msetP => b; rewrite !msetE.
by case: ifP => //= /eqP->; rewrite !add1n subnSK.
Qed.

Lemma subset_msetBLR A B C : (msubset (A `\` B) C) = (A `<=` B `+` C).
Proof.
apply/msubsetP/msubsetP => [] sABC a;
by have := sABC a; rewrite !msetE ?leq_subLR.
Qed.

Lemma msetnP n x a : reflect (0 < n /\ x = a) (x \in msetn n a).
Proof. by do [apply: (iffP idP); rewrite !inE] => [/andP[]|[]] -> /eqP. Qed.

Lemma gt0_msetnP n x a : 0 < n -> reflect (x = a) (x \in msetn n a).
Proof. by move=> n_gt0; rewrite inE n_gt0 /=; exact: eqP. Qed.

Lemma msetn1 n a : a \in msetn n a = (n > 0).
Proof. by rewrite inE eqxx andbT. Qed.

Lemma mset1P x a : reflect (x = a) (x \in [mset a]).
Proof. by rewrite inE; exact: eqP. Qed.

Lemma mset11 a : a \in [mset a]. Proof. by rewrite inE /=. Qed.

Lemma msetn_inj n : n > 0 -> injective (@msetn K n).
Proof.
move=> n_gt0 a b eqsab; apply/(gt0_msetnP _ _ n_gt0).
by rewrite -eqsab inE n_gt0 eqxx.
Qed.

Lemma mset1UP x a B : reflect (x = a \/ x \in B) (x \in a |` B).
Proof. by rewrite !inE; exact: predU1P. Qed.

Lemma mset_cons a s : seq_mset (a :: s) = a +` (seq_mset s).
Proof. by apply/msetP=> x; rewrite !msetE /= eq_sym. Qed.

(* intersection *)

Lemma msetIP x A B : reflect (x \in A /\ x \in B) (x \in A `&` B).
Proof. by rewrite inE; apply: andP. Qed.

Lemma msetIS C A B : A `<=` B -> C `&` A `<=` C `&` B.
Proof.
move=> sAB; apply/msubsetP=> x; rewrite !msetE.
by rewrite leq_min !geq_min leqnn (msubsetP sAB) orbT.
Qed.

Lemma msetSI C A B : A `<=` B -> A `&` C `<=` B `&` C.
Proof. by move=> sAB; rewrite -!(msetIC C) msetIS. Qed.

Lemma msetISS A B C D : A `<=` C -> B `<=` D -> A `&` B `<=` C `&` D.
Proof. by move=> /(msetSI B) /msubset_trans sAC /(msetIS C) /sAC. Qed.

(* difference *)

Lemma msetSB C A B : A `<=` B -> A `\` C `<=` B `\` C.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_sub2r.
Qed.

Lemma msetBS C A B : A `<=` B -> C `\` B `<=` C `\` A.
Proof.
by move=> /msubsetP sAB; apply/msubsetP=> x; rewrite !msetE leq_sub2l.
Qed.

Lemma msetBSS A B C D : A `<=` C -> D `<=` B -> A `\` B `<=` C `\` D.
Proof. by move=> /(msetSB B) /msubset_trans sAC /(msetBS C) /sAC. Qed.

Lemma msetB0 A : A `\` mset0 = A.
Proof. by apply/msetP=> x; rewrite !msetE subn0. Qed.

Lemma mset0B A : mset0 `\` A = mset0.
Proof. by apply/msetP=> x; rewrite !msetE sub0n. Qed.

Lemma msetBxx A : A `\` A = mset0.
Proof. by apply/msetP=> x; rewrite !msetE subnn. Qed.

(* other inclusions *)

Lemma msubsetIl A B : A `&` B `<=` A.
Proof. by apply/msubsetP=> x; rewrite msetE geq_minl. Qed.

Lemma msubsetIr A B : A `&` B `<=` B.
Proof. by apply/msubsetP=> x; rewrite msetE geq_minr. Qed.

Lemma msubsetDl A B : A `\` B `<=` A.
Proof. by apply/msubsetP=> x; rewrite msetE leq_subLR leq_addl. Qed.

Lemma msubD1set A x : A `\ x `<=` A.
Proof. by rewrite msubsetDl. Qed.

Hint Resolve msubsetIl msubsetIr msubsetDl msubD1set : core.

(* cardinal lemmas for msets *)

Lemma mem_mset1U a A : a \in A -> a |` A = A.
Proof.
rewrite in_mset => aA; apply/msetP => x; rewrite !msetE (maxn_idPr _) //.
by have [->|//] := altP eqP; rewrite (leq_trans _ aA).
Qed.

Lemma mem_msetD1 a A : a \notin A -> A `\ a = A.
Proof.
move=> /mset_eq0P aA; apply/msetP => x; rewrite !msetE.
by have [->|] := altP eqP; rewrite ?aA ?subn0.
Qed.

Lemma msetIn a A n : A `&` msetn n a = msetn (minn (A a) n) a.
Proof.
by apply/msetP => x; rewrite !msetE; have [->|] := altP eqP; rewrite ?minn0.
Qed.

Lemma msubIset A B C : (B `<=` A) || (C `<=` A) -> (B `&` C `<=` A).
Proof. by case/orP; apply: msubset_trans; rewrite (msubsetIl, msubsetIr). Qed.

Lemma msubsetI A B C : (A `<=` B `&` C) = (A `<=` B) && (A `<=` C).
Proof.
rewrite !(sameP msetIidPl eqP) msetIA; have [-> //| ] := altP (A `&` B =P A).
by apply: contraNF => /eqP <-; rewrite -msetIA -msetIIl msetIAC.
Qed.

Lemma msubsetIP A B C : reflect (A `<=` B /\ A `<=` C) (A `<=` B `&` C).
Proof. by rewrite msubsetI; exact: andP. Qed.

Lemma msubUset A B C : (B `|` C `<=` A) = (B `<=` A) && (C `<=` A).
Proof.
apply/idP/idP => [subA|/andP [AB CA]]; last by rewrite -[A]msetUid msetUSS.
by rewrite !(msubset_trans _ subA).
Qed.

Lemma msubUsetP A B C : reflect (A `<=` C /\ B `<=` C) (A `|` B `<=` C).
Proof. by rewrite msubUset; exact: andP. Qed.

Lemma msetU_eq0 A B : (A `|` B == mset0) = (A == mset0) && (B == mset0).
Proof. by rewrite -!msubset0 msubUset. Qed.

Lemma setD_eq0 A B : (A `\` B == mset0) = (A `<=` B).
Proof. by rewrite -msubset0 subset_msetBLR msetD0. Qed.

Lemma msub1set A a : ([mset a] `<=` A) = (a \in A).
Proof.
apply/msubsetP/idP; first by move/(_ a); rewrite msetnxx in_mset.
by move=> ainA b; rewrite msetnE; case: eqP => // ->; rewrite -in_mset.
Qed.

Lemma msetDBA A B C : C `<=` B -> A `+` B `\` C = (A `+` B) `\` C.
Proof.
by move=> /msubsetP CB; apply/msetP=> a; rewrite !msetE2 addnBA.
Qed.

Lemma mset_0Vmem A : (A = mset0) + {x : K | x \in A}.
Proof.
have [/fsetP Aisfset0 | [a ainA]] := fset_0Vmem (finsupp A); last first.
  by right; exists a; rewrite -msuppE.
left; apply/msetP => a; rewrite mset0E; apply/mset_eq0P.
by rewrite -msuppE Aisfset0 inE.
Qed.

Definition size_mset A : size A = \sum_(a <- finsupp A) A a.
Proof. by rewrite -sum1_size sum_mset; apply: eq_bigr => i; rewrite muln1. Qed.

Lemma size_mset0 : size (mset0 : {mset K}) = 0.
Proof. by rewrite -sum1_size big_mset0. Qed.

Lemma sum_nat_seq_eq0 (I : eqType) r (P : pred I) (E : I -> nat) :
   (\sum_(i <- r | P i) E i == 0) = all [pred i | P i ==> (E i == 0)] r.
Proof.
rewrite big_tnth sum_nat_eq0; apply/forallP/allP => /= HE x.
  by move=> /seq_tnthP[i ->]; apply: HE.
by apply: HE; rewrite mem_tnth.
Qed.

Lemma size_mset_eq0 A : (size A == 0) = (A == mset0).
Proof.
apply/idP/eqP => [|->]; last by rewrite size_mset0.
rewrite size_mset sum_nat_seq_eq0 => /allP AP.
apply/msetP => a /=; rewrite msetE.
by have /= := AP a; case: finsuppP => // _ /(_ _)/eqP->.
Qed.

End MSetTheory.


(* * Base Library for ICL

   - Version: 3 October 2016
   - Author: Gert Smolka, Saarland University
   - Acknowlegments: Sigurd Schneider, Dominik Kirst, Yannick Forster, Fabian Kunze, Maximilian Wuttke
 *)

Require Export Bool Omega Lia List Setoid Morphisms.
From Undecidability.Shared.Libs.PSL Require Export Tactics.

Global Set Implicit Arguments.
Global Unset Strict Implicit.
Global Unset Printing Records.
Global Unset Printing Implicit Defensive.
Global Set Regular Subst Tactic.

Hint Extern 4 => exact _ : core.  (* makes auto use type class inference *)

(* De Morgan laws *)

Lemma DM_or (X Y : Prop) :
  ~ (X \/ Y) <-> ~ X /\ ~ Y.
Proof.
  tauto.
Qed.

Lemma DM_exists X (p : X -> Prop) :
  ~ (exists x, p x) <-> forall x, ~ p x.
Proof.
  firstorder.
Qed.

(* ** Boolean propositions and decisions *)

Coercion is_true : bool >-> Sortclass.

Lemma bool_Prop_true b :
  b = true -> b.
Proof.
  intros A. rewrite A. reflexivity.
Qed.

Lemma bool_Prop_false b :
  b = false -> ~ b.
Proof.
  intros A. rewrite A. cbn. intros H. congruence.
Qed.

Lemma bool_Prop_true' (b : bool) :
  b -> b = true.
Proof.
  intros A. cbv in A. destruct b; tauto.
Qed.

Lemma bool_Prop_false' (b : bool) :
  ~ b -> b = false.
Proof.
  intros A. cbv in A. destruct b; tauto.
Qed.

Hint Resolve bool_Prop_true bool_Prop_false : core.
Hint Resolve bool_Prop_true' bool_Prop_false' : core.

Definition bool2nat := fun b : bool => if b then 1 else 0.
Definition nat2bool := fun n : nat => match n with 0 => false | _ => true end.
(* Coercion nat2bool : nat >-> bool. *)
Lemma bool_nat (b : bool) :
  1 = bool2nat b -> b.
Proof. intros; cbv in *. destruct b. auto. congruence. Qed.
Lemma nat_bool (b : bool) :
  b = nat2bool 1 -> b.
Proof. intros; cbv in *. destruct b. auto. congruence. Qed.
Hint Resolve bool_nat nat_bool : core.

Ltac simpl_coerce :=
  match goal with
  | [ H: False |- _ ] => destruct H
  | [ H: ~ is_true true |- _ ] => destruct H; congruence
  | [ H: is_true false |- _ ] => congruence
  end.

Ltac simpl_congruence :=
  match goal with
  | [ H : 0 = S _ |- _] => congruence
  | [ H : S _ = 0 |- _] => congruence
  | [ H : S _ = 0 |- _] => congruence
  | [ H : true = false |- _] => congruence
  | [ H : false = true |- _] => congruence
  end.

Hint Extern 1 => simpl_coerce : core.
Hint Extern 1 => simpl_congruence : core.


(** kat: Kleene algebra with tests *)

(** We define here the class of Kleene algebra with tests, as a two
   sorted structure *)

Require Export kleene.
Set Implicit Arguments.

(** * KAT operations *)

(** A Kleene algebra with tests is composed of a Kleene algebra
   ([kar], i.e., [(X,dot,pls,one,zer,str)]), a Boolean algebra of
   tests ([tst], i.e., [(T,cap,cup,top,bot,neg)]), and an injection
   from tests to Kleene elements.

   Since we work with typed structures, the Kleene algebra is a
   category, and we actually have a family of Boolean algebras, for
   each square homset ([X n n]). *)
Class ops := mk_ops {
  kar: monoid.ops;
  tst: ob kar -> lattice.ops;
  inj: forall {n}, tst n -> kar n n
}.
Coercion kar: ops >-> monoid.ops.
(** we use [[p]] to denote the injection of the test [p] into the Kleene algebra *)
Notation " [ p ] " := (inj p): ra_terms.

(* -- failed attempts to declare [inj] as a coercion -- *)
(* SubClass car' {X} n := @car (@tst X n). *)
(* SubClass car'' {X} n := @car (@mor (@kar X) n n). *)
(* Definition inj' X n: @car' X n -> @car'' X n := @inj X n. *)
(* Coercion inj' : car' >-> car''. *)
(* Print Coercion Paths car' car. *)
(* Goal forall `{X: ops} n m (a: X n m) (p: tst n) (q: tst m), p⋅a*q ≡ a. *)

(** * KAT laws  *)

(** The Kleene algebra should be a Kleene algebra (with bottom
   element), the Boolean algebras should be a Boolean lattice, and the
   injection should be a morphism of idempotent semirings, i.e, map
   [(leq,weq,cap,cup,top,bot)] into [(leq,weq,dot,pls,one,zer)] *)

(* TOTHINK: voir si on laisse les deux instances :>,
   qui ne sont utiles que dans l'abstrait si les structures
   concrètes sont déclarées incrémentalement
   voir aussi s'il ne vaut pas mieux poser ces deux instances en
   paramètres phantomes.
   TODO: inliner [morphism]?
   TODO: relacher les contraintes sur les niveaux
*)
Class laws (X: ops) := {
  kar_BKA:> monoid.laws BKA kar;
  tst_BL:> forall n, lattice.laws BL (tst n);
  mor_inj: forall n, morphism BSL (@inj X n);
  inj_top: forall n, [top] ≡ one n;
  inj_cap: forall n (p q: tst n), [p ⊓ q] ≡ [p] ⋅ [q]
}.

(** * Basic properties of KAT  *)

Section s.
Context `{L: laws}.
Variable n: ob X.

Global Instance inj_leq: Proper (leq ==> leq) (@inj X n).
Proof. apply mor_inj. Qed.

Global Instance inj_weq: Proper (weq ==> weq) (@inj X n).
Proof. apply mor_inj. Qed.

Lemma inj_bot: [bot] ≡ zer n n.
Proof. now apply mor_inj. Qed.

Lemma inj_cup (p q: tst n): [p ⊔ q] ≡ [p] + [q].
Proof. now apply mor_inj. Qed.

Lemma str_inj (p: tst n): [p]^* ≡ 1.
Proof. apply antisym. now rewrite leq_xt, inj_top, str1. apply str_refl. Qed.

End s.

(** * dual KAT, for duality reasoning *)

Definition dual (X: ops) := {|
  kar := dual kar;
  tst := tst;
  inj := @inj X |}.

Lemma dual_laws X (L: laws X): laws (dual X).
Proof.
  constructor; try apply L.
  apply dual_laws, kar_BKA.
  intros. simpl in *.
  rewrite capC. apply inj_cap.
Qed.

Lemma dualize {P: ops -> Prop} (L: forall X, laws X -> P X) {X} {H: laws X}: P (dual X).
Proof. eapply L. now apply dual_laws. Qed.

Ltac dual x := apply (dualize x).


Require Import VST.floyd.proofauto.
Require Import VSTlibtest.testmath.
Require Import VSTlib.spec_math.
Require Import vcfloat.FPCompCert.
#[export] Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition f_model (t: ftype Tdouble) : ftype Tdouble :=
  let x := ff_func MF.cos t in
  let y := ff_func MF.sin t in
  (x*x+y*y)%F64.

Definition f_spec :=
 DECLARE _f
  WITH t: float
  PRE [ tdouble ]
         PROP  ()
         PARAMS (Vfloat t)
         SEP   ()
  POST [ tdouble ]
         PROP ()
         RETURN (Vfloat (f_model t))
         SEP ().

Definition Gprog := spec_math.MathASI.

Lemma body_f: semax_body Vprog Gprog f_f f_spec.
Proof.
start_function.
forward_call.
forward_call.
forward.
Qed.

Require Import Reals.

Import Binary.

Definition ROUND {NAN: Nans} (t: type) (r: R) : R :=
   (Generic_fmt.round Zaux.radix2
                (SpecFloat.fexp (fprec t) (femax t))
                (BinarySingleNaN.round_mode BinarySingleNaN.mode_NE)
                r).

Lemma BMULT_correct {NAN: Nans} {t} (x y: ftype t) :
  let prec := fprec t in let emax := femax t in
  if Raux.Rlt_bool
         (Rabs (ROUND t (FT2R x * FT2R y)))
         (Raux.bpow Zaux.radix2 emax)
       then
        FT2R (BMULT t x y) = ROUND t (FT2R x * FT2R y) /\
        is_finite _ _ (BMULT t x y) = andb (is_finite _ _ x) (is_finite _ _ y) /\
        (is_nan _ _ (BMULT t x y) = false ->
         Bsign _ _ (BMULT t x y) = xorb (Bsign _ _ x) (Bsign _ _ y))
       else
        B2FF _ _ (BMULT t x y) =
        binary_overflow prec emax BinarySingleNaN.mode_NE
                    (xorb (Bsign _ _ x) (Bsign _ _ y)).
Proof.
intros.
apply Bmult_correct.
Qed.

Lemma BPLUS_correct {NAN: Nans} {t} (x y: ftype t) :
  let prec := fprec t in let emax := femax t in
  is_finite _ _ x = true ->
  is_finite _ _ y = true ->
  if   Raux.Rlt_bool (Rabs (ROUND t (FT2R x + FT2R y)))
          (Raux.bpow Zaux.radix2 emax)
  then FT2R (BPLUS t x y) = ROUND t (FT2R x + FT2R y)%R /\
        is_finite _ _ (BPLUS t x y) = true /\
        Bsign _ _ (BPLUS t x y) = match
                    Raux.Rcompare (FT2R x + FT2R y)%R 0
                  with
                  | Eq => (Bsign prec emax x &&
                                 Bsign prec emax y)%bool
                  | Lt => true
                  | Gt => false
                  end
       else B2FF _ _  (BPLUS t x y) =
                 binary_overflow prec emax BinarySingleNaN.mode_NE  (Bsign _ _ x) /\
              Bsign _ _ x = Bsign _ _ y.
Proof.
intros.
apply Bplus_correct; auto.
Qed.

Definition type_hibound (t: type) :=
  (Raux.bpow Zaux.radix2 (femax t) - Raux.bpow Zaux.radix2 (femax t - fprec t))%R.

Lemma ROUND_error: forall {NAN: Nans} t (x: R),
  (exists delta : R, exists epsilon : R,
    Rabs delta <= default_rel t /\
    Rabs epsilon <= default_abs t /\
   ROUND t x = x * (1+delta) + epsilon)%R.
Proof.
intros.
apply generic_round_property.
Qed.

Require Import Interval.Tactic.

Definition ulp (t: type) := (2 * default_rel t)%R.

(*  This is a clumsy and tedious proof.  It would be better to
  automate this in VCFloat . . . *)
Lemma f_model_accurate: forall t,
  Binary.is_finite (fprec Tdouble) (femax Tdouble) t = true ->
   is_finite _ _ (f_model t) = true /\
  (1 - 10*ulp Tdouble <= FT2R (f_model t) <= 1 + 10 * ulp Tdouble)%R.
Proof.
intros.
unfold f_model.
destruct (ff_acc MF.cos t H I) as [FINx [dx [ex [? [? Hx]]]]].
pose proof (ff_acc MF.sin t H I) as [FINy [dy [ey [? [? Hy]]]]].
forget (ff_func MF.cos t) as x.
forget (ff_func MF.sin t) as y.
change (ftype Tdouble) in x,y.
rename t into t'. forget (FT2R t') as t.
clear t' H.
simpl in *.
pose proof (sin2_cos2 t).
pose proof (COS_bound t).
pose proof (SIN_bound t).
forget (sin t) as s.
forget (cos t) as c.
rewrite !Rsqr_pow2 in H.

assert (Mxx := BMULT_correct x x).
cbv zeta in Mxx.
rewrite Raux.Rlt_bool_true in Mxx.
2:{
rewrite Hx.
match goal with |- context [ROUND ?t ?x] =>
  destruct (ROUND_error t x) as [dr [er [? [? Hxx]]]]
end.
rewrite Hxx; interval.
}
destruct Mxx as [Mxx [FINxx _]].
simpl in FINxx; rewrite FINx in FINxx; simpl in FINxx.

assert (Myy := BMULT_correct y y).
cbv zeta in Myy.
rewrite Raux.Rlt_bool_true in Myy.
2:{
rewrite Hy.
match goal with |- context [ROUND ?t ?x] =>
  destruct (ROUND_error t x) as [dr [er [? [? Hyy]]]]
end.
rewrite Hyy; interval.
}
destruct Myy as [Myy [FINyy _]].
simpl in FINyy; rewrite FINy in FINyy; simpl in FINyy.

rewrite Hx, Hy in *. clear Hx Hy.
pose proof (BPLUS_correct (BMULT Tdouble x x) (BMULT Tdouble y y) FINxx FINyy).
rewrite Raux.Rlt_bool_true in H6.
2:{
rewrite Mxx, Myy.
clear - H0 H1 H2 H3 H4 H5.
match goal with |- context [ROUND ?t (?x * _)] =>
  destruct (ROUND_error t (x*x)) as [dr [er [? [? ?]]]]
end.
rewrite H7; clear H7.
match goal with |- context [ROUND ?t (?x * _)] =>
  destruct (ROUND_error t (x*x)) as [dr' [er' [? [? ?]]]]
end.
 rewrite H9; clear H9.
match goal with |- context [ROUND ?t ?x] =>
  destruct (ROUND_error t x) as [dr'' [er'' [? [? ?]]]]
end.
rewrite H11. clear H11.
unfold default_rel, default_abs in *; simpl in *.
interval.
}
destruct H6 as [? [? _]].
split; auto.
rewrite H6.
rewrite Mxx, Myy.
clear H6 Mxx Myy.
match goal with |- context [ROUND ?t (?x * _)] =>
  destruct (ROUND_error t (x*x)) as [dr [er [? [? ?]]]]
end.
rewrite H9; clear H9.
match goal with |- context [ROUND ?t (?x * _)] =>
  destruct (ROUND_error t (x*x)) as [dr' [er' [? [? ?]]]]
end.
rewrite H11; clear H11.
match goal with |- context [ROUND ?t ?x] =>
  destruct (ROUND_error t x) as [dr'' [er'' [? [? ?]]]]
end.
rewrite H13; clear H13.
simpl in *.
unfold ulp, default_rel, default_abs in *; simpl in *.
clear FINx FINy FINxx FINyy H7.
match goal with |- (_ <= ?A <= _)%R =>
 replace A with (A + (1 -  (((s * (s * 1) + c * (c * 1))))))%R
  by (rewrite H; Lra.lra)
end.
clear H.
match goal with |- (_ <= ?A <= _)%R =>
  field_simplify A
end.
interval.
Qed.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import Coq.Strings.String Coq.ZArith.ZArith Coq.Lists.List Coq.Logic.FunctionalExtensionality Coq.Sets.Ensembles
        Computation ADT ADTRefinement ADTNotation BuildADTRefinements
        KVEnsembles.

Open Scope string_scope.

Section CacheADT.

  Variable Key : Type.
  Variable Value : Type.

  Definition CacheSig : ADTSig :=
    ADTsignature {
        "EmptyCache"  : unit → rep,
        "AddKey" : rep × (Key * Value) → rep × bool,
        "UpdateKey" : rep × (Key * (Value -> Value)) → rep × bool,
        "LookupKey"   : rep × Key → rep × (option Value)
  }.

  Definition CacheSpec : ADT CacheSig :=
    ADTRep (Ensemble (Key * Value)) {
        const "EmptyCache" (_ : unit) : rep :=
          ret (fun _ => False),
        meth "AddKey" (r : rep, kv : Key * Value) : bool :=
            { r' | (SubEnsembleInsert kv r (fst r')) /\
                   ((usedKey r (fst kv) /\ snd r' = false) \/
                    (~ usedKey r (fst kv) /\ snd r' = true))},
        meth "UpdateKey" (r : rep, kv : Key * (Value -> Value)) : bool :=
              { r' |
                (Same_set _ (fst r') (EnsembleUpdate (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))},
        meth "LookupKey" (r : rep, k : Key) : option Value :=
                v <- {v | ValidLookup r k v};
        ret (r, v)
      }.

End CacheADT.

Section AddDuplicateKeyStrategies.

  Variable Key : Type.
  Variable Value : Type.

  (* Two strategies : replace the key*)

  Lemma refine_ReplaceUsedKeyAdd
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r (fst r')) /\
                    ((usedKey r (fst kv) /\ snd r' = false) \/
                     (~ usedKey r (fst kv) /\ snd r' = true))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- If b
                 Then (ret (EnsembleReplace kv r))
                 Else { r' | SubEnsembleInsert kv r r' };
              ret (r', negb b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    f_equiv; unfold pointwise_relation; intros.
    destruct a; simpl.
    - refine pick val _; try reflexivity.
      apply SubEnsembleInsertReplace.
    - reflexivity.
  Qed.

  Lemma refine_IgnoreUsedKeyAdd
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r (fst r')) /\
                    ((usedKey r (fst kv) /\ snd r' = false) \/
                     (~ usedKey r (fst kv) /\ snd r' = true))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- If b
                 Then (ret r)
                 Else { r' | SubEnsembleInsert kv r r' };
              ret (r', negb b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    f_equiv; unfold pointwise_relation; intros.
    destruct a; simpl.
    - refine pick val _; try reflexivity.
      apply SubEnsembleInsertRefl.
    - reflexivity.
  Qed.

End AddDuplicateKeyStrategies.

Section UpdateMissingKeyStrategies.

  Variable Key : Type.
  Variable Value : Type.

  (* Best Practice : Update the key, if its there. *)

  Lemma refine_IgnoreUnusedKeyUpdate
  : forall (kv : Key * (Value -> Value))
           (r : Ensemble (Key * Value)),
      refine { r' |
                (Same_set _ (fst r') (EnsembleUpdate (fst kv) r (snd kv)))
                 /\ ((usedKey r (fst kv) /\ snd r' = true) \/
                     (~ usedKey r (fst kv) -> snd r' = false))}
             (b <- {b | decides b (usedKey r (fst kv))};
              r' <- ret (EnsembleUpdate (fst kv) r (snd kv));
              ret (r', b)).
  Proof.
    etransitivity.
    apply refine_pick_decides with
            (P := usedKey r (fst kv));
      intros; refine pick pair;
    (apply refine_bind;
     [reflexivity |
      unfold pointwise_relation; intros;
      refine pick val _;
      [simplify with monad laws; higher_order_1_reflexivity
      | intuition ]]).
    apply refine_under_bind.
    destruct a; simpl; intros.
    - refine pick val _; [reflexivity | intuition ].
    - inversion_by computes_to_inv; simpl in H.
      f_equiv.
      apply refine_pick_val.
      unfold Same_set, Included; intuition; unfold In in *.
  Qed.

End UpdateMissingKeyStrategies.

Section CacheEvictionStrategies.

  Variable Key : Type.
  Variable Value : Type.

  (* First refinement- determine if there is a key to be replaced. *)

  Lemma refine_SubEnsembleInsert
  : forall (kv : Key * Value)
           (r : Ensemble (Key * Value)),
      refine { r' | (SubEnsembleInsert kv r r')}
             (k_opt <- {k_opt | forall k',
                                    k_opt = Some k' ->
                                    exists v', r (k', v')};
              Ifopt k_opt as k' Then
                                  ret (EnsembleInsert kv
                                                      (EnsembleRemove k' r))
                                  Else
                                  ret (EnsembleInsert kv r)).
  Proof.
    intros; rewrite refine_Pick_If_Then_Opt with
            (P := fun k' => exists v', r (k', v')).
    f_equiv; unfold pointwise_relation; intros; simpl.
    destruct a;
      [ higher_order_1_reflexivity
      | reflexivity ].
    simpl; intros; apply refine_pick_val;
    unfold Same_set, Included, In, SubEnsembleInsert, EnsembleInsert,
    EnsembleRemove in *; simpl; intros; intuition.
    simpl; intros; apply refine_pick_val;
    unfold Same_set, Included, In, SubEnsembleInsert, EnsembleInsert,
    EnsembleRemove in *; simpl; intros; intuition.
  Qed.

  (* Never tab a key for replacement *)
  Lemma refine_pick_KeyToBeReplaced_never
  : forall (r : Ensemble (Key * Value)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', r (k', v')}
             (ret None).
  Proof.
    intros; rewrite refine_pick_val;
    [ reflexivity
      | discriminate ].
  Qed.

  Section LogicalIndex.

    (* To define various replacement strategies, we're going to
       add a logical index to the pairs of keys and values. *)

    Definition KVEnsemble_EquivalentKeys {A B}
               (ens : Ensemble (Key * A))
               (ens' : Ensemble (Key * B)) :=
      (forall k a, ens (k, a) -> (exists b, ens' (k, b)))
      /\ (forall k b, ens' (k, b) -> (exists a, ens (k, a))).

    Definition CacheADTwLogIndex_AbsR
             (or : Ensemble (Key * Value))
             (nr : Ensemble (Key * Value) *
                   Ensemble (Key * nat))
      := or = (fst nr)
         /\ (KVEnsemble_EquivalentKeys (fst nr) (snd nr)).

    Definition DropLogIndex
               (nr : Ensemble (Key * Value) *
                     Ensemble (Key * nat))
    : Ensemble (Key * Value) :=
      fst nr.

  (* Pick the key with the lowest index for replacement *)
  Lemma refine_pick_KeyToBeReplaced_min
  : forall (r : Ensemble (Key * Value) *
                Ensemble (Key * nat)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', fst r (k', v')}
             {k_opt | forall k',
                         k_opt = Some k' ->
                         ((exists v', fst r (k', v'))
                          /\ (forall idx ki,
                                snd r (k', idx) ->
                                snd r ki ->
                                idx <= snd ki))
                             }.
  Proof.
    intros; apply refine_pick_pick; intros.
    eapply H; eauto.
  Qed.

  (* Pick the key with the highest index for replacement *)
  Lemma refine_pick_KeyToBeReplaced_max
  : forall (r : Ensemble (Key * Value) *
                Ensemble (Key * nat)),
      refine {k_opt | forall k',
                         k_opt = Some k' ->
                         exists v', fst r (k', v')}
             {k_opt | forall k',
                         k_opt = Some k' ->
                         ((exists v', fst r (k', v'))
                          /\ (forall idx ki,
                                snd r (k', idx) ->
                                snd r ki ->
                                snd ki <= idx))
                             }.
  Proof.
    intros; apply refine_pick_pick; intros.
    eapply H; eauto.
  Qed.

    Lemma refine_LogIndexEmpty
    : refine {nr' |
              CacheADTwLogIndex_AbsR (fun _ : Key * Value => False) nr'}
             (ret (fun _  => False, fun _ => False)).
    Proof.
      apply refine_pick_val;
      unfold CacheADTwLogIndex_AbsR, KVEnsemble_EquivalentKeys; intuition;
      destruct_ex; eauto.
    Qed.

    Lemma refine_LogIndexUsedKey
    : forall n or nr,
        CacheADTwLogIndex_AbsR or nr
        -> refine {b | decides b (usedKey or n)}
               {b | decides b (usedKey (fst nr) n)}.
    Proof.
      unfold CacheADTwLogIndex_AbsR, KVEnsemble_EquivalentKeys;
      intros; apply refine_pick_pick;
      unfold usedKey; simpl; intros; unfold decides;
      find_if_inside; simpl in * ; destruct_ex;
      unfold Same_set, Included, In in *; intuition; subst; eauto.
    Qed.

    Lemma refine_pick_CacheADTwLogIndex_AbsR or' :
          refine
            {nr' | CacheADTwLogIndex_AbsR or' nr'}
            (nr' <- {nr' | KVEnsemble_EquivalentKeys or' nr'};
             ret (or', nr')).
    Proof.
      unfold CacheADTwLogIndex_AbsR; intros.
      setoid_rewrite refineEquiv_pick_pair_snd_dep; simpl.
      refine pick val or'.
      simplify with monad laws; f_equiv.
      unfold Same_set, Included; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Remove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (a : Key),
             KVEnsemble_EquivalentKeys (EnsembleRemove a ens)
                                       (EnsembleRemove a ens').
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleRemove in *;
        simpl in *; intuition.
      apply H in H3; destruct_ex; eauto.
      apply H0 in H3; destruct_ex; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Replace {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             kb c,
             KVEnsemble_EquivalentKeys (EnsembleReplace kb ens)
                                       (EnsembleReplace (fst kb, c) ens').
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleReplace,
        EnsembleRemove in *;
        simpl in *; intuition; injections; eauto.
      apply H in H3; destruct_ex; eauto.
      apply H0 in H3; destruct_ex; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Update {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k f g,
             KVEnsemble_EquivalentKeys (EnsembleUpdate k ens f)
                                       (EnsembleUpdate k ens' g).
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleUpdate,
        EnsembleReplace, EnsembleRemove in *;
        simpl in *; intuition; injections; eauto; subst.
      destruct_ex; intuition; eauto; subst.
      apply H in H3; destruct_ex; eauto.
      exists (g x0); left; intuition; eauto.
      apply H in H3; destruct_ex; eauto.
      destruct_ex; intuition; subst.
      apply H0 in H3; destruct_ex;
      eexists; left; intuition; eauto.
      apply H0 in H3; destruct_ex;  eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Refl {B} :
      forall (ens : Ensemble (Key * B)),
        KVEnsemble_EquivalentKeys ens ens.
    Proof.
      unfold KVEnsemble_EquivalentKeys, EnsembleRemove in *;
      simpl in *; intuition; eauto.
    Qed.

    Lemma KVEnsemble_EquivalentKeys_Insert {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B) (c : C),
             KVEnsemble_EquivalentKeys (EnsembleInsert ab ens)
                                       (EnsembleInsert (fst ab, c) ens').
    Proof.
      unfold refine; intros.
      unfold KVEnsemble_EquivalentKeys, EnsembleInsert in *;
        simpl in *; intuition; injections; eauto.
      apply H in H2; destruct_ex; eauto.
      apply H0 in H2; destruct_ex; eauto.
    Qed.

    Definition PickID {A} (_ : A) := True.

    Lemma refine_pick_KVEnsembleInsert {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B),
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleInsert ab ens) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleInsert (fst ab, b) ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Insert,
      KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleInsertRemove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             (ab : Key * B) k,
        refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleInsert
                           ab
                           (EnsembleRemove k ens)) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleInsert (fst ab, b)
                                  (EnsembleRemove k ens'))).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Insert,
      KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleRemove {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k,
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleRemove k ens) ens''}
             (ret (EnsembleRemove k ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Remove.
    Qed.

    Lemma refine_pick_KVEnsembleReplace {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
             k,
             refine
             {ens'' | KVEnsemble_EquivalentKeys
                        (EnsembleReplace k ens) ens''}
             (b <- {b | @PickID C b};
              ret (EnsembleReplace (fst k, b) ens')).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Replace.
    Qed.

    Lemma refine_pick_KVEnsembleUpdate {B C}
    : forall (ens : Ensemble (Key * B))
                (ens' : Ensemble (Key * C))
                (EquivKeys : KVEnsemble_EquivalentKeys ens ens')
                k f,
             refine
               {ens'' | KVEnsemble_EquivalentKeys
                          (EnsembleUpdate k ens f) ens''}
               (b <- {b | @PickID C b};
                ret (EnsembleUpdate k ens' (fun _ => b))).
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto using KVEnsemble_EquivalentKeys_Update.
    Qed.

    Lemma refine_pick_KVEnsemble {B C} :
      forall (ens : Ensemble (Key * B))
             (ens' : Ensemble (Key * C))
             (EquivKeys : KVEnsemble_EquivalentKeys ens ens'),
             refine
          {ens'' | KVEnsemble_EquivalentKeys ens ens''}
          (ret ens').
    Proof.
      unfold refine; intros; inversion_by computes_to_inv;
      subst; econstructor.
      eauto.
    Qed.
  End LogicalIndex.

End CacheEvictionStrategies.

Require Import String_as_OT.
Require Import FMapAVL.
Module StringIndexedMap := FMapAVL.Make String_as_OT.
Definition MapStringNat := StringIndexedMap.t nat.

Section BoundedStringCacheADT.

(* This is a cache which ignores updates to missing values
   and uses an LRU strategy to pick any elements to remove.
 *)

  Variable Value : Type.
  Variable Bound : nat.

  Definition EnsembleFMapEquivalence {A}
             (ens : Ensemble (string * A))
             (fmap : StringIndexedMap.t A) :=
    forall k,
      (forall a, StringIndexedMap.find k fmap = Some a ->
                 ens (k, a))
      /\ (forall a, ens (k, a) ->
                    StringIndexedMap.find k fmap = Some a).

  Definition FMapCommonKeys {A B}
             (values : StringIndexedMap.t A)
             (indices : StringIndexedMap.t B)
    := forall k,
         (forall a, StringIndexedMap.MapsTo k a values ->
                    exists b, StringIndexedMap.MapsTo k b indices)
         /\ (forall b, StringIndexedMap.MapsTo k b indices ->
                    exists a, StringIndexedMap.MapsTo k a values).

  Definition indexBound
             (indices : StringIndexedMap.t nat)
             (indicesBound : nat)
    := forall k idx,
         StringIndexedMap.find k indices = Some idx ->
         idx <= indicesBound.

  Definition BoundedStringCacheADT_AbsR
             (spec : Ensemble (string * Value)
                     * Ensemble (string * nat))
             (impl : StringIndexedMap.t Value
                     * StringIndexedMap.t nat
                     * nat) :=
    EnsembleFMapEquivalence (fst spec) (fst (fst impl)) /\
    EnsembleFMapEquivalence (snd spec) (snd (fst impl)) /\
    FMapCommonKeys (fst (fst impl)) (snd (fst impl)) /\
    indexBound (snd (fst impl)) (snd impl).

  Lemma decides_usedKey
  : forall (or : Ensemble (string * Value))
           (nr : StringIndexedMap.t Value)
           (k : string),
      EnsembleFMapEquivalence or nr ->
      decides (if StringIndexedMap.find k nr then
                 true else
                 false)
              (usedKey or k).
  Proof.
    unfold EnsembleFMapEquivalence, usedKey; intros;
    pose proof (H k); intuition.
    find_if_inside; simpl; eauto.
    intuition; destruct_ex.
    apply H2 in H0; discriminate.
  Qed.

  Lemma AbsR_add_EnsembleReplace {A}
  : forall nr kv or v,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) (fst kv) nr = Some v
      -> EnsembleFMapEquivalence
           (EnsembleReplace kv or)
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold EnsembleReplace, EnsembleRemove,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k (fst kv)); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (snd kv) (refl_equal (fst kv))))
      in *; destruct kv; simpl in *; f_equal; congruence.
    right; split; eauto.
    eapply H.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    destruct (string_dec k (fst kv)); subst.
    simpl in H1; congruence.
    destruct (H k).
    generalize (H4 _ H3).
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleUpdate {A}
  : forall nr k f or v,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) k nr = Some v
      -> EnsembleFMapEquivalence
           (EnsembleUpdate k or f)
           (StringIndexedMap.add k (f v) nr).
  Proof.
    unfold EnsembleUpdate, EnsembleRemove,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k0 k); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (f v) (refl_equal k)))
      in *; simpl in *; f_equal; injections; intuition.
    eexists; split; eauto.
    eapply H; eauto.
    right; split; eauto.
    eapply H.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    destruct_ex; intuition; subst.
    apply H in H3; rewrite H0 in H3; injections.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    apply H in H3.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleUpdate' {A}
  : forall nr k f or,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) k nr = None
      -> EnsembleFMapEquivalence (EnsembleUpdate k or f) nr.
  Proof.
    unfold EnsembleUpdate, EnsembleRemove,
    EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k0 k); subst.
    rewrite H0 in H1; discriminate.
    right; intuition; eapply H; eauto.
    subst; simpl in *.
    destruct_ex; intuition; eapply H in H3; subst.
    destruct_ex; rewrite H0 in *; discriminate.
    eapply H; eauto.
  Qed.

  Lemma AbsR_add_EnsembleInsert {A}
  : forall nr kv or,
      EnsembleFMapEquivalence or nr
      -> StringIndexedMap.find (elt:=A) (fst kv) nr = None
      -> EnsembleFMapEquivalence
           (fun kv' => kv' = kv \/ or kv')
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold SubEnsembleInsert, EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k (fst kv)); subst.
    left.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 nr (snd kv) (refl_equal (fst kv))))
      in *; destruct kv; simpl in *; f_equal; congruence.
    right.
    pose proof (H k); intuition.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_3,
    StringIndexedMap.find_2.
    subst; simpl in *.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_1.
    destruct (string_dec k (fst kv)); subst.
    apply H in H2.
    rewrite H0 in H2; discriminate.
    apply H in H2.
    eauto using StringIndexedMap.find_1, StringIndexedMap.add_2,
    StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_remove_EnsembleRemove {A}
  : forall nr or k,
      EnsembleFMapEquivalence (A := A) or nr
      -> EnsembleFMapEquivalence
           (EnsembleRemove k or)
           (StringIndexedMap.remove k nr).
  Proof.
    unfold EnsembleRemove, EnsembleFMapEquivalence;
    intros; intuition; simpl in *; subst.
    eapply StringIndexedMap.remove_1; try reflexivity;
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0;
    simpl; apply StringIndexedMap.find_2 in H0;
    unfold StringIndexedMap.MapsTo, StringIndexedMap.remove in H0;
    simpl in H0; eauto.
    destruct (string_dec k0 k); subst; simpl in *.
    exfalso.
    eapply StringIndexedMap.remove_1; try reflexivity;
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0;
    simpl; apply StringIndexedMap.find_2 in H0;
    unfold StringIndexedMap.MapsTo, StringIndexedMap.remove in H0;
    simpl in H0; eauto.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.remove_3 in H0; eapply H;
    eauto using StringIndexedMap.find_1.
    apply StringIndexedMap.find_1.
    apply StringIndexedMap.remove_2; eauto.
    eapply H in H2.
    eauto using StringIndexedMap.find_2.
  Qed.

  Lemma AbsR_add_EnsembleInsertRemove {A}
  : forall nr or kv,
      EnsembleFMapEquivalence (A := A) or nr
      -> EnsembleFMapEquivalence
           (EnsembleInsert kv (EnsembleRemove (fst kv) or))
           (StringIndexedMap.add (fst kv) (snd kv) nr).
  Proof.
    unfold SubEnsembleInsert, EnsembleRemove,
    EnsembleInsert, EnsembleFMapEquivalence;
    intros; intuition.
    destruct (string_dec k a); subst; simpl in *.
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ b (refl_equal a)))
      in H0; left; f_equal; congruence.
    right; intuition;
    apply StringIndexedMap.find_2 in H0;
      apply StringIndexedMap.add_3 in H0; eauto.
    eapply H; eauto using StringIndexedMap.find_1.
    unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
    StringIndexedMap.MapsTo in *; simpl in *; eauto.
    injections.
    eauto using StringIndexedMap.find_1,
    StringIndexedMap.add_1.
    apply H in H2; simpl in *.
    apply StringIndexedMap.find_1;
      apply StringIndexedMap.add_2; eauto.
    eauto using StringIndexedMap.find_1,
      StringIndexedMap.add_2, StringIndexedMap.remove_2,
      StringIndexedMap.find_2.
  Qed.

  Lemma FMapCommonKeys_add {A B}
  : forall k a b
           (ens : StringIndexedMap.t A)
           (ens' : StringIndexedMap.t B),
      FMapCommonKeys ens ens'
      -> FMapCommonKeys
           (StringIndexedMap.add k a ens)
           (StringIndexedMap.add k b ens').
  Proof.
    unfold FMapCommonKeys; intuition;
    (destruct (string_dec k0 k);
     [eexists; eapply StringIndexedMap.add_1; eauto
     |
     eapply StringIndexedMap.add_3 in H0; eauto;
     apply H in H0; destruct_ex;
     eexists; eapply StringIndexedMap.add_2; eauto]).
  Qed.

  Lemma FMapCommonKeys_remove {A B}
  : forall k
           (ens : StringIndexedMap.t A)
           (ens' : StringIndexedMap.t B),
      FMapCommonKeys ens ens'
      -> FMapCommonKeys
           (StringIndexedMap.remove k ens)
           (StringIndexedMap.remove k ens').
  Proof.
    unfold FMapCommonKeys; intuition;
    (destruct (string_dec k0 k);
     [subst; exfalso;
      eapply (StringIndexedMap.remove_1); eauto;
      unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
      StringIndexedMap.MapsTo in *; simpl in *; eauto
     |
     eapply StringIndexedMap.remove_3 in H0;
       apply H in H0; destruct_ex;
       eauto using StringIndexedMap.remove_2 ]).
  Qed.

  Lemma indexBound_add
  : forall indices k n,
      indexBound indices n
      -> indexBound (StringIndexedMap.add k n indices) (S n).
  Proof.
    unfold indexBound; intros.
    destruct (string_dec k k0).
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ _ e)) in H0.
    injections; omega.
    apply StringIndexedMap.find_2 in H0.
    eapply StringIndexedMap.add_3 in H0; eauto.
    apply StringIndexedMap.find_1 in H0; eauto.
  Qed.

  Lemma indexBound_add_remove
  : forall indices k k' n,
      indexBound indices n
      -> indexBound (StringIndexedMap.add k n
                                          (StringIndexedMap.remove k' indices)) (S n).
  Proof.
    unfold indexBound; intros.
    destruct (string_dec k k0).
    rewrite (StringIndexedMap.find_1 (StringIndexedMap.add_1 _ _ e)) in H0.
    injections; omega.
    apply StringIndexedMap.find_2 in H0.
    eapply StringIndexedMap.add_3 in H0; eauto.
    destruct (string_dec k' k0).
    exfalso;
      eapply (StringIndexedMap.remove_1); eauto;
      unfold StringIndexedMap.In, StringIndexedMap.Raw.In0,
      StringIndexedMap.MapsTo in *; simpl in *; eauto.
    apply StringIndexedMap.remove_3 in H0; eauto.
    apply StringIndexedMap.find_1 in H0; eauto.
  Qed.

  Definition find_minimum_Key
             (indices : StringIndexedMap.t nat)
  : option (string * nat) :=
    StringIndexedMap.fold
      (fun k idx sv =>
         Ifopt sv as sv'
                       Then
                         if (lt_dec idx (snd sv') )
                         then Some (k, idx)
                         else Some sv'
                       Else
                         Some (k, idx))
      indices None.

  Lemma fold_left_In :
    forall l kv p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p) l p' =
   Some kv ->
   (Some kv = p') \/
   SetoidList.InA
     (fun p p' : string * nat => fst p = fst p' /\ snd p = snd p')
     kv l.
  Proof.
    clear; induction l; simpl; intros; subst; eauto.
    destruct p'; simpl in H.
    destruct (lt_dec (snd a) (snd p)).
    destruct (IHl _ _ H).
    right; constructor; injections; simpl; eauto.
    right; constructor 2; eauto.
    destruct (IHl _ _ H).
    injections; eauto.
    eauto.
    right; destruct (IHl _ _ H); injections; eauto.
  Qed.

  Lemma fold_left_min_opt :
    forall l kv p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p) l (Some p') =
   Some kv ->
   snd kv <= snd p'.
  Proof.
    clear; induction l; simpl; intros; subst; eauto.
    injections; eauto.
    destruct (lt_dec (snd a) (snd p')).
    apply le_trans with (m := snd a); eauto with arith.
    eauto.
  Qed.

  Lemma find_minimum_Key_In :
    forall indices kv,
      find_minimum_Key indices = Some kv ->
      StringIndexedMap.MapsTo (elt:=nat) (fst kv) (snd kv) indices.
  Proof.
    intros.
    unfold find_minimum_Key in H.
    rewrite StringIndexedMap.fold_1 in H.
    eapply StringIndexedMap.elements_2.
    destruct (@fold_left_In (StringIndexedMap.elements (elt:=nat) indices) kv None); intuition.
    unfold StringIndexedMap.key in *.
    rewrite <- H; f_equal.
    repeat (apply functional_extensionality; intros); f_equal;
    intuition.
    discriminate.
    destruct kv.
    unfold StringIndexedMap.eq_key_elt, StringIndexedMap.Raw.Proofs.PX.eqke; eauto.
  Qed.

  Lemma find_minimum_Key_correct :
    forall indices kv,
      find_minimum_Key indices = Some kv ->
      forall k v, StringIndexedMap.find k indices = Some v ->
                  snd kv <= v.
  Proof.
    intros.
    unfold find_minimum_Key in H.
    rewrite StringIndexedMap.fold_1 in H.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.elements_1 in H0.
    unfold StringIndexedMap.eq_key_elt in H0.
    unfold StringIndexedMap.Raw.Proofs.PX.eqke in H0.
    assert (   forall (k0 : StringIndexedMap.key) (v0 : nat) p',
   fold_left
     (fun (a : option (StringIndexedMap.key * nat))
        (p : StringIndexedMap.key * nat) =>
      Ifopt a as sv'
      Then if lt_dec (snd p) (snd sv') then Some (fst p, snd p) else Some sv'
      Else Some p)
     (StringIndexedMap.elements (elt:=nat) indices) (Some p') =
   Some kv ->

   SetoidList.InA
     (fun p p' : string * nat => fst p = fst p' /\ snd p = snd p')
     (k0, v0) (StringIndexedMap.elements (elt:=nat) indices)
   -> ((snd kv <= snd p') /\( snd kv <= v0 ))).
    { clear; induction (StringIndexedMap.elements (elt:=nat) indices);
      simpl; intros; subst; eauto.
      destruct p'; simpl in H.
      inversion H0; subst; intuition; simpl in *; subst; eauto.
      destruct (lt_dec (snd a) (snd p')).
      inversion H0; subst.
      intuition; simpl in *; intros; subst.
      destruct (fold_left_In _ _ H); injections; simpl;
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *.
      eauto with arith.
      destruct (fold_left_In _ _ H); injections; simpl;
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto with arith.
      intuition.
      destruct (IHl _ _ _ H H2); simpl in *.
      omega.
      destruct (IHl _ _ _ H H2); simpl in *; eauto.
      inversion H0; subst.
      destruct (fold_left_In _ _ H); injections; simpl;
      intuition; simpl in *; subst.
      apply not_gt.
      auto with arith.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto.
      destruct kv.
      destruct (IHl _ _ _ H H1); simpl in *; eauto.
      eapply le_trans.
      eapply H2.
      apply not_gt; auto with arith.
      destruct (IHl _ _ _ H H2); eauto.
    }
    destruct ((StringIndexedMap.elements (elt:=nat) indices)).
    simpl in H; discriminate.
    simpl in H.
    eapply H1 with (p' := p); eauto.
    simpl.
    destruct (lt_dec (snd p) (snd p)); eauto.
    exfalso.
    omega.
    rewrite <- H; f_equal.
    repeat (apply functional_extensionality; intros); f_equal.
    destruct x0; reflexivity.
    destruct p; eauto.
  Qed.

  Lemma refine_pick_oldest {V} :
    forall spec_indices impl_indices
           spec_values impl_values,
    EnsembleFMapEquivalence spec_indices impl_indices /\
    EnsembleFMapEquivalence spec_values impl_values /\
    FMapCommonKeys impl_values impl_indices
    ->  refine {k_opt | forall k' : string,
                          k_opt = Some k' ->
                          ((exists v' : V, spec_values (k', v'))
                           /\ (forall (idx : nat) (ki : string * nat),
                                 spec_indices (k', idx) -> spec_indices ki -> idx <= snd ki))}
               (ret (option_map fst (find_minimum_Key impl_indices))).
  Proof.
    unfold refine; intros; inversion_by computes_to_inv; subst.
    econstructor; intros.
    caseEq (find_minimum_Key impl_indices); rewrite H2 in *;
    simpl in *; try discriminate; injections.
    unfold EnsembleFMapEquivalence in *.
    pose proof (find_minimum_Key_correct _ H2).
    pose proof (find_minimum_Key_In _ H2).
    split; intros.
    unfold FMapCommonKeys in H3.
    destruct (H3 (fst p)).
    destruct (H6 (snd p)); eauto.
    destruct (H (fst p)); eexists; eauto.
    eapply H8.
    eauto using StringIndexedMap.find_1.
    apply H1 in H5; destruct ki; eapply H1 in H6. destruct_ex;
    simpl in *.
    eapply StringIndexedMap.find_1 in H4; rewrite H5 in H4.
    injection H4; intros; subst; eauto.
  Qed.

  Lemma refine_If_Then_Else'
  : forall (A : Type) (c : bool) (x x0 y y0 : Comp A),
      (c = true -> refine x y)
      -> (c = false -> refine x0 y0)
      -> refine (If c Then x Else x0) (If c Then y Else y0).
  Proof.
    unfold refine; intros; destruct c; auto.
  Qed.

  Lemma FMapCommonKeys_find_None {A B}
  : forall m m' k,
      FMapCommonKeys m m'
      -> StringIndexedMap.find (elt:=A) k m = None
      -> StringIndexedMap.find (elt:=B) k m' = None .
  Proof.
    intros.
    caseEq (StringIndexedMap.find (elt:=B) k m'); eauto.
    apply StringIndexedMap.find_2 in H1.
    apply H in H1.
    destruct_ex.
    apply StringIndexedMap.find_1 in H1.
    rewrite H1 in H0; discriminate.
  Qed.

  Lemma StringIndexedMap_find_None_remove {V}
  : forall k k' m,
      StringIndexedMap.find (elt:=V) k m = None
      -> StringIndexedMap.find
           (elt:=V) k
           (StringIndexedMap.remove k' m) = None.
  Proof.
    intros.
    caseEq (StringIndexedMap.find (elt:=V) k (StringIndexedMap.remove (elt:=V) k' m)); eauto.
    apply StringIndexedMap.find_2 in H0.
    apply StringIndexedMap.remove_3 in H0;
      apply StringIndexedMap.find_1 in H0;
      congruence.
  Qed.

Tactic Notation "rewrite" "with" "monad" "laws" :=
  repeat first [ setoid_rewrite refineEquiv_bind_bind
               | setoid_rewrite refineEquiv_bind_unit
               | setoid_rewrite refineEquiv_unit_bind].

(* To keep the presentation clean for the paper, we'll
 split and rename the premise holding the abstraction. *)
Ltac split_CacheADTwLogIndex_AbsR :=
  match goal with
      H : CacheADTwLogIndex_AbsR _ _ |- _ =>
      let H' := fresh "Eq_or_nr" in
      let H'' := fresh "EquivKeys_H" in
      destruct H as [H' H'']; rewrite H' in *
  end.

Definition BoundedStringCacheADT
: Sharpened (@CacheSpec string Value).
    Proof.
      unfold CacheSpec.
      hone representation using (@CacheADTwLogIndex_AbsR string Value).
      hone constructor "EmptyCache".
      {
        simplify with monad laws.
        rewrite refine_LogIndexEmpty.
        finish honing.
      }
      hone method "AddKey".
      {
        split_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_pick_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_ReplaceUsedKeyAdd.
        setoid_rewrite refine_SubEnsembleInsert.
        rewrite with monad laws.
        setoid_rewrite refine_pick_KeyToBeReplaced_min.
        setoid_rewrite refine_If_Then_Else_Bind.
        rewrite with monad laws.
        setoid_rewrite refine_If_Opt_Then_Else_Bind.
        rewrite with monad laws.
        pose proof refine_pick_KVEnsembleInsertRemove.
        setoid_rewrite refine_pick_KVEnsembleInsertRemove
                       with (1 := EquivKeys_H).
        setoid_rewrite refine_pick_KVEnsembleInsert
                       with (1 := EquivKeys_H).
        rewrite with monad laws; simpl.
        finish honing.
      }
      hone method "UpdateKey".
      {
        split_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_pick_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_IgnoreUnusedKeyUpdate.
        rewrite with monad laws.
        setoid_rewrite refine_pick_KVEnsembleUpdate
                       with (1 := EquivKeys_H).
        rewrite with monad laws; simpl.
        finish honing.
      }
      hone method "LookupKey".
      {
        split_CacheADTwLogIndex_AbsR.
        setoid_rewrite refine_pick_CacheADTwLogIndex_AbsR.
        rewrite with monad laws.
        setoid_rewrite (refine_pick_KVEnsemble EquivKeys_H).
        rewrite with monad laws;  simpl.
        finish honing.
      }

      hone representation using BoundedStringCacheADT_AbsR.

      hone constructor "EmptyCache".
      { simplify with monad laws.
        refine pick val
        (StringIndexedMap.empty Value,
         StringIndexedMap.empty nat,
         0).
        finish honing.
        repeat split; intuition; simpl in *;
        try (eapply (StringIndexedMap.empty_1); eauto;
             eapply (StringIndexedMap.find_2); eauto).
        - exfalso;
          eapply StringIndexedMap.empty_1; eauto.
        - exfalso;
          eapply StringIndexedMap.empty_1; eauto.
        - unfold indexBound; intros;
          exfalso;
          eapply (StringIndexedMap.empty_1);
          eapply (StringIndexedMap.find_2); eauto.
      }

    hone method "LookupKey".
    {
      simplify with monad laws.
      refine pick val (StringIndexedMap.find n (fst (fst r_n))).
      simplify with monad laws; simpl.
      rewrite refine_pick_val by eauto.
      simplify with monad laws.
      finish honing.
      unfold BoundedStringCacheADT_AbsR, ValidLookup in *;
        eapply H0.
    }

    hone method "UpdateKey".
    {
      unfold BoundedStringCacheADT_AbsR in *; split_and.
      simplify with monad laws.
      rewrite refine_pick_val by eauto using decides_usedKey.
      simplify with monad laws; simpl.
      refine pick val (snd r_n); unfold PickID; eauto;
      simplify with monad laws.
      etransitivity.
      apply refine_Pick_Some_dec with
      (P := fun b => StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n)) = Some b); intros.
      {
        refine pick val
               (StringIndexedMap.add (fst n) ((snd n) b) (fst (fst r_n)),
                StringIndexedMap.add (fst n) (snd r_n) (snd (fst r_n)),
                S (snd r_n)).
        simplify with monad laws.
        rewrite H3.
        higher_order_1_reflexivity.
        simpl; intuition.
        eauto using AbsR_add_EnsembleUpdate.
        apply StringIndexedMap.find_2 in H3.
        apply H2 in H3; destruct_ex.
        eapply AbsR_add_EnsembleUpdate with (f := fun _ => snd r_n);
          eauto using StringIndexedMap.find_1.
        eauto using FMapCommonKeys_add.
        eauto using indexBound_add.
      }
      {
        refine pick val _; eauto.
        simplify with monad laws; simpl.
        reflexivity.
        caseEq (StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n)));
          try solve [exfalso; eapply H3; eauto];
          intuition; eauto using AbsR_add_EnsembleUpdate'.
        eapply AbsR_add_EnsembleUpdate'; eauto using FMapCommonKeys_find_None.
      }
      refine pick val (StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n)));
        try (split; congruence).
      simplify with monad laws.
      finish honing.
    }

    hone method "AddKey".
    {
      unfold BoundedStringCacheADT_AbsR in *; split_and.
      simplify with monad laws.
      rewrite refine_pick_val by eauto using decides_usedKey.
      simplify with monad laws.
      setoid_rewrite refine_If_Then_Else_Bind.
      etransitivity.
      apply refine_If_Then_Else';
        caseEq (StringIndexedMap.find (elt:=Value) (fst n) (fst (fst r_n))); simpl; try discriminate.
      (* If the key is used, do this. *)
      + simplify with monad laws.
        refine pick val (snd r_n); unfold PickID; eauto.
        simplify with monad laws; simpl.
        refine pick val ((_, _), _);
          [ |
            simpl; intuition;
            simpl; eauto using
                         AbsR_add_EnsembleReplace,
                   FMapCommonKeys_remove,
                   FMapCommonKeys_add,
                   AbsR_add_EnsembleInsertRemove,
                   indexBound_add].
        simplify with monad laws.
        reflexivity.
        eapply (AbsR_add_EnsembleInsertRemove (fst n, snd r_n) H0).
      + (* If the key is not used, do this. *)
        simplify with monad laws.
        (* Check to see if we've hit the bound. *)
        apply (refine_if (b := if (gt_dec (snd r_n) Bound)
                               then true
                               else false)); intros.
        (* If we have, then pick a key to remove. *)
        rewrite refine_pick_oldest; eauto.
        simplify with monad laws.
        rewrite refine_If_Opt_Then_Else_Bind.
        (* Should add a constaint that Bound is greater
             than zero- then we can do away with this check. *)
        apply refine_If_Opt_Then_Else.
        * unfold pointwise_relation; intros.
          refine pick val (snd r_n); unfold PickID; eauto.
          simplify with monad laws; simpl.
          refine pick val ((StringIndexedMap.add (elt:=Value) (fst n) (snd n) (StringIndexedMap.remove a (fst (fst r_n))), _), S (snd r_n));
            [ |
              simpl; split; [ | split; [ | split ] ];
              simpl; eauto using
                           AbsR_add_EnsembleInsertRemove,
                     FMapCommonKeys_remove,
                     AbsR_add_EnsembleInsert,
                     AbsR_remove_EnsembleRemove,
                     StringIndexedMap_find_None_remove,
                     FMapCommonKeys_add,
                     indexBound_add_remove].
          simplify with monad laws; simpl.
          higher_order_1_reflexivity.
          apply (@AbsR_add_EnsembleInsert nat);
            eauto using
                AbsR_add_EnsembleInsert, AbsR_remove_EnsembleRemove,
          StringIndexedMap_find_None_remove.
          apply StringIndexedMap_find_None_remove.
          eapply FMapCommonKeys_find_None; eauto.
        * refine pick val (snd r_n); unfold PickID; eauto.
          simplify with monad laws; simpl.
          refine pick val ((_, _), S (snd r_n));
            [ |
              simpl; intuition
                       simpl; eauto using
                                    AbsR_add_EnsembleInsert,
                              FMapCommonKeys_add,
                              indexBound_add;
              eapply (AbsR_add_EnsembleInsert (_, _));
              simpl; eauto using FMapCommonKeys_find_None].
          simplify with monad laws.
          reflexivity.
        * refine pick val None; try discriminate.
          simplify with monad laws.
          refine pick val (snd r_n); unfold PickID; eauto.
          simplify with monad laws; simpl.
          refine pick val ((_, _), S (snd r_n));
            [ |
              simpl; intuition
                       simpl; eauto using
                                    AbsR_add_EnsembleInsert,
                              FMapCommonKeys_add,
                              indexBound_add;
              eapply (AbsR_add_EnsembleInsert (_, _));
              simpl; eauto using FMapCommonKeys_find_None].
          simplify with monad laws.
          reflexivity.
      + finish honing.
    }

    finish sharpening.
    Defined.
F
End BoundedStringCacheADT.


From iris.algebra Require Export cmra.
Set Default Proof Using "Type".

(** The basic definition of the uPred type, its metric and functor laws.
    You probably do not want to import this file. Instead, import
    base_logic.base_logic; that will also give you all the primitive
    and many derived laws for the logic. *)

(* A good way of understanding this definition of the uPred OFE is to
   consider the OFE uPred0 of monotonous SProp predicates. That is,
   uPred0 is the OFE of non-expansive functions from M to SProp that
   are monotonous with respect to CMRA inclusion. This notion of
   monotonicity has to be stated in the SProp logic. Together with the
   usual closedness property of SProp, this gives exactly uPred_mono.

   Then, we quotient uPred0 *in the sProp logic* with respect to
   equivalence on valid elements of M. That is, we quotient with
   respect to the following *sProp* equivalence relation:
     P1 ≡ P2 := ∀ x, ✓ x → (P1(x) ↔ P2(x))       (1)
   When seen from the ambiant logic, obtaining this quotient requires
   definig both a custom Equiv and Dist.

   It is worth noting that this equivalence relation admits canonical
   representatives. More precisely, one can show that every
   equivalence class contains exactly one element P0 such that:
     ∀ x, (✓ x → P0(x)) → P0(x)                 (2)
   (Again, this assertion has to be understood in sProp). Intuitively,
   this says that P0 trivially holds whenever the resource is invalid.
   Starting from any element P, one can find this canonical
   representative by choosing:
     P0(x) := ✓ x → P(x)                        (3)

   Hence, as an alternative definition of uPred, we could use the set
   of canonical representatives (i.e., the subtype of monotonous
   sProp predicates that verify (2)). This alternative definition would
   save us from using a quotient. However, the definitions of the various
   connectives would get more complicated, because we have to make sure
   they all verify (2), which sometimes requires some adjustments. We
   would moreover need to prove one more property for every logical
   connective.
 *)

Record uPred (M : ucmraT) : Type := IProp {
  uPred_holds :> nat → M → Prop;

  uPred_mono n1 n2 x1 x2 :
    uPred_holds n1 x1 → x1 ≼{n1} x2 → n2 ≤ n1 → uPred_holds n2 x2
}.
Arguments uPred_holds {_} _ _ _ : simpl never.
Add Printing Constructor uPred.
Instance: Params (@uPred_holds) 3.

Delimit Scope uPred_scope with I.
Bind Scope uPred_scope with uPred.
Arguments uPred_holds {_} _%I _ _.

Section cofe.
  Context {M : ucmraT}.

  Inductive uPred_equiv' (P Q : uPred M) : Prop :=
    { uPred_in_equiv : ∀ n x, ✓{n} x → P n x ↔ Q n x }.
  Instance uPred_equiv : Equiv (uPred M) := uPred_equiv'.
  Inductive uPred_dist' (n : nat) (P Q : uPred M) : Prop :=
    { uPred_in_dist : ∀ n' x, n' ≤ n → ✓{n'} x → P n' x ↔ Q n' x }.
  Instance uPred_dist : Dist (uPred M) := uPred_dist'.
  Definition uPred_ofe_mixin : OfeMixin (uPred M).
  Proof.
    split.
    - intros P Q; split.
      + by intros HPQ n; split=> i x ??; apply HPQ.
      + intros HPQ; split=> n x ?; apply HPQ with n; auto.
    - intros n; split.
      + by intros P; split=> x i.
      + by intros P Q HPQ; split=> x i ??; symmetry; apply HPQ.
      + intros P Q Q' HP HQ; split=> i x ??.
        by trans (Q i x);[apply HP|apply HQ].
    - intros n P Q HPQ; split=> i x ??; apply HPQ; auto.
  Qed.
  Canonical Structure uPredC : ofeT := OfeT (uPred M) uPred_ofe_mixin.

  Program Definition uPred_compl : Compl uPredC := λ c,
    {| uPred_holds n x := ∀ n', n' ≤ n → ✓{n'}x → c n' n' x |}.
  Next Obligation.
    move=> /= c n1 n2 x1 x2 HP Hx12 Hn12 n3 Hn23 Hv. eapply uPred_mono.
    eapply HP, cmra_validN_includedN, cmra_includedN_le=>//; lia.
    eapply cmra_includedN_le=>//; lia. done.
  Qed.
  Global Program Instance uPred_cofe : Cofe uPredC := {| compl := uPred_compl |}.
  Next Obligation.
    intros n c; split=>i x Hin Hv.
    etrans; [|by symmetry; apply (chain_cauchy c i n)]. split=>H; [by apply H|].
    repeat intro. apply (chain_cauchy c n' i)=>//. by eapply uPred_mono.
  Qed.
End cofe.
Arguments uPredC : clear implicits.

Instance uPred_ne {M} (P : uPred M) n : Proper (dist n ==> iff) (P n).
Proof.
  intros x1 x2 Hx; split=> ?; eapply uPred_mono; eauto; by rewrite Hx.
Qed.
Instance uPred_proper {M} (P : uPred M) n : Proper ((≡) ==> iff) (P n).
Proof. by intros x1 x2 Hx; apply uPred_ne, equiv_dist. Qed.

Lemma uPred_holds_ne {M} (P Q : uPred M) n1 n2 x :
  P ≡{n2}≡ Q → n2 ≤ n1 → ✓{n2} x → Q n1 x → P n2 x.
Proof.
  intros [Hne] ???. eapply Hne; try done. eauto using uPred_mono, cmra_validN_le.
Qed.

(* Equivalence to the definition of uPred in the appendix. *)
Lemma uPred_alt {M : ucmraT} (P: nat → M → Prop) :
  (∀ n1 n2 x1 x2, P n1 x1 → x1 ≼{n1} x2 → n2 ≤ n1 → P n2 x2) ↔
  ( (∀ x n1 n2, n2 ≤ n1 → P n1 x → P n2 x) (* Pointwise down-closed *)
  ∧ (∀ n x1 x2, x1 ≡{n}≡ x2 → ∀ m, m ≤ n → P m x1 ↔ P m x2) (* Non-expansive *)
  ∧ (∀ n x1 x2, x1 ≼{n} x2 → ∀ m, m ≤ n → P m x1 → P m x2) (* Monotonicity *)
  ).
Proof.
  (* Provide this lemma to eauto. *)
  assert (∀ n1 n2 (x1 x2 : M), n2 ≤ n1 → x1 ≡{n1}≡ x2 → x1 ≼{n2} x2).
  { intros ????? H. eapply cmra_includedN_le; last done. by rewrite H. }
  (* Now go ahead. *)
  split.
  - intros Hupred. repeat split; eauto using cmra_includedN_le.
  - intros (Hdown & _ & Hmono) **. eapply Hmono; [done..|]. eapply Hdown; done.
Qed.

(** functor *)
Program Definition uPred_map {M1 M2 : ucmraT} (f : M2 -n> M1)
  `{!CmraMorphism f} (P : uPred M1) :
  uPred M2 := {| uPred_holds n x := P n (f x) |}.
Next Obligation. naive_solver eauto using uPred_mono, cmra_morphism_monotoneN. Qed.

Instance uPred_map_ne {M1 M2 : ucmraT} (f : M2 -n> M1)
  `{!CmraMorphism f} n : Proper (dist n ==> dist n) (uPred_map f).
Proof.
  intros x1 x2 Hx; split=> n' y ??.
  split; apply Hx; auto using cmra_morphism_validN.
Qed.
Lemma uPred_map_id {M : ucmraT} (P : uPred M): uPred_map cid P ≡ P.
Proof. by split=> n x ?. Qed.
Lemma uPred_map_compose {M1 M2 M3 : ucmraT} (f : M1 -n> M2) (g : M2 -n> M3)
    `{!CmraMorphism f, !CmraMorphism g} (P : uPred M3):
  uPred_map (g ◎ f) P ≡ uPred_map f (uPred_map g P).
Proof. by split=> n x Hx. Qed.
Lemma uPred_map_ext {M1 M2 : ucmraT} (f g : M1 -n> M2)
      `{!CmraMorphism f} `{!CmraMorphism g}:
  (∀ x, f x ≡ g x) → ∀ x, uPred_map f x ≡ uPred_map g x.
Proof. intros Hf P; split=> n x Hx /=; by rewrite /uPred_holds /= Hf. Qed.
Definition uPredC_map {M1 M2 : ucmraT} (f : M2 -n> M1) `{!CmraMorphism f} :
  uPredC M1 -n> uPredC M2 := CofeMor (uPred_map f : uPredC M1 → uPredC M2).
Lemma uPredC_map_ne {M1 M2 : ucmraT} (f g : M2 -n> M1)
    `{!CmraMorphism f, !CmraMorphism g} n :
  f ≡{n}≡ g → uPredC_map f ≡{n}≡ uPredC_map g.
Proof.
  by intros Hfg P; split=> n' y ??;
    rewrite /uPred_holds /= (dist_le _ _ _ _(Hfg y)); last lia.
Qed.

Program Definition uPredCF (F : urFunctor) : cFunctor := {|
  cFunctor_car A B := uPredC (urFunctor_car F B A);
  cFunctor_map A1 A2 B1 B2 fg := uPredC_map (urFunctor_map F (fg.2, fg.1))
|}.
Next Obligation.
  intros F A1 A2 B1 B2 n P Q HPQ.
  apply uPredC_map_ne, urFunctor_ne; split; by apply HPQ.
Qed.
Next Obligation.
  intros F A B P; simpl. rewrite -{2}(uPred_map_id P).
  apply uPred_map_ext=>y. by rewrite urFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' P; simpl. rewrite -uPred_map_compose.
  apply uPred_map_ext=>y; apply urFunctor_compose.
Qed.

Instance uPredCF_contractive F :
  urFunctorContractive F → cFunctorContractive (uPredCF F).
Proof.
  intros ? A1 A2 B1 B2 n P Q HPQ. apply uPredC_map_ne, urFunctor_contractive.
  destruct n; split; by apply HPQ.
Qed.

(** logical entailement *)
Inductive uPred_entails {M} (P Q : uPred M) : Prop :=
  { uPred_in_entails : ∀ n x, ✓{n} x → P n x → Q n x }.
Hint Extern 0 (uPred_entails _ _) => reflexivity.
Instance uPred_entails_rewrite_relation M : RewriteRelation (@uPred_entails M).

Hint Resolve uPred_mono : uPred_def.

(** Notations *)
Notation "P ⊢ Q" := (uPred_entails P%I Q%I)
  (at level 99, Q at level 200, right associativity) : stdpp_scope.
Notation "(⊢)" := uPred_entails (only parsing) : stdpp_scope.
Notation "P ⊣⊢ Q" := (equiv (A:=uPred _) P%I Q%I)
  (at level 95, no associativity) : stdpp_scope.
Notation "(⊣⊢)" := (equiv (A:=uPred _)) (only parsing) : stdpp_scope.

Module uPred.
Section entails.
Context {M : ucmraT}.
Implicit Types P Q : uPred M.

Global Instance entails_po : PreOrder (@uPred_entails M).
Proof.
  split.
  - by intros P; split=> x i.
  - by intros P Q Q' HP HQ; split=> x i ??; apply HQ, HP.
Qed.
Global Instance entails_anti_sym : AntiSymm (⊣⊢) (@uPred_entails M).
Proof. intros P Q HPQ HQP; split=> x n; by split; [apply HPQ|apply HQP]. Qed.

Lemma equiv_spec P Q : (P ⊣⊢ Q) ↔ (P ⊢ Q) ∧ (Q ⊢ P).
Proof.
  split; [|by intros [??]; apply (anti_symm (⊢))].
  intros HPQ; split; split=> x i; apply HPQ.
Qed.
Lemma equiv_entails P Q : (P ⊣⊢ Q) → (P ⊢ Q).
Proof. apply equiv_spec. Qed.
Lemma equiv_entails_sym P Q : (Q ⊣⊢ P) → (P ⊢ Q).
Proof. apply equiv_spec. Qed.
Global Instance entails_proper :
  Proper ((⊣⊢) ==> (⊣⊢) ==> iff) ((⊢) : relation (uPred M)).
Proof.
  move => P1 P2 /equiv_spec [HP1 HP2] Q1 Q2 /equiv_spec [HQ1 HQ2]; split; intros.
  - by trans P1; [|trans Q1].
  - by trans P2; [|trans Q2].
Qed.
Lemma entails_equiv_l (P Q R : uPred M) : (P ⊣⊢ Q) → (Q ⊢ R) → (P ⊢ R).
Proof. by intros ->. Qed.
Lemma entails_equiv_r (P Q R : uPred M) : (P ⊢ Q) → (Q ⊣⊢ R) → (P ⊢ R).
Proof. by intros ? <-. Qed.

Lemma entails_lim (cP cQ : chain (uPredC M)) :
  (∀ n, cP n ⊢ cQ n) → compl cP ⊢ compl cQ.
Proof.
  intros Hlim; split=> n m ? HP.
  eapply uPred_holds_ne, Hlim, HP; eauto using conv_compl.
Qed.

Lemma limit_preserving_entails `{Cofe A} (Φ Ψ : A → uPred M) :
  NonExpansive Φ → NonExpansive Ψ → LimitPreserving (λ x, Φ x ⊢ Ψ x).
Proof. intros HΦ HΨ c Hc. rewrite -!compl_chain_map /=. by apply entails_lim. Qed.
End entails.
End uPred.