(** * Finite Modular Maps : RBT Proofs *)

(** This is a complement to [Tries.MMaps.RBT], proving the Red/Black balancing
    invariants for the code in [Tries.MMaps.RBT], and hence the logarithmic
    depth bound. These extra proofs are not even loaded during a regular
    usage of [Tries.MMaps.RBT], which already provides proofs of observational
    correctness (the binary search tree invariants).

    This is an adapation of Coq [MSetRBT.BalanceProps] to maps. *)

From Coq Require Import Bool BinPos Pnat Setoid SetoidList Arith.
From Coq Require Import Orders OrdersFacts OrdersLists.
From Tries.MMaps Require Import Interface GenTree RBT.

Local Set Implicit Arguments.
Local Unset Strict Implicit.
Import ListNotations.

(* For nicer extraction, we create inductive principles
   only when needed *)
Local Unset Elimination Schemes.

Module BalanceProps(K:OrderedType).
Include Tries.MMaps.RBT.MakeRaw K.
Import GenTree.PairNotations. (* #1 and #2 for fst and snd *)
Local Open Scope lazy_bool_scope.
Local Notation color := Color.t.
Local Arguments Leaf {elt}.
Local Notation Rd := (@Node _ Red).
Local Notation Bk := (@Node _ Black).

(** ** Red-Black invariants *)

(** In a red-black tree :
    - a red node has no red children
    - the black depth at each node is the same along all paths.
    The black depth is here an argument of the predicate. *)

Inductive rbt elt : nat -> tree elt -> Prop :=
 | RB_Leaf : rbt 0 Leaf
 | RB_Rd n l k e r :
   notred l -> notred r -> rbt n l -> rbt n r -> rbt n (Rd l k e r)
 | RB_Bk n l k e r : rbt n l -> rbt n r -> rbt (S n) (Bk l k e r).

(** A red-red tree is almost a red-black tree, except that it has
    a _red_ root node which _may_ have red children. Note that a
    red-red tree is hence non-empty, and all its strict subtrees
    are red-black. *)

Inductive rrt elt (n:nat) : tree elt -> Prop :=
 | RR_Rd l k e r : rbt n l -> rbt n r -> rrt n (Rd l k e r).

(** An almost-red-black tree is almost a red-black tree, except that
    it's permitted to have two red nodes in a row at the very root (only).
    We implement this notion by saying that a quasi-red-black tree
    is either a red-black tree or a red-red tree. *)

Inductive arbt elt (n:nat)(t:tree elt) : Prop :=
 | ARB_RB : rbt n t -> arbt n t
 | ARB_RR : rrt n t -> arbt n t.

(** The main exported invariant : being a red-black tree for some
    black depth. *)

Class Rbt elt (t:tree elt) :=  RBT : exists d, rbt d t.

(** ** Basic tactics and results about red-black *)

Scheme rbt_ind := Induction for rbt Sort Prop.
Local Hint Constructors rbt rrt arbt : map.
Local Hint Extern 0 (notred _) => (exact I) : map.
Ltac invrb := intros; inv rrt; inv rbt; try contradiction.
Ltac descolor := destruct_all Color.t.
Ltac destree t := destruct t as [|[|] ? ? ? ?].
Ltac desarb := match goal with H:arbt _ _ |- _ => destruct H end.
Ltac nonzero n := destruct n as [|n]; [try split; invrb|].

Notation notredred := (rrcase (fun _ _ _ _ _ _ _ => False) (fun _ => True)).

Section Elt.
Variable elt : Type.
Implicit Type t s l r : tree elt.
Implicit Type e v : elt.

Lemma rr_nrr_rb n t :
 rrt n t -> notredred t -> rbt n t.
Proof.
 destruct 1 as [l x e r Hl Hr].
 unfold rrcase; destmatch; now autom.
Qed.

Local Hint Resolve rr_nrr_rb : map.

Lemma arb_nrr_rb n t :
 arbt n t -> notredred t -> rbt n t.
Proof.
 destruct 1; autom.
Qed.

Lemma arb_nr_rb n t :
 arbt n t -> notred t -> rbt n t.
Proof.
 destruct 1; destruct t; descolor; invrb; autom.
Qed.

Local Hint Resolve arb_nrr_rb arb_nr_rb : map.

(** ** A Red-Black tree has indeed a logarithmic depth *)

Definition redcarac s :=
 rcase (elt:=elt) (fun _ _ _ _ => 1) (fun _ => 0) s.

Lemma rb_maxdepth s n : rbt n s -> maxdepth s <= 2*n + redcarac s.
Proof.
 induction 1.
 - simpl; auto.
 - replace (redcarac l) with 0 in * by now destree l.
   replace (redcarac r) with 0 in * by now destree r.
   simpl maxdepth. simpl redcarac.
   rewrite Nat.add_succ_r, <- Nat.succ_le_mono.
   now apply Nat.max_lub.
 - simpl. rewrite <- Nat.succ_le_mono.
   apply Nat.max_lub; eapply Nat.le_trans; eauto;
   [destree l | destree r]; simpl;
   rewrite !Nat.add_0_r, ?Nat.add_1_r; auto with arith.
Qed.

Lemma rb_mindepth s n : rbt n s -> n + redcarac s <= mindepth s.
Proof.
 induction 1; simpl.
 - trivial.
 - rewrite Nat.add_succ_r.
   apply -> Nat.succ_le_mono.
   replace (redcarac l) with 0 in * by now destree l.
   replace (redcarac r) with 0 in * by now destree r.
   now apply Nat.min_glb.
 - apply -> Nat.succ_le_mono. rewrite Nat.add_0_r.
   apply Nat.min_glb; eauto with arith.
Qed.

Lemma maxdepth_upperbound s : Rbt s ->
 maxdepth s <= 2 * Nat.log2 (S (cardinal s)).
Proof.
 intros (n,H).
 eapply Nat.le_trans; [eapply rb_maxdepth; eauto|].
 transitivity (2*(n+redcarac s)).
 - rewrite Nat.mul_add_distr_l. apply Nat.add_le_mono_l.
   rewrite <- Nat.mul_1_l at 1. apply Nat.mul_le_mono_r.
   auto with arith.
 - apply Nat.mul_le_mono_l.
   transitivity (mindepth s).
   + now apply rb_mindepth.
   + apply mindepth_log_cardinal.
Qed.

Lemma maxdepth_lowerbound s : s<>Leaf ->
 Nat.log2 (cardinal s) < maxdepth s.
Proof.
 apply maxdepth_log_cardinal.
Qed.

(** ** Singleton *)

Lemma singleton_rb x e : Rbt (singleton x e).
Proof.
 unfold singleton. exists 1; autom.
Qed.

(** ** [makeBlack] and [makeRed] *)

Lemma makeBlack_rb n t : arbt n t -> Rbt (makeBlack t).
Proof.
 destruct t as [|[|] l x e r].
 - exists 0; simpl; autom.
 - destruct 1; invrb; exists (S n); simpl; autom.
 - exists n; autom.
Qed.

Lemma makeRed_rr t n :
 rbt (S n) t -> notred t -> rrt n (makeRed t).
Proof.
 destruct t as [|[|] l x e r]; invrb; simpl; autom.
Qed.

(** ** Balancing *)

Lemma lbal_rb n l k e r :
 arbt n l -> rbt n r -> rbt (S n) (lbal l k e r).
Proof.
case lbal_match; intros; desarb; invrb; autom.
Qed.

Lemma rbal_rb n l k e r :
 rbt n l -> arbt n r -> rbt (S n) (rbal l k e r).
Proof.
case rbal_match; intros; desarb; invrb; autom.
Qed.

Lemma rbal'_rb n l k e r :
 rbt n l -> arbt n r -> rbt (S n) (rbal' l k e r).
Proof.
case rbal'_match; intros; desarb; invrb; autom.
Qed.

Lemma lbalS_rb n l x e r :
 arbt n l -> rbt (S n) r -> notred r -> rbt (S n) (lbalS l x e r).
Proof.
 intros Hl Hr Hr'.
 destruct r as [|[|] rl rx rv rr]; invrb. clear Hr'.
 revert Hl.
 case lbalS_match.
 - destruct 1; invrb; autom.
 - intros. apply rbal'_rb; autom.
Qed.

Lemma lbalS_arb n l x e r :
 arbt n l -> rbt (S n) r -> arbt (S n) (lbalS l x e r).
Proof.
 case lbalS_match.
 - destruct 1; invrb; autom.
 - clear l. intros l Hl Hl' Hr.
   destruct r as [|[|] rl rx rv rr]; invrb.
   * destruct rl as [|[|] rll rlx rlv rlr]; invrb.
     right; auto using rbal'_rb, makeRed_rr with map.
   * left; apply rbal'_rb; autom.
Qed.

Lemma rbalS_rb n l x e r :
 rbt (S n) l -> notred l -> arbt n r -> rbt (S n) (rbalS l x e r).
Proof.
 intros Hl Hl' Hr.
 destruct l as [|[|] ll lx lv lr]; invrb. clear Hl'.
 revert Hr.
 case rbalS_match.
 - destruct 1; invrb; autom.
 - intros. apply lbal_rb; autom.
Qed.

Lemma rbalS_arb n l x e r :
 rbt (S n) l -> arbt n r -> arbt (S n) (rbalS l x e r).
Proof.
 case rbalS_match.
 - destruct 2; invrb; autom.
 - clear r. intros r Hr Hr' Hl.
   destruct l as [|[|] ll lx lv lr]; invrb.
   * destruct lr as [|[|] lrl lrx lrv lrr]; invrb.
     right; auto using lbal_rb, makeRed_rr with map.
   * left; apply lbal_rb; autom.
Qed.

(** ** Insertion *)

(** The next lemmas combine simultaneous results about rbt and arbt.
    A first solution here: statement with [if ... then ... else] *)

Definition ifred s (A B:Prop) := rcase (fun _ _ _ _ => A) (fun _ => B) s.

Lemma ifred_notred s A B : notred s -> (ifred s A B <-> B).
Proof.
 destruct s; descolor; simpl; intuition.
Qed.

Lemma ifred_or s A B : ifred s A B -> A\/B.
Proof.
 destruct s; descolor; simpl; intuition.
Qed.

Lemma ins_rr_rb x e s n : rbt n s ->
 ifred s (rrt n (ins x e s)) (rbt n (ins x e s)).
Proof.
induction 1 as [ | n l k v r | n l k v r Hl IHl Hr IHr ].
- simpl; autom.
- simpl. rewrite ifred_notred in * by trivial.
  destmatch; autom.
- rewrite ifred_notred by autom.
  cbn. destmatch; intro.
  * autom.
  * apply lbal_rb; trivial. apply ifred_or in IHl; intuition.
  * apply rbal_rb; trivial. apply ifred_or in IHr; intuition.
Qed.

Lemma ins_arb x e s n : rbt n s -> arbt n (ins x e s).
Proof.
 intros H. apply (ins_rr_rb x e), ifred_or in H. intuition.
Qed.

Instance add_rb x e s : Rbt s -> Rbt (add x e s).
Proof.
 intros (n,H). unfold add. now apply (@makeBlack_rb n), ins_arb.
Qed.

(** ** Deletion *)

(*TODO: share with RBT *)

Ltac append_tac l r :=
 induction l as [| lc ll _ lx lv lr IHlr];
 [intro r; simpl
 |induction r as [| rc rl IHrl rx rv rr _];
   [simpl
   |destruct lc, rc;
     [specialize (IHlr rl); clear IHrl
     |simpl;
      assert (Hr:notred (Bk rl rx rv rr)) by (simpl; trivial);
      set (r:=Bk rl rx rv rr) in *; clearbody r; clear IHrl rl rx rv rr;
      specialize (IHlr r)
     |change (append _ _) with (Rd (append (Bk ll lx lv lr) rl) rx rv rr);
      assert (Hl:notred (Bk ll lx lv lr)) by (simpl; trivial);
      set (l:=Bk ll lx lv lr) in *; clearbody l; clear IHlr ll lx lv lr
     |specialize (IHlr rl); clear IHrl]]].

Fact append_rr_match ll lx lv lr rl rx rv rr :
 rspec
  (fun a x e b => Rd (Rd ll lx lv a) x e (Rd b rx rv rr))
  (fun t => Rd ll lx lv (Rd t rx rv rr))
  (append lr rl)
  (append (Rd ll lx lv lr) (Rd rl rx rv rr)).
Proof.
 exact (rmatch _ _ _).
Qed.

Fact append_bb_match ll lx lv lr rl rx rv rr :
 rspec
  (fun a x e b => Rd (Bk ll lx lv a) x e (Bk b rx rv rr))
  (fun t => lbalS ll lx lv  (Bk t rx rv rr))
  (append lr rl)
  (append (Bk ll lx lv lr) (Bk rl rx rv rr)).
Proof.
 exact (rmatch _ _ _).
Qed.

(** A second approach here: statement with ... /\ ... *)

Lemma append_arb_rb n l r : rbt n l -> rbt n r ->
 (arbt n (append l r)) /\
 (notred l -> notred r -> rbt n (append l r)).
Proof.
revert r n.
append_tac l r.
- split; autom.
- split; autom.
- (* Red / Red *)
  intros n. invrb.
  case (IHlr n); auto; clear IHlr.
  case append_rr_match.
  + intros a x v b _ H; split; invrb.
    assert (rbt n (Rd a x v b)) by autom. invrb. autom.
  + split; invrb; autom.
- (* Red / Black *)
  split; invrb. destruct (IHlr n) as (_,IH); autom.
- (* Black / Red *)
  split; invrb. destruct (IHrl n) as (_,IH); autom.
- (* Black / Black *)
  nonzero n.
  invrb.
  destruct (IHlr n) as (IH,_); auto; clear IHlr.
  revert IH.
  case append_bb_match.
  + intros a x v b IH; split; destruct IH; invrb; autom.
  + split; [left | invrb]; auto using lbalS_rb with map.
Qed.

Ltac induct' m :=
 induction m as [|c l IHl x' vx' r IHr]; simpl; intros;
 [|case K.compare_spec; intros].

(** A third approach : Lemma ... with ... *)

Lemma del_arb s x n : rbt (S n) s -> isblack s -> arbt n (del x s)
with del_rb s x n : rbt n s -> notblack s -> rbt n (del x s).
Proof.
{ revert n.
  induct' s; descolor; try easy; invrb.
  - apply append_arb_rb; assumption.
  - assert (IHl' := del_rb l x). clear IHr del_arb del_rb.
    destruct l as [|[|] ll lx lv lr]; autom.
    nonzero n. apply lbalS_arb; autom.
  - assert (IHr' := del_rb r x). clear IHl del_arb del_rb.
    destruct r as [|[|] rl rx rv rr]; autom.
    nonzero n. apply rbalS_arb; auto. }
{ revert n.
  induct' s; descolor; try easy; invrb.
  - apply append_arb_rb; assumption.
  - assert (IHl' := del_arb l x). clear IHr del_arb del_rb.
    destruct l as [|[|] ll lx lv lr]; autom.
    nonzero n. destruct n as [|n]; [invrb|]; apply lbalS_rb; autom.
  - assert (IHr' := del_arb r x). clear IHl del_arb del_rb.
    destruct r as [|[|] rl rx rv rr]; autom.
    nonzero n. apply rbalS_rb; auto. }
Qed.

Instance remove_rb s x : Rbt s -> Rbt (remove x s).
Proof.
 intros (n,H). unfold remove.
 destruct s as [|[|] l y v r].
 - apply (@makeBlack_rb n). autom.
 - apply (@makeBlack_rb n). left. apply del_rb; simpl; autom.
 - nonzero n. apply (@makeBlack_rb n). apply del_arb; simpl; autom.
Qed.

(** ** Treeify *)

Local Notation ifpred p n := (if p then pred n else n%nat).
Local Notation treeify_t := (klist elt -> tree elt * klist elt).

Definition treeify_rb_invariant size depth (f:treeify_t) :=
 forall acc,
 size <= length acc ->
  rbt depth (fst (f acc)) /\
  size + length (snd (f acc)) = length acc.

Lemma treeify_zero_rb : treeify_rb_invariant 0 0 (@treeify_zero elt).
Proof.
 intros acc _; simpl; autom.
Qed.

Lemma treeify_one_rb : treeify_rb_invariant 1 0 (@treeify_one elt).
Proof.
 intros [|(x,e) acc]; simpl; autom; inversion 1.
Qed.

Lemma treeify_cont_rb f g size1 size2 size d :
 treeify_rb_invariant size1 d f ->
 treeify_rb_invariant size2 d g ->
 size = S (size1 + size2) ->
 treeify_rb_invariant size (S d) (treeify_cont f g).
Proof.
 intros Hf Hg H acc Hacc.
 unfold treeify_cont.
 specialize (Hf acc).
 destruct (f acc) as (l, acc1). simpl in *.
 destruct Hf as (Hf1, Hf2). { subst. eauto with arith. }
 destruct acc1 as [|(x,e) acc2]; simpl in *.
 - exfalso. revert Hacc. apply Nat.lt_nge. rewrite H, <- Hf2.
   auto with arith.
 - specialize (Hg acc2).
   destruct (g acc2) as (r, acc3). simpl in *.
   destruct Hg as (Hg1, Hg2).
   { revert Hacc.
     rewrite H, <- Hf2, Nat.add_succ_r, <- Nat.succ_le_mono.
     apply Nat.add_le_mono_l. }
   split; autom.
   now rewrite H, <- Hf2, <- Hg2, Nat.add_succ_r, Nat.add_assoc.
Qed.

Lemma treeify_aux_rb n :
 exists d, forall (b:bool),
  treeify_rb_invariant (ifpred b (Pos.to_nat n)) d (treeify_aux b n).
Proof.
 induction n as [n (d,IHn)|n (d,IHn)| ].
 - exists (S d). intros b.
   eapply treeify_cont_rb; [ apply (IHn false) | apply (IHn b) | ].
   rewrite Pos2Nat.inj_xI.
   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
   destruct b; simpl; intros; rewrite Nat.add_0_r; trivial.
   now rewrite <- Nat.add_succ_r, Nat.succ_pred; trivial.
 - exists (S d). intros b.
   eapply treeify_cont_rb; [ apply (IHn b) | apply (IHn true) | ].
   rewrite Pos2Nat.inj_xO.
   assert (H := Pos2Nat.is_pos n). apply Nat.neq_0_lt_0 in H.
   rewrite <- Nat.add_succ_r, Nat.succ_pred by trivial.
   destruct b; simpl; intros; rewrite Nat.add_0_r; trivial.
   symmetry. now apply Nat.add_pred_l.
 - exists 0; destruct b;
    [ apply treeify_zero_rb | apply treeify_one_rb ].
Qed.

(** The black depth of [treeify l] is actually a log2, but
    we don't need to mention that. *)

Instance treeify_rb (l:klist elt) : Rbt (treeify l).
Proof.
 unfold treeify.
 destruct (treeify_aux_rb (plength l)) as (d,H).
 exists d.
 apply H.
 now rewrite plength_spec.
Qed.

Instance filter_rb (f:key->elt->bool) m : Rbt m -> Rbt (filter f m).
Proof.
 unfold filter. intros. apply treeify_rb.
Qed.

Instance partition_rb1 (f:key->elt->bool) m :
 Rbt m -> Rbt (fst (partition f m)).
Proof.
 unfold partition. intros. destruct partition_aux. apply treeify_rb.
Qed.

Instance partition_rb2 (f:key->elt->bool) m :
 Rbt m -> Rbt (snd (partition f m)).
Proof.
 unfold partition. intros. destruct partition_aux. apply treeify_rb.
Qed.

End Elt.

Instance map_rb {elt elt'}(f:elt->elt') m : Rbt m -> Rbt (map f m).
Proof.
 intros (n,H). exists n. induction H; simpl; constructor; auto.
 destruct l; auto.
 destruct r; auto.
Qed.

Instance mapi_rb {elt elt'}(f:key->elt->elt') m : Rbt m -> Rbt (mapi f m).
Proof.
 intros (n,H). exists n. induction H; simpl; constructor; auto.
 destruct l; auto.
 destruct r; auto.
Qed.

Instance merge_rb {elt elt' elt''}
 (f:key -> option elt -> option elt' -> option elt'') m m' :
 Rbt m -> Rbt m' -> Rbt (merge f m m').
Proof.
 unfold merge. intros. apply treeify_rb.
Qed.

End BalanceProps.

(** We could hence define [Ok m] as [Bst m /\ Rbt m] and re-validate
    the [Raw.S] signature. This would be more robust in case new ops
    are added in the signature. But that would be yet another wrapper,
    so we don't do it for the moment. *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sets                                                                    *
**************************************************************************)

Set Implicit Arguments.
Generalizable Variables A B.
Require Import LibTactics LibLogic LibReflect LibList
  LibOperation LibStruct LibInt LibNat LibEpsilon.
Require Export LibBag.

(* ********************************************************************** *)
(** * Construction of sets as predicates *)

(* ---------------------------------------------------------------------- *)
(** ** Basic definitions *)

Definition set (A : Type) := A -> Prop.

Section Operations.
Variables (A B : Type).
Implicit Types x : A.
Implicit Types E F G : set A.

Definition set_st (P:A->Prop) : set A := P.
Definition empty_impl : set A := (fun _ => False).
Definition full_impl : set A := (fun _ => True).
Definition single_impl x := (= x).
Definition in_impl x E := E x.
Definition compl_impl : set A -> set A := @pred_not A. (* todo: as typeclass? *)
Definition union_impl : set A -> set A -> set A := @pred_or A.
Definition inter_impl : set A -> set A -> set A := @pred_and A.
Definition remove_impl : set A -> set A -> set A :=
  fun E F x => E x /\ ~ F x.
Definition incl_impl : set A -> set A -> Prop := @pred_le A.
Definition list_repr_impl (E:set A) (l:list A) :=
  No_duplicates l /\ forall x, Mem x l <-> E x.
Definition to_list (E:set A) := epsilon (list_repr_impl E).
Definition finite (E:set A) := exists l, list_repr_impl E l.
Definition card_impl (E:set A) := LibList.length (to_list E).
Definition fold_impl (m:monoid_def B) (f:A->B) (E:set A) :=
  LibList.fold_right (fun x acc => monoid_oper m (f x) acc)
    (monoid_neutral m) (to_list E).

End Operations.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited *)

Instance set_inhab : forall A, Inhab (set A).
Proof using. intros. apply (prove_Inhab (@empty_impl A)). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Notation through typeclasses *)

Lemma in_inst : forall A, BagIn A (set A).
Proof using. constructor. exact (@in_impl A). Defined.
Hint Extern 1 (BagIn _ (set _)) => apply in_inst : typeclass_instances.
(* TODO: why is this not an instance like others ? *)

Instance empty_inst : forall A, BagEmpty (set A).
  constructor. apply (@empty_impl A). Defined.
Instance single_inst : forall A, BagSingle A (set A).
  constructor. rapply (@single_impl A). Defined.
Instance union_inst : forall A, BagUnion (set A).
  constructor. rapply (@union_impl A). Defined.
Instance inter_inst : forall A, BagInter (set A).
  constructor. rapply (@inter_impl A). Defined.
Instance remove_inst : forall A, BagRemove (set A) (set A).
  constructor. rapply (@remove_impl A). Defined.
Instance incl_inst : forall A, BagIncl (set A).
  constructor. rapply (@incl_impl A). Defined.
Instance disjoint_inst : forall A, BagDisjoint (set A).
  constructor. rapply (fun E F : set A => E \n F = \{}). Defined.
Instance fold_inst : forall A B, BagFold B (A->B) (set A).
  constructor. rapply (@fold_impl A B). Defined.
Instance card_inst : forall A, BagCard (set A).
  constructor. rapply (@card_impl A). Defined.

Global Opaque set finite in_inst empty_inst single_inst union_inst inter_inst
  remove_inst incl_inst disjoint_inst card_inst fold_inst.

(* ---------------------------------------------------------------------- *)
(** ** Notations for building sets *)

Notation "\set{ x | P }" := (@set_st _ (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x : A | P }" := (@set_st A (fun x => P))
 (at level 0, x ident, P at level 200) : set_scope.
Notation "\set{ x '\in' E | P }" := (@set_st _ (fun x => x \in E /\ P))
 (at level 0, x ident, P at level 200) : set_scope.

Notation "\set{= e | x '\in' E }" :=
 (@set_st _ (fun a => exists_ x \in E, a = e ))
 (at level 0, x ident, E at level 200) : set_scope.
Notation "\set{= e | x '\in' E , y ''\in' F }" :=
 (@set_st _ (fun a => exists_ x \in E, exists_ y \in F, a = e ))
 (at level 0, x ident, F at level 200) : set_scope.
Notation "\set{= e | x y '\in' E }" :=
 (@set_st _ (fun a => exists_ x y \in E, a = e ))
 (at level 0, x ident, y ident, E at level 200) : set_scope.

(* ********************************************************************** *)
(** * Properties of sets *)

Section Instances.
Variables (A:Type).
Transparent set finite empty_inst single_inst single_impl in_inst
  incl_inst inter_inst union_inst card_inst fold_inst remove_inst
  disjoint_inst.
Hint Constructors Mem.

Ltac unf := unfold finite,
  card_inst, card_impl, card,
  to_list,
  disjoint_inst, disjoint,
  incl_inst, incl_impl,
  empty_inst, empty_impl, empty,
  single_inst, single_impl, single,
  in_inst, in_impl, is_in,
  incl_inst, incl_impl, incl,
  compl_impl, pred_not,
  inter_inst, inter_impl, inter, pred_and,
  union_inst, union_impl, union, pred_or,
  remove_inst, remove_impl, remove,
  fold_inst, fold_impl, fold in *.

(* ---------------------------------------------------------------------- *)
(** set_st *)

Lemma in_set_st_eq : forall A (P:A->Prop) x,
  x \in set_st P = P x.
Proof using. intros. apply* prop_ext. Qed.

(* ---------------------------------------------------------------------- *)
(** to_list *)

Lemma to_list_spec : forall (E:set A) L,
  L = to_list E -> finite E -> No_duplicates L /\ (forall x, Mem x L <-> x \in E).
Proof.
  intros. unfolds to_list, finite. spec_epsilon~ as L' (HL'&EL'). subst*.
Qed.

Lemma to_list_empty :
  to_list (\{}:set A) = nil.
Proof using.
  unf. spec_epsilon as l.
  exists (@nil A). split. constructor. iff; false_invert.
  inverts Hl. simpls. destruct~ l. false. rewrite <- H0. simple~.
Qed.

Lemma to_list_single : forall (x:A),
  to_list (\{x}) = x::nil.
Proof using.
  intros. unfold to_list. spec_epsilon as l.
    exists (x::nil). split.
      constructor*. introv M. inverts M.
      unfold single_inst, single_impl. simple~.
       iff H. inverts* H. inverts* H1. inverts* H.
  unfolds single_inst, single_impl. simpls~.
  inverts Hl as H H0. destruct (H0 x). specializes~ H2.
  destruct l.
    inverts H2.
    tests E: (x = a).
      fequals. destruct l. auto. forwards~: (proj1 (H0 a0)).
       subst. inverts H as M1 M2. false* M1.
      inverts H2. false. forwards~: (proj1 (H0 a)). false.
Qed.

(* ---------------------------------------------------------------------- *)
(** finite *)

Lemma finite_prove : forall A (E:set A) L,
  (forall x, x \in E -> Mem x L) -> finite E.
Proof using.
  introv M. sets_eq L1 EQL1: (Remove_duplicates L).
  forwards~ (HN&HM): Remove_duplicates_spec EQL1.
  sets L2: (Filter (fun x => x \in E) L1).
  exists L2. split.
    applys* Filter_No_duplicates.
    intros x. specializes M x. rewrite <- HM in M. unf. iff N.
      subst L2. forwards*: Filter_Mem_inv N.
      applys* Filter_Mem.
Qed.

Lemma finite_prove_exists : forall A (E:set A),
  (exists L, forall x, x \in E -> Mem x L) -> finite E.
Proof using. introv (L&H). applys* finite_prove. Qed.

Lemma finite_inv_basic : forall A (E:set A),
  finite E -> exists L, (forall x, x \in E -> Mem x L).
Proof using. introv (L&HN&HM). exists L. intros. applys* HM. Qed.

Lemma finite_empty : forall A,
  finite (\{} : set A).
Proof using.
  intros. apply finite_prove_exists. unf.
  exists (@nil A0). introv M. inverts M.
Qed.

Lemma finite_singleton : forall A (a : A),
  finite \{a}.
Proof using.
  intros. apply finite_prove_exists. unf.
  exists (a::nil). introv M. hnf in M. subst*.
Qed.

Lemma finite_union : forall A (E F : set A),
  finite E ->
  finite F ->
  finite (E \u F).
Proof using.
  introv H1 H2. apply finite_prove_exists.
  lets (L1&E1): finite_inv_basic H1.
  lets (L2&E2): finite_inv_basic H2.
  exists (L1++L2). unf. introv M. rewrite* Mem_app_or_eq.
Qed.

Lemma finite_inter : forall A (E F : set A),
  finite E \/ finite F ->
  finite (E \n F).
Proof using.
  introv H. apply finite_prove_exists. destruct H.
  lets (L&EQ): finite_inv_basic H. exists L. unf. autos*.
  lets (L&EQ): finite_inv_basic H. exists L. unf. autos*.
Qed.

Lemma finite_incl : forall A (E F : set A),
  E \c F ->
  finite F ->
  finite E.
Proof using.
  introv HI HF. apply finite_prove_exists.
  lets (L&EQ): finite_inv_basic HF. unf. exists* L.
Qed.

Lemma finite_remove : forall A (E F : set A),
  finite E ->
  finite (E \- F).
Proof using.
  introv HE. apply finite_prove_exists.
  lets (L&EQ): finite_inv_basic HE. unf. exists* L.
Qed.

(* ---------------------------------------------------------------------- *)
(** fold *)

Lemma fold_empty : forall B m (f:A->B),
  fold m f (\{}:set A) = monoid_neutral m.
Proof using.
  intros. unfold fold_inst, fold_impl, fold.
  rewrite to_list_empty. rewrite~ fold_right_nil.
Qed.

Lemma fold_single : forall B (m:monoid_def B) (f:A->B) (x:A),
  Monoid m -> fold m f \{x} = f x.
Proof using.
  intros. unfold fold_inst, fold_impl, fold.
  rewrite to_list_single. rewrite~ fold_right_cons.
  rewrite fold_right_nil. rewrite monoid_neutral_r. auto.
Qed.

Lemma fold_union : forall B (m:monoid_def B) (f:A->B) (E F : set A),
  Monoid m ->
  finite E ->
  finite F ->
  E \# F ->
  fold m f (E \u F) = monoid_oper m (fold m f E) (fold m f F).
Proof using.
  intros. unfold fold, fold_inst, fold_impl.
  admit. (* todo: under development *)
Qed.

(* ---------------------------------------------------------------------- *)
(** double inclusion *)

Lemma set_ext_eq : forall (E F : set A),
  (E = F) = (forall (x:A), x \in E <-> x \in F).
Proof using.
  intros. apply prop_ext. iff H. subst*. apply* prop_ext_1.
Qed.

Lemma set_ext : forall (E F : set A),
  (forall (x:A), x \in E <-> x \in F) -> E = F.
Proof using. intros. rewrite~ set_ext_eq. Qed.

(* ---------------------------------------------------------------------- *)
(** set_in, incl *)

Global Instance in_extens_inst : In_extens (A:=A) (T:=set A).
Proof using. constructor. intros. rewrite* set_ext_eq. Qed.

Global Instance in_empty_eq_inst : In_empty_eq (A:=A) (T:=set A).
Proof using. constructor. intros. apply* prop_ext. Qed.

Global Instance in_single_eq_inst : In_single_eq (A:=A) (T:=set A).
Proof using. constructor. intros. apply* prop_ext. Qed.

Global Instance in_union_eq_inst : In_union_eq (A:=A) (T:=set A).
Proof using. constructor. intros. unf. apply* prop_ext. Qed.

Global Instance in_inter_eq_inst : In_inter_eq (A:=A) (T:=set A).
Proof using. constructor. intros. unf. apply* prop_ext. Qed.

Global Instance in_remove_eq_inst : In_remove_eq (A:=A) (T:=set A).
Proof using. constructor. intros. unf. applys* prop_ext. Qed.

Global Instance incl_in_eq_inst : Incl_in_eq (A:=A) (T:=set A).
Proof using. constructor. intros. unf. autos*. Qed.

Global Instance disjoint_eq_inst : Disjoint_eq (T:=set A).
Proof using.
  constructor. intros. unf. applys prop_ext. iff M.
    intros x. rewrite* <- (@func_same_1 _ _ x _ _ M).
    applys* prop_ext_1.
Qed.

(* ---------------------------------------------------------------------- *)
(** card *)

(* TODO: prove that
  card E = min_of (fun n => exists L, covers L E /\ n = length L)
  where covers L E = forall_ x \in E, Mem x L
*)

Lemma card_is_length_to_list : forall (E:set A),
  finite E -> card E = length (to_list E).
Proof using. introv HF. unf. spec_epsilon* as L'. Qed.

Global Instance card_empty_inst : Card_empty (T:=set A).
Proof using.
  constructor. lets E: to_list_empty. unf. rewrite E. rew_list~.
Qed.

Global Instance card_single_inst : Card_single (T:=set A).
Proof using.
  constructor. intros a. lets E: to_list_single a. unf. rewrite E. rew_list~.
Qed.

Lemma set_card_union_le : forall (E F:set A),
  finite E -> finite F ->
  card (E \u F) <= (card E + card F)%nat.
Proof using.
  Local Opaque union. hint finite_union.
  introv FE FF. do 3 rewrite~ card_is_length_to_list.
  forwards~ (NE&HE): to_list_spec E.
  forwards~ (NF&HF): to_list_spec F.
  forwards~ (NG&HG): to_list_spec (E \u F).
  sets LE: (to_list E). sets LF: (to_list F).
  sets G: (E \u F). sets LG: (to_list G).
  asserts RG: (forall x : A, Mem x LG <-> (x \in E \/ x \in F)).
    intros. specializes HG x. subst G. rewrite in_union_eq in HG. auto.
  clear HG. clearbody LG.
  forwards~ M: No_duplicates_length_le LG (LE ++ LF).
   introv N. apply Mem_app_or. rewrite HE, HF. rewrite <- RG. auto.
  rew_length in M. auto.
  Transparent union. (* should not be needed *)
Qed.

(* ---------------------------------------------------------------------- *)
(** structural decomposition *)

Lemma set_isolate : forall (E : set A) x,
  x \in E ->
  E = \{x} \u (E \- \{x}).
Proof using.
  introv H. unf. apply prop_ext_1. intros y. iff M.
    tests*: (y = x).
    destruct M. subst*. autos*.
Qed.

End Instances.

(* ---------------------------------------------------------------------- *)
(** ** Structural properties *)

(** Rewriting tactics *)

Hint Rewrite in_set_st_eq : rew_set.
Tactic Notation "rew_set" :=
  autorewrite with rew_set.
Tactic Notation "rew_set" "in" hyp(H) :=
  autorewrite with rew_set in H.
Tactic Notation "rew_set" "in" "*" :=
  autorewrite with rew_set in *.

(* ********************************************************************** *)
(** * Additional predicates on sets *)

(* ---------------------------------------------------------------------- *)
(** ** Foreach *)

(** TODO: derive these lemmas as typeclasses in a generic way in LibBag *)

Section ForeachProp.
Variables (A : Type).
Implicit Types P Q : A -> Prop.
Implicit Types E F : set A.

Lemma foreach_empty : forall P,
  @foreach A (set A) _ P \{}.
Proof using. intros_all. false. Qed.
(* TODO: false* @in_empty. typeclass. *)

Lemma foreach_single : forall P X,
  P X -> @foreach A (set A) _ P (\{ X }).
Proof using. intros_all. rewrite in_single_eq in H0. subst*. Qed.

Lemma foreach_union : forall P E F,
  foreach P E -> foreach P F -> foreach P (E \u F).
Proof using. intros_all. destruct~ (in_union_inv H1). Qed.

Lemma foreach_union_inv : forall P E F,
  foreach P (E \u F) -> foreach P E /\ foreach P F.
Proof using.
  introv H. split; introv K.
  apply H. rewrite~ @in_union_eq. typeclass.
  apply H. rewrite~ @in_union_eq. typeclass.
Qed.

Lemma foreach_union_eq : forall P E F,
  foreach P (E \u F) = (foreach P E /\ foreach P F).
Proof using.
  intros. extens. iff.
  apply~ foreach_union_inv. apply* foreach_union.
Qed.

Lemma foreach_single_eq : forall P X,
  foreach P (\{X}:set A) = P X.
Proof using.
  intros. extens. iff.
  apply H. apply in_single_self.
  apply~ foreach_single.
Qed.

Lemma foreach_weaken : forall P Q E,
  foreach P E -> pred_le P Q -> foreach Q E.
Proof using. introv H L K. apply~ L. Qed.

Lemma foreach_remove_simple : forall P E F,
  foreach P E -> foreach P (E \- F).
Proof using. introv M H. applys M. rewrite in_remove_eq in H. autos*. Qed.

Lemma foreach_remove : forall P Q E F,
  foreach P E -> pred_le P (fun (x:A) => x \notin F -> Q x) -> foreach Q (E \- F).
Proof using. introv M H Px. rewrite in_remove_eq in Px. applys* H. Qed.

Lemma foreach_notin_prove : forall P x E,
  foreach P E -> ~ P x -> x \notin E.
Proof using. introv M N I. applys N. applys~ M. Qed.

End ForeachProp.

Hint Resolve foreach_empty foreach_single foreach_union.
Hint Rewrite foreach_union_eq foreach_single_eq : rew_foreach.

Tactic Notation "rew_foreach" :=
  autorewrite with rew_foreach.
Tactic Notation "rew_foreach" "in" hyp(H) :=
  autorewrite with rew_foreach in H.
Tactic Notation "rew_foreach" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_foreach).
  (* autorewrite with rew_foreach in *.  *)

Tactic Notation "rew_foreach" "~" :=
  rew_foreach; auto_tilde.
Tactic Notation "rew_foreach" "*" :=
  rew_foreach; auto_star.
Tactic Notation "rew_foreach" "~" "in" constr(H) :=
  rew_foreach in H; auto_tilde.
Tactic Notation "rew_foreach" "*" "in" constr(H) :=
  rew_foreach in H; auto_star.
Tactic Notation "rew_foreach" "~" "in" "*" :=
  rew_foreach in *; auto_tilde.
Tactic Notation "rew_foreach" "*" "in" "*" :=
  rew_foreach in *; auto_star.

(* ********************************************************************** *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove equalities on unions *)

(* Documentation appears further on *)

Lemma for_set_union_assoc : forall A, assoc (union (T:=set A)).
Proof using. intros. apply union_assoc. Qed.

Lemma for_set_union_comm : forall A, comm (union (T:=set A)).
Proof using. intros. apply union_comm. Qed.

Lemma for_set_union_empty_l : forall A (E:set A), \{} \u E = E.
Proof using. intros. apply union_empty_l. Qed.

Lemma for_set_union_empty_r : forall A (E:set A), E \u \{} = E.
Proof using. intros. apply union_empty_r. Qed.

Hint Rewrite <- for_set_union_assoc : rew_permut_simpl.
Hint Rewrite for_set_union_empty_l for_set_union_empty_r : rew_permut_simpl.
Ltac rew_permut_simpl :=
  autorewrite with rew_permut_simpl; try typeclass.
Ltac rews_permut_simpl :=
  autorewrite with rew_permut_simpl in *; try typeclass.

Section PermutationTactic.
Context (A:Type).
Implicit Types l : set A.

Lemma permut_get_1 : forall l1 l2,
  (l1 \u l2) = (l1 \u l2).
Proof using. intros. auto. Qed.

Lemma permut_get_2 : forall l1 l2 l3,
  (l1 \u l2 \u l3) = (l2 \u l1 \u l3).
Proof using. intros. apply union_comm_assoc. Qed.

Lemma permut_get_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l4) = (l2 \u l3 \u l1 \u l4).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_2.
Qed.

Lemma permut_get_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l5)
  = (l2 \u l3 \u l4 \u l1 \u l5).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_3.
Qed.

Lemma permut_get_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6)
  = (l2 \u l3 \u l4 \u l5 \u l1 \u l6).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_4.
Qed.

Lemma permut_get_6 : forall l1 l2 l3 l4 l5 l6 l7,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l1 \u l7).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_5.
Qed.

Lemma permut_get_7 : forall l1 l2 l3 l4 l5 l6 l7 l8,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l1 \u l8).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_6.
Qed.

Lemma permut_get_8 : forall l1 l2 l3 l4 l5 l6 l7 l8 l9,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l9)
  = (l2 \u l3 \u l4 \u l5 \u l6 \u l7 \u l8 \u l1 \u l9).
Proof using.
  intros. do 2 rewrite (union_assoc l2). apply permut_get_7.
Qed.

Lemma permut_cancel_1 : forall l1 l2,
  (l1 \u l1 \u l2) = l1 \u l2.
Proof using. intros. rewrite union_assoc. rewrite union_self. auto. Qed.

Lemma permut_cancel_2 : forall l1 l2 l3,
  (l1 \u l2 \u l1 \u l3) = (l1 \u l2 \u l3).
Proof using.
  intros. rewrite <- (@permut_get_2 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_3 : forall l1 l2 l3 l4,
  (l1 \u l2 \u l3 \u l1 \u l4) = (l1 \u l2 \u l3 \u l4).
Proof using.
  intros. rewrite <- (@permut_get_3 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_4 : forall l1 l2 l3 l4 l5,
    (l1 \u l2 \u l3 \u l4 \u l1 \u l5)
  = (l1 \u l2 \u l3 \u l4 \u l5).
Proof using.
  intros. rewrite <- (@permut_get_4 l1). apply permut_cancel_1.
Qed.

Lemma permut_cancel_5 : forall l1 l2 l3 l4 l5 l6,
    (l1 \u l2 \u l3 \u l4 \u l5 \u l1 \u l6)
  = (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using.
  intros. rewrite <- (@permut_get_5 l1). apply permut_cancel_1.
Qed.

Lemma permut_tactic_setup : forall l1 l2,
   (\{} \u l1 \u \{}) = (l2 \u \{}) -> l1 = l2.
Proof using. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_keep : forall l1 l2 l3 l4,
  ((l1 \u l2) \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = l4.
Proof using. intros. rews_permut_simpl. Qed.

Lemma permut_tactic_simpl : forall l1 l2 l3 l4,
  (l1 \u l3) = l4 ->
  (l1 \u (l2 \u l3)) = (l2 \u l4).
Proof using. intros. subst. apply permut_get_2. Qed.

Lemma permut_tactic_trans : forall l1 l2 l3,
  l3 = l2 -> l1 = l3 -> l1 = l2.
Proof using. intros. subst~. Qed.

End PermutationTactic.

(** [permut_lemma_get n] returns the lemma [permut_get_n]
    for the given value of [n] *)

Ltac permut_lemma_get n :=
  match nat_from_number n with
  | 1%nat => constr:(permut_get_1)
  | 2%nat => constr:(permut_get_2)
  | 3%nat => constr:(permut_get_3)
  | 4%nat => constr:(permut_get_4)
  | 5%nat => constr:(permut_get_5)
  end.

(** [permut_prepare] applies to a goal of the form [permut l l']
    and sets [l] and [l'] in the form [l1 \u l2 \u .. \u \{}],
    (some of the lists [li] are put in the form [x::\{}]). *)

Ltac permut_simpl_prepare :=
   rew_permut_simpl;
   apply permut_tactic_setup;
   repeat rewrite <- union_assoc.

(* todo : doc *)

Ltac cancel_all_dup l :=
  repeat first
    [ rewrite (permut_cancel_1 l)
    | rewrite (permut_cancel_2 l)
    | rewrite (permut_cancel_3 l)
    | rewrite (permut_cancel_4 l)
    | rewrite (permut_cancel_5 l) ].

Ltac permut_index_of l lcontainer :=
  match constr:(lcontainer) with
  | l \u _ => constr:(1)
  | _ \u l \u _ => constr:(2)
  | _ \u _ \u l \u _ => constr:(3)
  | _ \u _ \u _ \u l \u _ => constr:(4)
  | _ \u _ \u _ \u _ \u l \u _ => constr:(5)
  | _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(6)
  | _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(7)
  | _ \u _ \u _ \u _ \u _ \u _ \u _ \u l \u _ => constr:(8)
  | _ => constr:(0) (* not found *)
  end.

(** [permut_simplify] simplifies a goal of the form
    [permut l l'] where [l] and [l'] are lists built with
    concatenation and consing, by cancelling syntactically
    equal elements *)

Ltac permut_simpl_once :=
  match goal with
  | |- (_ \u \{}) = _ => fail 1
  | |- (_ \u (?l \u ?lr)) = ?l' =>
     cancel_all_dup l;
     match permut_index_of l l' with
     | 0 => apply permut_tactic_keep
     | ?n => let F := permut_lemma_get n in
            eapply permut_tactic_trans;
            [ eapply F; try typeclass
            | apply permut_tactic_simpl ]
     end
  end.

Ltac permut_simpl :=
  permut_simpl_prepare;
  repeat permut_simpl_once;
  rew_permut_simpl;
  try apply refl_equal.

(* TODO: move demos somewhere else *)

Section DemoSetUnion.
Variables (A:Type).

Lemma demo_set_union_permut_simpl_1 :
  forall l1 l2 l3 : set A,
  (l1 \u l2 \u l3 \u l1) = (l3 \u l2 \u l1).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_2 :
  forall
  (x:A) l1 l2 l3,
  (l1 \u \{x} \u l3 \u l2) = (l1 \u l2 \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  rew_permut_simpl.
Qed.

Lemma demo_set_union_permut_simpl_3 : forall (x y:A) l1 l1' l2 l3,
  l1 = l1' ->
  (l1 \u (\{x} \u l2) \u \{x} \u (\{y} \u l3)) = (\{y} \u (l1' \u l2) \u (\{x} \u l3)).
Proof using.
  intros.
  permut_simpl_prepare.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  permut_simpl_once.
  try permut_simpl_once.
  rew_permut_simpl.
Qed.

End DemoSetUnion.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to prove membership *)

(* TODO: doc & sort *)

Section InUnionGet.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_get_1 : forall x l1 l2,
  x \in l1 -> x \in (l1 \u l2).
Proof using. intros. apply in_union_l. auto. Qed.

Lemma in_union_get_2 : forall x l1 l2 l3,
  x \in l2 -> x \in (l1 \u l2 \u l3).
Proof using. intros. apply in_union_r. apply~ in_union_get_1. Qed.

Lemma in_union_get_3 : forall x l1 l2 l3 l4,
  x \in l3 -> x \in (l1 \u l2 \u l3 \u l4).
Proof using. intros. apply in_union_r. apply~ in_union_get_2. Qed.

Lemma in_union_get_4 : forall x l1 l2 l3 l4 l5,
  x \in l4 -> x \in (l1 \u l2 \u l3 \u l4 \u l5).
Proof using. intros. apply in_union_r. apply~ in_union_get_3. Qed.

Lemma in_union_get_5 : forall x l1 l2 l3 l4 l5 l6,
  x \in l5 -> x \in (l1 \u l2 \u l3 \u l4 \u l5 \u l6).
Proof using. intros. apply in_union_r. apply~ in_union_get_4. Qed.

End InUnionGet.

Implicit Arguments in_union_get_1 [A x l1 l2].
Implicit Arguments in_union_get_2 [A x l1 l2 l3].
Implicit Arguments in_union_get_3 [A x l1 l2 l3 l4].
Implicit Arguments in_union_get_4 [A x l1 l2 l3 l4 l5].
Implicit Arguments in_union_get_5 [A x l1 l2 l3 l4 l5 l6].

Ltac in_union_get :=
  match goal with H: ?x \in ?A |- ?x \in ?B =>
  match B with context [A] =>
  let go tt := first
        [ apply (in_union_get_1 H)
        | apply (in_union_get_2 H)
        | apply (in_union_get_3 H)
        | apply (in_union_get_4 H)
        | apply (in_union_get_5 H) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r B);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _ \u _) => in_union_get.

Section InUnionExtract.
Variables (A:Type).
Implicit Types l : set A.

Lemma in_union_extract_1 : forall x l1,
  x \in (\{x} \u l1).
Proof using. intros. apply in_union_get_1. apply in_single_self. Qed.

Lemma in_union_extract_2 : forall x l1 l2,
  x \in (l1 \u \{x} \u l2).
Proof using. intros. apply in_union_get_2. apply in_single_self. Qed.

Lemma in_union_extract_3 : forall x l1 l2 l3,
  x \in (l1 \u l2 \u \{x} \u l3).
Proof using. intros. apply in_union_get_3. apply in_single_self. Qed.

Lemma in_union_extract_4 : forall x l1 l2 l3 l4,
  x \in (l1 \u l2 \u l3 \u \{x} \u l4).
Proof using. intros. apply in_union_get_4. apply in_single_self. Qed.

Lemma in_union_extract_5 : forall x l1 l2 l3 l4 l5,
  x \in (l1 \u l2 \u l3 \u l4 \u \{x} \u l5).
Proof using. intros. apply in_union_get_5. apply in_single_self. Qed.

End InUnionExtract.

Ltac in_union_extract :=
  match goal with |- ?x \in ?A =>
  match A with context [\{x}] =>
  let go tt := first
        [ apply (in_union_extract_1)
        | apply (in_union_extract_2)
        | apply (in_union_extract_3)
        | apply (in_union_extract_4)
        | apply (in_union_extract_5) ] in
  first [ go tt
        | rewrite <- (for_set_union_empty_r A);
          repeat rewrite <- for_set_union_assoc;
          go tt ]
  end end.

Hint Extern 3 (_ \in _) => in_union_extract.

(* ---------------------------------------------------------------------- *)
(** ** Tactics to invert a membership hypothesis *)

(* TODO: doc & sort *)

Section InversionsTactic.
Context (A:Type).
Implicit Types l : set A.
Implicit Types x : A.
Lemma empty_eq_single_inv_1 : forall x l1 l2,
  l1 = l2 -> x \notin l1 -> x \in l2 -> False.
Proof using. intros. subst*. Qed.
Lemma empty_eq_single_inv_2 : forall x l1 l2,
  l1 = l2 -> x \notin l2 -> x \in l1 -> False.
Proof using. intros. subst*. Qed.
Lemma notin_empty : forall x,
  x \notin (\{}:set A).
Proof using. intros. unfold notin. rewrite in_empty_eq. auto. Qed.
End InversionsTactic.
Hint Resolve notin_empty.

Ltac in_union_meta :=
  match goal with
  | |- _ \in \{_} => apply in_single_self
  | |- _ \in \{_} \u _ => apply in_union_l; apply in_single_self
  | |- _ \in _ \u _ => apply in_union_r; in_union_meta
  end.

Ltac fset_inv_core_for H :=
  let go L :=
     false L; [ apply H
              | try apply notin_empty
              | instantiate; try in_union_meta ] in
  match type of H with
  | \{} = _ => go empty_eq_single_inv_1
  | _ = \{} => go empty_eq_single_inv_2
  | _ = _ => go empty_eq_single_inv_1
  end.

Tactic Notation "fset_inv" constr(H) :=
  fset_inv_core_for H.

Ltac fset_inv_core :=
  match goal with
  | |- \{} <> _ => let H := fresh in intro H; fset_inv H
  | |- _ <> \{} => let H := fresh in intro H; fset_inv H
  | H: \{} = _ |- _ => fset_inv H
  | H: _ = \{} |- _ => fset_inv H
  end.

Tactic Notation "fset_inv" :=
  fset_inv_core.

Section InUnionInv.
Variables (A:Type).
Implicit Types l : set A.

Lemma set_in_empty_inv : forall x,
  x \in (\{}:set A) -> False.
Proof using. introv. apply notin_empty. Qed.
Lemma set_in_single_inv : forall x y : A,
  x \in (\{y}:set A) -> x = y.
Proof using. intros. rewrite @in_single_eq in H. auto. typeclass. Qed.
Lemma set_in_union_inv : forall x l1 l2,
  x \in (l1 \u l2) -> x \in l1 \/ x \in l2.
Proof using. introv H. rewrite @in_union_eq in H. auto. typeclass. Qed.

End InUnionInv.

Implicit Arguments set_in_single_inv [A x y].
Implicit Arguments set_in_union_inv [A x l1 l2].

Ltac set_in_inv_base H M :=
  match type of H with
  | _ \in \{} => false; apply (@set_in_empty_inv _ _ H)
  | _ \in \{_} =>
    generalize (set_in_single_inv H); try clear H; intro_subst
  | _ \in _ \u _ =>
    let H' := fresh "TEMP" in
    destruct (set_in_union_inv H) as [H'|H'];
    try clear H; set_in_inv_base H' M
  | _ => rename H into M
  end.

Tactic Notation "set_in" constr(H) "as" ident(M) :=
  set_in_inv_base H M.
Tactic Notation "set_in" constr(H) :=
  let M := fresh "H" in set_in H as M.

(* ---------------------------------------------------------------------- *)
(** ** Tactic to prove two sets equal by double-inclusion *)

Tactic Notation "eq_set" :=
  let H := fresh "TEMP" in
  apply set_ext; iff H; set_in H; in_union_get.
Tactic Notation "eq_set" "*" :=
  eq_set; auto_star.

(* ---------------------------------------------------------------------- *)
(* ---------------------------------------------------------------------- *)

(* FUTURE
  (** Sets of sets *)

  (* todo: typeclass for bigunion and bigintersection *)

  Definition bigunion_impl A (E : set (set A)) : set A :=
    \set{ x | exists_ F \in E, x \in (F:set A) }.

  Definition biguinter_impl A (E : set (set A)) : set A :=
    \set{ x | forall_ F \in E, x \in (F:set A) }.

*)


Require Import Arith.
Require Import Omega.
Require Import String.
Require List.

Import List.ListNotations.
Open Scope list.

Set Implicit Arguments.

Class Ordering A :=
  { cmp: A -> A -> comparison;
    cmp_eq: forall x y,
        cmp x y = Eq <-> x = y;
    cmp_antisym: forall x y,
        cmp x y = Gt <-> cmp y x = Lt;
    cmp_trans : forall x y z,
        cmp x y = Lt -> cmp y z = Lt ->
        cmp x z = Lt; }.

Lemma cmp_eq1 : forall A (ordA:Ordering A) x y,
    cmp x y = Eq -> x = y.
Proof.
  intros.
  apply cmp_eq; auto.
Qed.

Lemma cmp_refl : forall A (ordA:Ordering A) x,
    cmp x x = Eq.
Proof.
  intros.
  apply cmp_eq; auto.
Qed.

Lemma cmp_antisym1 : forall A (ordA:Ordering A) x y,
    cmp x y = Gt -> cmp y x = Lt.
Proof.
  intros.
  apply cmp_antisym; auto.
Qed.

Lemma cmp_antisym2 : forall A (ordA:Ordering A) x y,
    cmp x y = Lt -> cmp y x = Gt.
Proof.
  intros.
  apply cmp_antisym; auto.
Qed.

Hint Resolve cmp_eq1 cmp_refl cmp_antisym1 cmp_antisym2 cmp_trans.

Definition cmp_lt {A} `{Ordering A} :=
  fun x y => cmp x y = Lt.

Definition cmp_dec {A} `{Ordering A} : forall (x y:A), {x=y} + {x<>y}.
Proof.
  intros.
  destruct_with_eqn (cmp x y).
  left; eauto.
  right; intro.
  apply cmp_eq in H0; congruence.
  right; intro.
  apply cmp_eq in H0; congruence.
Defined.

Definition ord_spec {A} `{Ordering A} :
  forall x y, CompareSpec (x=y) (cmp x y = Lt /\ cmp y x = Gt) (cmp y x = Lt /\ cmp x y = Gt) (cmp x y).
Proof.
  intros.
  destruct_with_eqn (cmp x y);
    constructor;
    intuition eauto.
Defined.

Instance nat_Ordering : Ordering nat.
Proof.
  refine {| cmp := fun x y =>
                     if Nat.eq_dec x y then Eq
                     else if lt_dec x y then Lt
                          else Gt; |};
    intros.
  - destruct (Nat.eq_dec x y); split; intros;
      subst; try congruence.
    destruct (lt_dec x y); congruence.
  - destruct (Nat.eq_dec x y), (Nat.eq_dec y x);
      subst;
      try congruence.
    split; congruence.
    destruct (lt_dec x y), (lt_dec y x);
      try omega.
    split; congruence.
    split; auto.
  - destruct (Nat.eq_dec x y), (Nat.eq_dec y z), (Nat.eq_dec x z);
      subst;
      try congruence.
    destruct (lt_dec z y), (lt_dec y z);
      try congruence;
      try omega.
    destruct (lt_dec x y), (lt_dec y z), (lt_dec x z);
      try congruence;
      try omega.
Defined.

Instance prod_Ordering A B {ordA:Ordering A} {ordB: Ordering B} : Ordering (A*B).
Proof.
  refine {| cmp := fun '(x1, x2) '(y1, y2) =>
                     match cmp x1 y1 with
                     | Lt => Lt
                     | Gt => Gt
                     | Eq => cmp x2 y2
                     end |}; intros.
  - destruct x, y.
    destruct (ord_spec a a0); subst; (intuition eauto);
      repeat match goal with
             | [ H: cmp _ _ = Eq |- _ ] =>
               apply cmp_eq in H
             | [ H: (_, _) = (_, _) |- _ ] =>
               inversion H; clear H
             end; subst;
        try congruence; eauto.
  - destruct x, y.
    destruct (ord_spec a a0); subst.
    * rewrite cmp_refl.
      intuition eauto.
    * destruct H.
      rewrite H0.
      split; congruence.
    * intuition.
      rewrite H0; auto.
  - destruct x, y, z.
    destruct (ord_spec a a0), (ord_spec a0 a1);
      intuition subst;
      rewrite ?cmp_refl in *;
      repeat match goal with
             | [ H: cmp _ _ = _ |- _ ] =>
               rewrite H in *
             end;
      try congruence;
      eauto.
    erewrite cmp_trans; eauto.
Defined.

Instance sum_Ordering A B : forall (ordA:Ordering A) (ordB:Ordering B), Ordering (A+B).
Proof.
  intros.
  refine {| cmp := fun x y =>
                     match x, y with
                     | inl x, inl y => cmp x y
                     | inr x, inr y => cmp x y
                     | inl _, inr _ => Lt
                     | inr _, inl _ => Gt
                     end; |}; intros.
  - destruct x, y; (intuition eauto);
      repeat match goal with
             | [ H: inl _ = inl _ |- _ ] =>
               inversion H; subst; clear H
             | [ H: inr _ = inr _ |- _ ] =>
               inversion H; subst; clear H
             | [ H: cmp _ _ = Eq |- _ ] =>
               apply cmp_eq in H; subst
             end;
      try congruence;
      eauto.
  - destruct x, y; intuition eauto.
  - destruct x, y, z; (intuition eauto);
      try congruence.
Defined.

Record injection A B :=
  { inject: A -> B;
    inject_ok : forall x y, inject x = inject y -> x = y; }.

Theorem injection_Ordering A {B} : forall (ordA:Ordering A) (inj:injection B A), Ordering B.
Proof.
  intros.
  refine {| cmp := fun x y =>
                     cmp (inject inj x) (inject inj y) |}; intuition eauto.
  eapply inject_ok; eauto.
  subst; rewrite cmp_refl; auto.
Defined.

Arguments injection_Ordering A {B} ordA inj.

Fixpoint cmp_list A (ord:Ordering A) (l1 l2:list A) : comparison :=
  match l1, l2 with
  | [], [] => Eq
  | [], _::_ => Lt
  | _::_, [] => Gt
  | x::xs, y::ys => match cmp x y with
                   | Eq => cmp_list ord xs ys
                   | Lt => Lt
                   | Gt => Gt
                   end
  end.

Section TwoListInduction.

  Variable A:Type.
  Variable B:Type.
  Variable P: list A -> list B -> Prop.

  Fixpoint zip (l1: list A) (l2:list B) : list (A*B) :=
    match l1 with
    | nil => nil
    | x::xs => match l2 with
              | nil => nil
              | y::ys => (x,y)::zip xs ys
              end
    end.

  Hypothesis Pnil_nil : P [] [].
  Hypothesis Pnil_cons : forall y ys, P [] (y::ys).
  Hypothesis Pcons_nil : forall x xs, P (x::xs) [].

  Theorem empty_zip : forall l1 l2,
      zip l1 l2 = [] ->
      P l1 l2.
  Proof.
    induction l1; simpl; intros.
    destruct l2; eauto.
    destruct l2; simpl in *; try congruence; eauto.
  Qed.

  Hypothesis Pind : forall x y xs ys,
      P xs ys ->
      P (x::xs) (y::ys).

  Theorem two_list_induction : forall l1 l2,
      P l1 l2.
  Proof.
    intros.
    remember (zip l1 l2).
    generalize dependent l2.
    generalize dependent l1.
    induction l; simpl; intros.
    - apply empty_zip; auto.
    - destruct l1, l2; simpl in *; try congruence.
      inversion Heql; subst.
      specialize (IHl l1 l2); intuition.
  Qed.

End TwoListInduction.

Section ThreeListInduction.

  Variable A:Type.
  Variable B:Type.
  Variable C:Type.

  Fixpoint zip3 (l1: list A) (l2:list B) (l3:list C) : list (A*B*C) :=
    zip (zip l1 l2) l3.

  Variable P: list A -> list B -> list C -> Prop.

  Hypothesis Psome_nil : forall xs ys zs,
      xs = [] \/ ys = [] \/ zs = [] -> P xs ys zs.

  Hypothesis Pind : forall x y z xs ys zs,
      P xs ys zs ->
      P (x::xs) (y::ys) (z::zs).

  Theorem three_list_induction : forall l1 l2 l3,
      P l1 l2 l3.
  Proof.
    intros.
    remember (zip l1 l2).
    generalize dependent l2.
    generalize dependent l1.
    eapply two_list_induction with (l1 := l) (l2 := l3);
      intros; eauto.
    destruct l1, l2; eauto.
    simpl in *; congruence.

    generalize dependent H.
    generalize dependent Heql.
    generalize dependent ys.
    generalize dependent xs.
    generalize dependent x.
    generalize dependent y.
    clear l.
    clear l3.
    eapply two_list_induction with (l1:=l1) (l2:=l2); simpl; intros; eauto.

    inversion Heql; subst; clear Heql.
    eauto.
  Qed.

End ThreeListInduction.

Instance list_Ordering A {ord:Ordering A} : Ordering (list A).
Proof.
  refine {| cmp := cmp_list ord |}; intros.
  - eapply two_list_induction with (l1 := x) (l2 := y);
      simpl in *;
      try solve [ (intuition eauto); congruence ];
      intros.
    destruct H.
    destruct (ord_spec x0 y0); (intuition subst); eauto; try congruence.
    inversion H2; subst; clear H2; intuition eauto.
  - eapply two_list_induction with (l1 := x) (l2 := y);
      simpl in *;
      try solve [ (intuition eauto); congruence ];
      intros.
    destruct (ord_spec x0 y0); (intuition subst); eauto; try congruence.
    rewrite cmp_refl; eauto.
    rewrite cmp_refl in *; eauto.
    rewrite H2 in *; congruence.
    rewrite H1; eauto.
  - generalize dependent H.
    generalize dependent H0.
    eapply three_list_induction with (l1:=x) (l2:=y) (l3:=z); intros; simpl.
    intuition subst.
    destruct ys, zs; simpl in *; try congruence.
    destruct xs, zs; simpl in *; try congruence.
    destruct xs, ys; simpl in *; try congruence.
    simpl in *.
    destruct (ord_spec y0 z0), (ord_spec x0 y0); subst; eauto;
      intuition eauto;
      repeat match goal with
             | [ H: context[cmp ?x ?x] |- _ ] =>
               rewrite cmp_refl in H
             | [ |- context[cmp ?x ?x] ] =>
               rewrite cmp_refl
             | [ H: context[cmp ?x ?y], Heq: cmp ?x ?y = _ |- _ ] =>
               rewrite Heq in H
             | [ Heq: cmp ?x ?y = _ |- context[cmp ?x ?y] ] =>
               rewrite Heq
             | _ =>
               try erewrite cmp_trans by eauto
             end;
      eauto;
      try congruence.
Defined.

Instance bool_Ordering : Ordering bool.
Proof.
  refine {| cmp := fun x y =>
                     match x, y with
                     | false, false => Eq
                     | true, true => Eq
                     | false, true => Lt
                     | true, false => Gt
                     end |}; intros.
  destruct x, y; simpl; (intuition idtac); congruence.
  destruct x, y; simpl; (intuition idtac); congruence.
  destruct x, y, z; simpl; (intuition idtac); congruence.
Defined.

Instance ascii_Ordering : Ordering Ascii.ascii.
Proof.
  apply (injection_Ordering (bool*bool*bool*bool*bool*bool*bool*bool)%type).
  typeclasses eauto.

  unshelve econstructor; intros.
  destruct H.
  exact (b, b0, b1, b2, b3, b4, b5, b6).
  destruct x, y.
  congruence.
Defined.

Fixpoint string_to_list (s:string) : list Ascii.ascii :=
  match s with
  | EmptyString => []
  | String c s => c :: string_to_list s
  end.

Instance string_Ordering : Ordering string.
Proof.
  apply (injection_Ordering (list Ascii.ascii)).
  typeclasses eauto.
  refine {| inject := string_to_list |}; intros.
  remember (string_to_list x).
  remember (string_to_list y).
  generalize dependent x.
  generalize dependent y.
  generalize dependent H.
  eapply two_list_induction with (l1 := l) (l2 := l0); intros;
    try congruence.
  destruct x, y; simpl in *; try congruence.
  inversion H0; subst; clear H0; intuition.
  destruct x0, y0; simpl in *; try congruence.
  inversion Heql0; subst; clear Heql0.
  inversion Heql; subst; clear Heql.
  f_equal.
  eapply H0; eauto.
Defined.

Inductive sorted A (lt: A -> A -> Prop) : list A -> Prop :=
| sorted_nil : sorted lt nil
| sorted_cons : forall x l,
    List.Forall (lt x) l ->
    sorted lt l ->
    sorted lt (x::l).


Require Import BinPos.
Require Import ZArith.
Require Import FMapPositive.
Require Import String.

Require Import Setoid.

Set Implicit Arguments.

(* Define maps and the syntax used in the definition,
   also an equivalence relation on maps and tactics for applying it *)

Inductive Map (Key Elt : Type) : Type :=
| mapEmpty
| mapItem (k : Key) (v : Elt)
| mapJoin (m1 m2 : Map Key Elt)
.
Arguments mapEmpty [Key Elt].

Infix "|->" := mapItem (at level 50, no associativity).
Infix ":*" := mapJoin (at level 60, right associativity).

Inductive MapEquiv {K E : Type} : Map K E -> Map K E -> Prop :=
| equivUnit : forall m, MapEquiv (m :* mapEmpty) m
| equivComm : forall m1 m2, MapEquiv (m1 :* m2) (m2 :* m1)
| equivAssoc : forall m1 m2 m3, MapEquiv ((m1 :* m2) :* m3) (m1 :* (m2 :* m3))

| equivJoin : forall l1 r1 l2 r2, MapEquiv l1 l2 -> MapEquiv r1 r2 -> MapEquiv (l1 :* r1) (l2 :* r2)
| equivTrans : forall m1 m2 m3, MapEquiv m1 m2 -> MapEquiv m2 m3 -> MapEquiv m1 m3
| equivSym : forall m1 m2, MapEquiv m1 m2 -> MapEquiv m2 m1
| equivRefl : forall m, MapEquiv m m
.
Infix "~=" := MapEquiv (at level 70, no associativity).

Definition equivJoinL {K V} (r : Map K V) l1 l2 pfl : l1 :* r ~= l2 :* r :=
  equivJoin pfl (equivRefl r).
Definition equivJoinR {K V} (l : Map K V) r1 r2 pfr :  l :* r1 ~= l :* r2 :=
  equivJoin (equivRefl l) pfr.

Add Parametric Relation (K E : Type) : (Map K E) MapEquiv
  reflexivity proved by equivRefl
  symmetry proved by equivSym
  transitivity proved by equivTrans
  as map_equiv_rel.

Add Parametric Morphism K E : (@mapJoin K E) with
  signature MapEquiv ==> MapEquiv ==> MapEquiv as map_join_mor.
Proof. auto using equivJoin. Qed.

Lemma equivUnitL : forall {K V} (m : Map K V), MapEquiv (mapEmpty :* m) m.
intros. rewrite equivComm. apply equivUnit.
Qed.

Lemma equivComAssoc : forall {K V} (m1 m2 m3 : Map K V), m1 :* m2 :* m3 ~= m2 :* m1 :* m3.
intros. rewrite <- equivAssoc, (equivComm m1 m2), equivAssoc. reflexivity. Qed.

Ltac find x map k :=
  match map with
    | (x |-> _ :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* (x |-> ?v)) => let pf := constr:(equivComm mapl (x |-> v)) in k pf
    | ?mapl :* ?mapr =>
           find x mapl ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc (x |-> _) _ mapr))
                                        in k pf)
        || find x mapr ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl (x |-> _) _))
                                        in k pf)
  end.
Ltac find_submap map submap k :=
  match map with
    | (submap :* _) => let pf := constr:(equivRefl map) in k pf
    | (?mapl :* submap) => let pf := constr:(equivComm mapl submap) in k pf
    | ?mapl :* ?mapr =>
           find_submap mapl submap

                       ltac:(fun pfl => let pf := constr:(equivTrans (equivJoinL mapr pfl)
                                                                   (equivAssoc submap _ mapr))
                                        in k pf)
        || find_submap mapr submap
                       ltac:(fun pfr => let pf := constr:(equivTrans (equivJoinR mapl pfr)
                                                                   (equivComAssoc mapl submap _))
                                        in k pf)
  end.

Ltac find_map_entry :=
  match goal with
    | [|- ?map ~= _ ] =>
      ((is_var map;
       match goal with
         | [H : ?map ~= ?mapr |- ?map ~= _] =>
           match mapr with
             | map => fail
             | _ => rewrite H
           end
       end)
        || (try (unfold map)));
      match goal with
        | [|- ?x |-> ?v ~= ?x |-> _ :* _] => rewrite (equivUnit (x |-> v)); reflexivity
        | [|- ?map ~= ?x |-> ?v :* ?map2 ] =>
          find x map ltac:(fun pf => exact pf)
      end
  end.

  Ltac equate_maps := rewrite ?equivAssoc;
   repeat (rewrite ?f_equal;
     match goal with
       | [|- mapEmpty :* ?m ~= _] => rewrite (equivUnitL m)
       | [|- _ ~= mapEmpty :* ?m] => rewrite (equivUnitL m)
       | [|- ?m :* _ ~= ?m :* _] => apply equivJoin;[reflexivity|]
       | [|- (?x |-> ?v1 :* _) ~= (?x |-> ?v2 :* _)] => apply equivJoin;[replace v1 with v2 by omega|]
       | [|- MapEquiv ?map (?x |-> _ :* _)] => find x map ltac:(fun pf => rewrite pf)
       | [|- MapEquiv ?map (?submap :* _)] => find_submap map submap ltac:(fun pf => rewrite pf)
       | [|- MapEquiv ?map ?map ] => reflexivity
       | [|- ?m :* mapEmpty ~= _] => rewrite (equivUnit m)
       | [|- _ ~= ?m :* mapEmpty] => rewrite (equivUnit m)
     end).

(* Language syntax *)
Inductive Exp :=
  | EVar (v:string)
  | ELoad (x : Exp)
  | ECon (i:Z)
  | EPlus (l r:Exp)
  | EMinus (l r:Exp)
  | EDiv (l r:Exp)
  | EAmb (x y : Exp)
  .
Definition isEVal e :=
  match e with
    | ECon _ => true
    | _ => false
  end.

Inductive BExp :=
  | BCon (b:bool)
  | BLe (l r : Exp)
  | BEq (l r : Exp)
  | BNot (e:BExp)
  | BAnd (l r:BExp)
  .
Definition isBool b :=
  match b with
    | BCon _ => true
    | _ => false
  end.
Inductive Stmt :=
  | Skip
  | SAssign (x:string) (e:Exp)
  | HAssign (e:Exp) (e2:Exp)
  | Seq (s1 s2 : Stmt)
  | SIf (b:BExp) (sthn sels : Stmt)
  | SWhile (b:BExp) (body:Stmt)
  | Jump (target : string)
  .

(* K definitions *)
Inductive kitem : Set :=
  | KExp (e : Exp)
  | KBExp (b : BExp)
  | KStmt (s : Stmt)
  | KFreezeE (f : Exp -> kitem)
  | KFreezeB (f : BExp -> kitem)
  .

Definition kra : kitem -> list kitem -> list kitem := @cons kitem.
Definition kdot : list kitem := nil.

Structure kcfg := KCfg {
  kcell : list kitem;
  store : Map string Z;
  heap : Map Z Z;
  labels : Map string Stmt
  }.


From Coq Require Import Arith.Arith.
From Coq Require Import Bool.Bool.
Require Export Coq.Strings.String.
From Coq Require Import Logic.FunctionalExtensionality.
From Coq Require Import Lists.List.
Import ListNotations.

Module Maps.

Locate "+".
Print Init.Nat.add.
Print string_dec.
Check string_dec.

Definition eqb_string (x y : string) : bool :=
  if string_dec x y then true else false.

Theorem eqb_string_refl : forall s : string,
  true = eqb_string s s.
Proof.
  intros s. unfold eqb_string.
  destruct (string_dec s s) as [Hs_eq | Hs_not_eq].
  - reflexivity.
  - destruct Hs_not_eq. reflexivity.
Qed.

Theorem eqb_string_true_iff : forall x y : string,
  eqb_string x y = true <-> x = y.
Proof.
  intros x y.
  unfold eqb_string.
  destruct (string_dec x y) as [Hs_eq | Hs_not_eq].
  - rewrite Hs_eq. split. reflexivity. reflexivity.
  - split.
    + intros contra. discriminate contra.
    + intros H. exfalso. apply Hs_not_eq. apply H.
Qed.

Locate not_true_iff_false.

Theorem eqb_string_false_iff : forall x y : string,
  eqb_string x y = false <-> x <> y.
Proof.
  intros x y. rewrite <- eqb_string_true_iff.
  rewrite not_true_iff_false. reflexivity.
Qed.

Definition total_map (A : Type) := string -> A.

Definition t_empty {A : Type} (v : A) : total_map A := (fun _ => v).

Definition t_update {A : Type} (m : total_map A)
                    (x : string) (v : A): total_map A :=
  fun x' => if eqb_string x x' then v else m x'.

Notation "'_' '!->' v" := (t_empty v)
  (at level 100, right associativity).

Example example_empty := (_ !-> false).

Notation "x '!->' v ';' m" := (t_update m x v)
                              (at level 100, v at next level, right associativity).

Definition examplemap' :=
  ( "bar" !-> true;
    "foo" !-> true;
    _ !-> false
  ).

Lemma t_apply_empty : forall (A : Type) (x : string) (v : A),
  (_ !-> v) x = v.
Proof. unfold t_empty. intros. reflexivity. Qed.

Lemma t_update_eq : forall (A : Type) (m : total_map A) x v,
  (x !-> v ; m) x = v.
Proof. intros. unfold t_update. rewrite <- eqb_string_refl. simpl. reflexivity. Qed.

Theorem t_update_neq : forall (A : Type) (m : total_map A) x1 x2 v,
  x1 <> x2 ->
  (x1 !-> v ; m) x2 = m x2.
Proof. unfold t_update, eqb_string. intros.
  destruct (string_dec x1 x2) as [Hsd | Hsd].
  - exfalso. apply H. apply Hsd.
  - reflexivity.
Qed.

Lemma t_update_shadow : forall (A : Type) (m : total_map A) x v1 v2,
  (x !-> v2 ; x !-> v1 ; m) = (x !-> v2 ; m).
Proof. unfold t_update. intros.
  apply functional_extensionality.
  intros val.
  unfold eqb_string.
  destruct (string_dec x val) as [Hsd | Hsd].
  - reflexivity.
  - reflexivity.
Qed.

Print reflect.

Lemma eqb_stringP : forall x y : string,
  reflect (x = y) (eqb_string x y).
Proof. unfold eqb_string. intros.
  destruct (string_dec x y) as [Exy | Exy].
  - apply ReflectT. apply Exy.
  - apply ReflectF. apply Exy.
Qed.

Theorem t_update_same : forall (A : Type) (m : total_map A) x,
  (x !-> m x ; m) = m.
Proof. unfold t_update. intros.
  apply functional_extensionality.
  intros val.
  destruct (eqb_stringP x val) as [E|E].
  - rewrite -> E. reflexivity.
  - reflexivity.
Qed.

Theorem t_update_permute : forall (A : Type) (m : total_map A) v1 v2 x1 x2,
  x2 <> x1 ->
  (x1 !-> v1 ; x2 !-> v2 ; m)
  =
  (x2 !-> v2 ; x1 !-> v1 ; m).
Proof. intros.
  apply functional_extensionality.
  intros x.
  unfold t_update.
  destruct (eqb_stringP x1 x) as [E|E].
  - rewrite <- E.
    destruct (eqb_stringP x2 x1) as [E1|E1].
    + exfalso. apply H. apply E1.
    + reflexivity.
  - reflexivity.
Qed.

Definition partial_map (A : Type) := total_map (option A).
Definition empty {A : Type} : partial_map A :=
  t_empty None.
Definition update {A : Type} (m : partial_map A)
           (x : string) (v : A) :=
  (x !-> Some v ; m).

Notation "x '|->' v ';' m" := (update m x v)
  (at level 100, v at next level, right associativity).

Notation "x '|->' v" := (update empty x v)
  (at level 100).

Lemma apply_empty : forall (A : Type) (x : string),
  @empty A x = None.
Proof. intros. unfold empty, t_empty. reflexivity. Qed.

Lemma update_eq : forall (A : Type) (m : partial_map A) x v,
  (x |-> v ; m) x = Some v.
Proof. intros. unfold update, t_update. rewrite <- eqb_string_refl. reflexivity. Qed.

Theorem update_neq : forall (A : Type) (m : partial_map A) x1 x2 v,
  x2 <> x1 ->
  (x2 |-> v ; m) x1 = m x1.
Proof. intros. unfold update, t_update.
  destruct (eqb_stringP x2 x1) as [E|E].
  - exfalso. apply H. apply E.
  - reflexivity.
Qed.

Lemma update_shadow : forall (A : Type) (m : partial_map A) x v1 v2,
  (x |-> v2 ; x |-> v1 ; m) = (x |-> v2 ; m).
Proof. intros. unfold update, t_update.
  apply functional_extensionality.
  intros val.
  destruct (eqb_stringP x val) as [E|E].
  - reflexivity.
  - reflexivity.
Qed.

Theorem update_same : forall (A : Type) (m : partial_map A) x v,
  m x = Some v ->
  (x |-> v ; m) = m.
Proof. intros. unfold update, t_update.
  apply functional_extensionality.
  intros val.
  destruct (eqb_stringP x val) as [E|E].
  - rewrite <- H. rewrite -> E. reflexivity.
  - reflexivity.
Qed.

Theorem update_permute : forall (A : Type) (m : partial_map A) x1 x2 v1 v2,
  x2 <> x1 ->
  (x1 |-> v1 ; x2 |-> v2 ; m) = (x2 |-> v2 ; x1 |-> v1 ; m).
Proof. intros. unfold update, t_update.
  apply functional_extensionality.
  intros val.
  destruct (eqb_stringP x1 val) as [E|E].
  - destruct (eqb_stringP x2 val) as [E1|E1].
    + rewrite <- E in E1. exfalso. apply H. apply E1.
    + reflexivity.
  - reflexivity.
Qed.

Definition inclusion {A : Type} (m m' : partial_map A) :=
  forall x v, m x = Some v -> m' x = Some v.

Lemma inclusion_update : forall (A : Type) (m m' : partial_map A) (x : string) (vx : A),
  inclusion m m' ->
  inclusion (x |-> vx ; m) (x |-> vx ; m').
Proof. unfold inclusion, update, t_update. intros.
  destruct (eqb_stringP x x0) as [E|E].
  - apply H0.
  - apply H. apply H0.
Qed.

End Maps.


Require Import Coq.Program.Basics.

Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Data.Monads.OptionMonad.

Require Import ASN1FP.Aux.Option.

Import MonadNotation.
Local Open Scope monad_scope.

(* `b` is inverse of `f` wrt. heterogenous equality `e` *)
Definition bool_het_inverse
           (A1 B A2 : Type)
           (f: A1 -> B)
           (b: B -> A2)
           (e: A1 -> A2 -> bool)
           (x: A1)
: Prop :=
  e x (b (f x)) = true.

(* monadic version of `bool_het_inverse` *)
Definition bool_het_inverse'
           (m: Type -> Type)
           `{Monad m}
           (A1 B A2 : Type)
           (f: A1 -> m B)
           (b: B -> m A2)
           (e: A1 -> A2 -> bool)
           (x: A1)
  : m bool:=
  y <- f x ;;
    x' <- b y ;;
    ret (e x x').

(*
 *  "Round-trip" converting between types A1, B, A2:
 *  A1 -> B -> A2
 *
 *  if
 *    forward pass happens
 *  then
 *      backward pass happens
 *    and
 *      backward pass returns an element,
 *      equivalent to the starting one
 *)
Definition roundtrip_option
           (A1 B A2 : Type)
           (f: A1 -> option B) (* forward pass *)
           (b: B -> option A2) (* backward pass *)
           (e: A1 -> A2 -> bool) (* equivalence on A *)
           (x: A1) (* value *)
  : Prop :=
   is_Some_b (f x) = true ->
   bool_het_inverse' option A1 B A2 f b e x = Some true.

(*
 * if
 *     b1 = f1^(-1)
 *   and
 *     b2 = f2^(-1)
 * then
 *   b1 . b2 = (f2 . f1)^(-1)
 *)
Lemma inv_trans {A1 A2 B C : Type}
      {f1 : A1 -> B} {b1 : B -> A2} {ea : A1 -> A2 -> bool}
      {f2 : B -> C} {b2 : C -> B} {eb : B -> B -> bool}
      {x : A1} :
      (forall (y z : B), eb y z = true -> b1 y = b1 z) ->
      bool_het_inverse A1 B A2 f1 b1 ea x ->
      bool_het_inverse B C B f2 b2 eb (f1 x) ->
      bool_het_inverse A1 C A2 (compose f2 f1) (compose b1 b2) ea x.
Proof.
  unfold bool_het_inverse, compose.
  intros H H1 H2.
  apply H in H2.
  rewrite <- H2.
  apply H1.
Qed.