diff options
Diffstat (limited to 'theories/IntMap')
| -rw-r--r-- | theories/IntMap/.depend | 48 | ||||
| -rw-r--r-- | theories/IntMap/Adalloc.v | 365 | ||||
| -rw-r--r-- | theories/IntMap/Addec.v | 193 | ||||
| -rw-r--r-- | theories/IntMap/Addr.v | 491 | ||||
| -rw-r--r-- | theories/IntMap/Adist.v | 336 | ||||
| -rw-r--r-- | theories/IntMap/Allmaps.v | 26 | ||||
| -rw-r--r-- | theories/IntMap/Fset.v | 371 | ||||
| -rw-r--r-- | theories/IntMap/Lsort.v | 628 | ||||
| -rw-r--r-- | theories/IntMap/Map.v | 865 | ||||
| -rw-r--r-- | theories/IntMap/Mapaxioms.v | 763 | ||||
| -rw-r--r-- | theories/IntMap/Mapc.v | 542 | ||||
| -rw-r--r-- | theories/IntMap/Mapcanon.v | 399 | ||||
| -rw-r--r-- | theories/IntMap/Mapcard.v | 764 | ||||
| -rw-r--r-- | theories/IntMap/Mapfold.v | 424 | ||||
| -rw-r--r-- | theories/IntMap/Mapiter.v | 620 | ||||
| -rw-r--r-- | theories/IntMap/Maplists.v | 437 | ||||
| -rw-r--r-- | theories/IntMap/Mapsubset.v | 606 | ||||
| -rw-r--r-- | theories/IntMap/intro.tex | 6 |
18 files changed, 7884 insertions, 0 deletions
diff --git a/theories/IntMap/.depend b/theories/IntMap/.depend new file mode 100644 index 00000000..8c90ac99 --- /dev/null +++ b/theories/IntMap/.depend @@ -0,0 +1,48 @@ +Mapsubset.vo: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo +Mapsubset.vi: Mapsubset.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo +Maplists.vo: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo +Maplists.vi: Maplists.v Addr.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapsubset.vo Mapcard.vo Mapcanon.vo Mapc.vo Mapiter.vo Mapfold.vo +Mapiter.vo: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo +Mapiter.vi: Mapiter.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo +Mapfold.vo: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo +Mapfold.vi: Mapfold.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Lsort.vo Mapsubset.vo +Mapcard.vo: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo +Mapcard.vi: Mapcard.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Mapsubset.vo Lsort.vo +Mapcanon.vo: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo +Mapcanon.vi: Mapcanon.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Mapiter.vo Fset.vo Lsort.vo Mapsubset.vo Mapcard.vo +Mapc.vo: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo +Mapc.vi: Mapc.v Addr.vo Adist.vo Addec.vo Map.vo Mapaxioms.vo Fset.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapcard.vo Mapcanon.vo +Mapaxioms.vo: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo +Mapaxioms.vi: Mapaxioms.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo +Map.vo: Map.v Addr.vo Adist.vo Addec.vo +Map.vi: Map.v Addr.vo Adist.vo Addec.vo +Lsort.vo: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo +Lsort.vi: Lsort.v Addr.vo Adist.vo Addec.vo Map.vo Mapiter.vo +Fset.vo: Fset.v Addr.vo Adist.vo Addec.vo Map.vo +Fset.vi: Fset.v Addr.vo Adist.vo Addec.vo Map.vo +Allmaps.vo: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo +Allmaps.vi: Allmaps.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo Mapaxioms.vo Mapiter.vo Mapsubset.vo Lsort.vo Mapfold.vo Mapcard.vo Mapcanon.vo Mapc.vo Maplists.vo Adalloc.vo +Adist.vo: Adist.v Addr.vo +Adist.vi: Adist.v Addr.vo +Addr.vo: Addr.v +Addr.vi: Addr.v +Addec.vo: Addec.v Addr.vo +Addec.vi: Addec.v Addr.vo +Adalloc.vo: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo +Adalloc.vi: Adalloc.v Addr.vo Adist.vo Addec.vo Map.vo Fset.vo +Mapsubset.html: Mapsubset.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html +Maplists.html: Maplists.v Addr.html Addec.html Map.html Fset.html Mapaxioms.html Mapsubset.html Mapcard.html Mapcanon.html Mapc.html Mapiter.html Mapfold.html +Mapiter.html: Mapiter.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html +Mapfold.html: Mapfold.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Lsort.html Mapsubset.html +Mapcard.html: Mapcard.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Mapsubset.html Lsort.html +Mapcanon.html: Mapcanon.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Mapiter.html Fset.html Lsort.html Mapsubset.html Mapcard.html +Mapc.html: Mapc.v Addr.html Adist.html Addec.html Map.html Mapaxioms.html Fset.html Mapiter.html Mapsubset.html Lsort.html Mapcard.html Mapcanon.html +Mapaxioms.html: Mapaxioms.v Addr.html Adist.html Addec.html Map.html Fset.html +Map.html: Map.v Addr.html Adist.html Addec.html +Lsort.html: Lsort.v Addr.html Adist.html Addec.html Map.html Mapiter.html +Fset.html: Fset.v Addr.html Adist.html Addec.html Map.html +Allmaps.html: Allmaps.v Addr.html Adist.html Addec.html Map.html Fset.html Mapaxioms.html Mapiter.html Mapsubset.html Lsort.html Mapfold.html Mapcard.html Mapcanon.html Mapc.html Maplists.html Adalloc.html +Adist.html: Adist.v Addr.html +Addr.html: Addr.v +Addec.html: Addec.v Addr.html +Adalloc.html: Adalloc.v Addr.html Adist.html Addec.html Map.html Fset.html diff --git a/theories/IntMap/Adalloc.v b/theories/IntMap/Adalloc.v new file mode 100644 index 00000000..9fde8f5f --- /dev/null +++ b/theories/IntMap/Adalloc.v @@ -0,0 +1,365 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Adalloc.v,v 1.10.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Arith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Fset. + +Section AdAlloc. + + Variable A : Set. + + Definition nat_of_ad (a:ad) := + match a with + | ad_z => 0 + | ad_x p => nat_of_P p + end. + + Fixpoint nat_le (m:nat) : nat -> bool := + match m with + | O => fun _:nat => true + | S m' => + fun n:nat => match n with + | O => false + | S n' => nat_le m' n' + end + end. + + Lemma nat_le_correct : forall m n:nat, m <= n -> nat_le m n = true. + Proof. + induction m as [| m IHm]. trivial. + destruct n. intro H. elim (le_Sn_O _ H). + intros. simpl in |- *. apply IHm. apply le_S_n. assumption. + Qed. + + Lemma nat_le_complete : forall m n:nat, nat_le m n = true -> m <= n. + Proof. + induction m. trivial with arith. + destruct n. intro H. discriminate H. + auto with arith. + Qed. + + Lemma nat_le_correct_conv : forall m n:nat, m < n -> nat_le n m = false. + Proof. + intros. elim (sumbool_of_bool (nat_le n m)). intro H0. + elim (lt_irrefl _ (lt_le_trans _ _ _ H (nat_le_complete _ _ H0))). + trivial. + Qed. + + Lemma nat_le_complete_conv : forall m n:nat, nat_le n m = false -> m < n. + Proof. + intros. elim (le_or_lt n m). intro. conditional trivial rewrite nat_le_correct in H. discriminate H. + trivial. + Qed. + + Definition ad_of_nat (n:nat) := + match n with + | O => ad_z + | S n' => ad_x (P_of_succ_nat n') + end. + + Lemma ad_of_nat_of_ad : forall a:ad, ad_of_nat (nat_of_ad a) = a. + Proof. + destruct a as [| p]. reflexivity. + simpl in |- *. elim (ZL4 p). intros n H. rewrite H. simpl in |- *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H. + rewrite nat_of_P_inj with (1 := H). reflexivity. + Qed. + + Lemma nat_of_ad_of_nat : forall n:nat, nat_of_ad (ad_of_nat n) = n. + Proof. + induction n. trivial. + intros. simpl in |- *. apply nat_of_P_o_P_of_succ_nat_eq_succ. + Qed. + + Definition ad_le (a b:ad) := nat_le (nat_of_ad a) (nat_of_ad b). + + Lemma ad_le_refl : forall a:ad, ad_le a a = true. + Proof. + intro. unfold ad_le in |- *. apply nat_le_correct. apply le_n. + Qed. + + Lemma ad_le_antisym : + forall a b:ad, ad_le a b = true -> ad_le b a = true -> a = b. + Proof. + unfold ad_le in |- *. intros. rewrite <- (ad_of_nat_of_ad a). rewrite <- (ad_of_nat_of_ad b). + rewrite (le_antisym _ _ (nat_le_complete _ _ H) (nat_le_complete _ _ H0)). reflexivity. + Qed. + + Lemma ad_le_trans : + forall a b c:ad, ad_le a b = true -> ad_le b c = true -> ad_le a c = true. + Proof. + unfold ad_le in |- *. intros. apply nat_le_correct. apply le_trans with (m := nat_of_ad b). + apply nat_le_complete. assumption. + apply nat_le_complete. assumption. + Qed. + + Lemma ad_le_lt_trans : + forall a b c:ad, + ad_le a b = true -> ad_le c b = false -> ad_le c a = false. + Proof. + unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply le_lt_trans with (m := nat_of_ad b). + apply nat_le_complete. assumption. + apply nat_le_complete_conv. assumption. + Qed. + + Lemma ad_lt_le_trans : + forall a b c:ad, + ad_le b a = false -> ad_le b c = true -> ad_le c a = false. + Proof. + unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply lt_le_trans with (m := nat_of_ad b). + apply nat_le_complete_conv. assumption. + apply nat_le_complete. assumption. + Qed. + + Lemma ad_lt_trans : + forall a b c:ad, + ad_le b a = false -> ad_le c b = false -> ad_le c a = false. + Proof. + unfold ad_le in |- *. intros. apply nat_le_correct_conv. apply lt_trans with (m := nat_of_ad b). + apply nat_le_complete_conv. assumption. + apply nat_le_complete_conv. assumption. + Qed. + + Lemma ad_lt_le_weak : forall a b:ad, ad_le b a = false -> ad_le a b = true. + Proof. + unfold ad_le in |- *. intros. apply nat_le_correct. apply lt_le_weak. + apply nat_le_complete_conv. assumption. + Qed. + + Definition ad_min (a b:ad) := if ad_le a b then a else b. + + Lemma ad_min_choice : forall a b:ad, {ad_min a b = a} + {ad_min a b = b}. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. left. rewrite H. + reflexivity. + intro H. right. rewrite H. reflexivity. + Qed. + + Lemma ad_min_le_1 : forall a b:ad, ad_le (ad_min a b) a = true. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. rewrite H. + apply ad_le_refl. + intro H. rewrite H. apply ad_lt_le_weak. assumption. + Qed. + + Lemma ad_min_le_2 : forall a b:ad, ad_le (ad_min a b) b = true. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le a b)). intro H. rewrite H. assumption. + intro H. rewrite H. apply ad_le_refl. + Qed. + + Lemma ad_min_le_3 : + forall a b c:ad, ad_le a (ad_min b c) = true -> ad_le a b = true. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H. + assumption. + intro H0. rewrite H0 in H. apply ad_lt_le_weak. apply ad_le_lt_trans with (b := c); assumption. + Qed. + + Lemma ad_min_le_4 : + forall a b c:ad, ad_le a (ad_min b c) = true -> ad_le a c = true. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H. + apply ad_le_trans with (b := b); assumption. + intro H0. rewrite H0 in H. assumption. + Qed. + + Lemma ad_min_le_5 : + forall a b c:ad, + ad_le a b = true -> ad_le a c = true -> ad_le a (ad_min b c) = true. + Proof. + intros. elim (ad_min_choice b c). intro H1. rewrite H1. assumption. + intro H1. rewrite H1. assumption. + Qed. + + Lemma ad_min_lt_3 : + forall a b c:ad, ad_le (ad_min b c) a = false -> ad_le b a = false. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H. + assumption. + intro H0. rewrite H0 in H. apply ad_lt_trans with (b := c); assumption. + Qed. + + Lemma ad_min_lt_4 : + forall a b c:ad, ad_le (ad_min b c) a = false -> ad_le c a = false. + Proof. + unfold ad_min in |- *. intros. elim (sumbool_of_bool (ad_le b c)). intro H0. rewrite H0 in H. + apply ad_lt_le_trans with (b := b); assumption. + intro H0. rewrite H0 in H. assumption. + Qed. + + (** Allocator: returns an address not in the domain of [m]. + This allocator is optimal in that it returns the lowest possible address, + in the usual ordering on integers. It is not the most efficient, however. *) + Fixpoint ad_alloc_opt (m:Map A) : ad := + match m with + | M0 => ad_z + | M1 a _ => if ad_eq a ad_z then ad_x 1 else ad_z + | M2 m1 m2 => + ad_min (ad_double (ad_alloc_opt m1)) + (ad_double_plus_un (ad_alloc_opt m2)) + end. + + Lemma ad_alloc_opt_allocates_1 : + forall m:Map A, MapGet A m (ad_alloc_opt m) = NONE A. + Proof. + induction m as [| a| m0 H m1 H0]. reflexivity. + simpl in |- *. elim (sumbool_of_bool (ad_eq a ad_z)). intro H. rewrite H. + rewrite (ad_eq_complete _ _ H). reflexivity. + intro H. rewrite H. rewrite H. reflexivity. + intros. change + (ad_alloc_opt (M2 A m0 m1)) with (ad_min (ad_double (ad_alloc_opt m0)) + (ad_double_plus_un (ad_alloc_opt m1))) + in |- *. + elim + (ad_min_choice (ad_double (ad_alloc_opt m0)) + (ad_double_plus_un (ad_alloc_opt m1))). + intro H1. rewrite H1. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption. + apply ad_double_bit_0. + intro H1. rewrite H1. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. assumption. + apply ad_double_plus_un_bit_0. + Qed. + + Lemma ad_alloc_opt_allocates : + forall m:Map A, in_dom A (ad_alloc_opt m) m = false. + Proof. + unfold in_dom in |- *. intro. rewrite (ad_alloc_opt_allocates_1 m). reflexivity. + Qed. + + (** Moreover, this is optimal: all addresses below [(ad_alloc_opt m)] + are in [dom m]: *) + + Lemma nat_of_ad_double : + forall a:ad, nat_of_ad (ad_double a) = 2 * nat_of_ad a. + Proof. + destruct a as [| p]. trivial. + exact (nat_of_P_xO p). + Qed. + + Lemma nat_of_ad_double_plus_un : + forall a:ad, nat_of_ad (ad_double_plus_un a) = S (2 * nat_of_ad a). + Proof. + destruct a as [| p]. trivial. + exact (nat_of_P_xI p). + Qed. + + Lemma ad_le_double_mono : + forall a b:ad, + ad_le a b = true -> ad_le (ad_double a) (ad_double b) = true. + Proof. + unfold ad_le in |- *. intros. rewrite nat_of_ad_double. rewrite nat_of_ad_double. apply nat_le_correct. + simpl in |- *. apply plus_le_compat. apply nat_le_complete. assumption. + apply plus_le_compat. apply nat_le_complete. assumption. + apply le_n. + Qed. + + Lemma ad_le_double_plus_un_mono : + forall a b:ad, + ad_le a b = true -> + ad_le (ad_double_plus_un a) (ad_double_plus_un b) = true. + Proof. + unfold ad_le in |- *. intros. rewrite nat_of_ad_double_plus_un. rewrite nat_of_ad_double_plus_un. + apply nat_le_correct. apply le_n_S. simpl in |- *. apply plus_le_compat. apply nat_le_complete. + assumption. + apply plus_le_compat. apply nat_le_complete. assumption. + apply le_n. + Qed. + + Lemma ad_le_double_mono_conv : + forall a b:ad, + ad_le (ad_double a) (ad_double b) = true -> ad_le a b = true. + Proof. + unfold ad_le in |- *. intros a b. rewrite nat_of_ad_double. rewrite nat_of_ad_double. intro. + apply nat_le_correct. apply (mult_S_le_reg_l 1). apply nat_le_complete. assumption. + Qed. + + Lemma ad_le_double_plus_un_mono_conv : + forall a b:ad, + ad_le (ad_double_plus_un a) (ad_double_plus_un b) = true -> + ad_le a b = true. + Proof. + unfold ad_le in |- *. intros a b. rewrite nat_of_ad_double_plus_un. rewrite nat_of_ad_double_plus_un. + intro. apply nat_le_correct. apply (mult_S_le_reg_l 1). apply le_S_n. apply nat_le_complete. + assumption. + Qed. + + Lemma ad_lt_double_mono : + forall a b:ad, + ad_le a b = false -> ad_le (ad_double a) (ad_double b) = false. + Proof. + intros. elim (sumbool_of_bool (ad_le (ad_double a) (ad_double b))). intro H0. + rewrite (ad_le_double_mono_conv _ _ H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_lt_double_plus_un_mono : + forall a b:ad, + ad_le a b = false -> + ad_le (ad_double_plus_un a) (ad_double_plus_un b) = false. + Proof. + intros. elim (sumbool_of_bool (ad_le (ad_double_plus_un a) (ad_double_plus_un b))). intro H0. + rewrite (ad_le_double_plus_un_mono_conv _ _ H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_lt_double_mono_conv : + forall a b:ad, + ad_le (ad_double a) (ad_double b) = false -> ad_le a b = false. + Proof. + intros. elim (sumbool_of_bool (ad_le a b)). intro H0. rewrite (ad_le_double_mono _ _ H0) in H. + discriminate H. + trivial. + Qed. + + Lemma ad_lt_double_plus_un_mono_conv : + forall a b:ad, + ad_le (ad_double_plus_un a) (ad_double_plus_un b) = false -> + ad_le a b = false. + Proof. + intros. elim (sumbool_of_bool (ad_le a b)). intro H0. + rewrite (ad_le_double_plus_un_mono _ _ H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_alloc_opt_optimal_1 : + forall (m:Map A) (a:ad), + ad_le (ad_alloc_opt m) a = false -> {y : A | MapGet A m a = SOME A y}. + Proof. + induction m as [| a y| m0 H m1 H0]. simpl in |- *. unfold ad_le in |- *. simpl in |- *. intros. discriminate H. + simpl in |- *. intros b H. elim (sumbool_of_bool (ad_eq a ad_z)). intro H0. rewrite H0 in H. + unfold ad_le in H. cut (ad_z = b). intro. split with y. rewrite <- H1. rewrite H0. reflexivity. + rewrite <- (ad_of_nat_of_ad b). + rewrite <- (le_n_O_eq _ (le_S_n _ _ (nat_le_complete_conv _ _ H))). reflexivity. + intro H0. rewrite H0 in H. discriminate H. + intros. simpl in H1. elim (ad_double_or_double_plus_un a). intro H2. elim H2. intros a0 H3. + rewrite H3 in H1. elim (H _ (ad_lt_double_mono_conv _ _ (ad_min_lt_3 _ _ _ H1))). intros y H4. + split with y. rewrite H3. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption. + apply ad_double_bit_0. + intro H2. elim H2. intros a0 H3. rewrite H3 in H1. + elim (H0 _ (ad_lt_double_plus_un_mono_conv _ _ (ad_min_lt_4 _ _ _ H1))). intros y H4. + split with y. rewrite H3. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. + assumption. + apply ad_double_plus_un_bit_0. + Qed. + + Lemma ad_alloc_opt_optimal : + forall (m:Map A) (a:ad), + ad_le (ad_alloc_opt m) a = false -> in_dom A a m = true. + Proof. + intros. unfold in_dom in |- *. elim (ad_alloc_opt_optimal_1 m a H). intros y H0. rewrite H0. + reflexivity. + Qed. + +End AdAlloc. diff --git a/theories/IntMap/Addec.v b/theories/IntMap/Addec.v new file mode 100644 index 00000000..7dba9ef6 --- /dev/null +++ b/theories/IntMap/Addec.v @@ -0,0 +1,193 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Addec.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +(** Equality on adresses *) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Addr. + +Fixpoint ad_eq_1 (p1 p2:positive) {struct p2} : bool := + match p1, p2 with + | xH, xH => true + | xO p'1, xO p'2 => ad_eq_1 p'1 p'2 + | xI p'1, xI p'2 => ad_eq_1 p'1 p'2 + | _, _ => false + end. + +Definition ad_eq (a a':ad) := + match a, a' with + | ad_z, ad_z => true + | ad_x p, ad_x p' => ad_eq_1 p p' + | _, _ => false + end. + +Lemma ad_eq_correct : forall a:ad, ad_eq a a = true. +Proof. + destruct a; trivial. + induction p; trivial. +Qed. + +Lemma ad_eq_complete : forall a a':ad, ad_eq a a' = true -> a = a'. +Proof. + destruct a. destruct a'; trivial. destruct p. + discriminate 1. + discriminate 1. + discriminate 1. + destruct a'. intros. discriminate H. + unfold ad_eq in |- *. intros. cut (p = p0). intros. rewrite H0. reflexivity. + generalize dependent p0. + induction p as [p IHp| p IHp| ]. destruct p0; intro H. + rewrite (IHp p0). reflexivity. + exact H. + discriminate H. + discriminate H. + destruct p0; intro H. discriminate H. + rewrite (IHp p0 H). reflexivity. + discriminate H. + destruct p0 as [p| p| ]; intro H. discriminate H. + discriminate H. + trivial. +Qed. + +Lemma ad_eq_comm : forall a a':ad, ad_eq a a' = ad_eq a' a. +Proof. + intros. cut (forall b b':bool, ad_eq a a' = b -> ad_eq a' a = b' -> b = b'). + intros. apply H. reflexivity. + reflexivity. + destruct b. intros. cut (a = a'). + intro. rewrite H1 in H0. rewrite (ad_eq_correct a') in H0. exact H0. + apply ad_eq_complete. exact H. + destruct b'. intros. cut (a' = a). + intro. rewrite H1 in H. rewrite H1 in H0. rewrite <- H. exact H0. + apply ad_eq_complete. exact H0. + trivial. +Qed. + +Lemma ad_xor_eq_true : + forall a a':ad, ad_xor a a' = ad_z -> ad_eq a a' = true. +Proof. + intros. rewrite (ad_xor_eq a a' H). apply ad_eq_correct. +Qed. + +Lemma ad_xor_eq_false : + forall (a a':ad) (p:positive), ad_xor a a' = ad_x p -> ad_eq a a' = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq a a')). intro H0. + rewrite (ad_eq_complete a a' H0) in H. rewrite (ad_xor_nilpotent a') in H. discriminate H. + trivial. +Qed. + +Lemma ad_bit_0_1_not_double : + forall a:ad, + ad_bit_0 a = true -> forall a0:ad, ad_eq (ad_double a0) a = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq (ad_double a0) a)). intro H0. + rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_bit_0 a0) in H. discriminate H. + trivial. +Qed. + +Lemma ad_not_div_2_not_double : + forall a a0:ad, + ad_eq (ad_div_2 a) a0 = false -> ad_eq a (ad_double a0) = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq (ad_double a0) a)). intro H0. + rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_div_2 a0) in H. + rewrite (ad_eq_correct a0) in H. discriminate H. + intro. rewrite ad_eq_comm. assumption. +Qed. + +Lemma ad_bit_0_0_not_double_plus_un : + forall a:ad, + ad_bit_0 a = false -> forall a0:ad, ad_eq (ad_double_plus_un a0) a = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq (ad_double_plus_un a0) a)). intro H0. + rewrite <- (ad_eq_complete _ _ H0) in H. rewrite (ad_double_plus_un_bit_0 a0) in H. + discriminate H. + trivial. +Qed. + +Lemma ad_not_div_2_not_double_plus_un : + forall a a0:ad, + ad_eq (ad_div_2 a) a0 = false -> ad_eq (ad_double_plus_un a0) a = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq a (ad_double_plus_un a0))). intro H0. + rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_double_plus_un_div_2 a0) in H. + rewrite (ad_eq_correct a0) in H. discriminate H. + intro H0. rewrite ad_eq_comm. assumption. +Qed. + +Lemma ad_bit_0_neq : + forall a a':ad, + ad_bit_0 a = false -> ad_bit_0 a' = true -> ad_eq a a' = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq a a')). intro H1. rewrite (ad_eq_complete _ _ H1) in H. + rewrite H in H0. discriminate H0. + trivial. +Qed. + +Lemma ad_div_eq : + forall a a':ad, ad_eq a a' = true -> ad_eq (ad_div_2 a) (ad_div_2 a') = true. +Proof. + intros. cut (a = a'). intros. rewrite H0. apply ad_eq_correct. + apply ad_eq_complete. exact H. +Qed. + +Lemma ad_div_neq : + forall a a':ad, + ad_eq (ad_div_2 a) (ad_div_2 a') = false -> ad_eq a a' = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq a a')). intro H0. + rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_eq_correct (ad_div_2 a')) in H. discriminate H. + trivial. +Qed. + +Lemma ad_div_bit_eq : + forall a a':ad, + ad_bit_0 a = ad_bit_0 a' -> ad_div_2 a = ad_div_2 a' -> a = a'. +Proof. + intros. apply ad_faithful. unfold eqf in |- *. destruct n. + rewrite ad_bit_0_correct. rewrite ad_bit_0_correct. assumption. + rewrite <- ad_div_2_correct. rewrite <- ad_div_2_correct. + rewrite H0. reflexivity. +Qed. + +Lemma ad_div_bit_neq : + forall a a':ad, + ad_eq a a' = false -> + ad_bit_0 a = ad_bit_0 a' -> ad_eq (ad_div_2 a) (ad_div_2 a') = false. +Proof. + intros. elim (sumbool_of_bool (ad_eq (ad_div_2 a) (ad_div_2 a'))). intro H1. + rewrite (ad_div_bit_eq _ _ H0 (ad_eq_complete _ _ H1)) in H. + rewrite (ad_eq_correct a') in H. discriminate H. + trivial. +Qed. + +Lemma ad_neq : + forall a a':ad, + ad_eq a a' = false -> + ad_bit_0 a = negb (ad_bit_0 a') \/ + ad_eq (ad_div_2 a) (ad_div_2 a') = false. +Proof. + intros. cut (ad_bit_0 a = ad_bit_0 a' \/ ad_bit_0 a = negb (ad_bit_0 a')). + intros. elim H0. intro. right. apply ad_div_bit_neq. assumption. + assumption. + intro. left. assumption. + case (ad_bit_0 a); case (ad_bit_0 a'); auto. +Qed. + +Lemma ad_double_or_double_plus_un : + forall a:ad, + {a0 : ad | a = ad_double a0} + {a1 : ad | a = ad_double_plus_un a1}. +Proof. + intro. elim (sumbool_of_bool (ad_bit_0 a)). intro H. right. split with (ad_div_2 a). + rewrite (ad_div_2_double_plus_un a H). reflexivity. + intro H. left. split with (ad_div_2 a). rewrite (ad_div_2_double a H). reflexivity. +Qed.
\ No newline at end of file diff --git a/theories/IntMap/Addr.v b/theories/IntMap/Addr.v new file mode 100644 index 00000000..1370d72d --- /dev/null +++ b/theories/IntMap/Addr.v @@ -0,0 +1,491 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Addr.v,v 1.8.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +(** Representation of adresses by the [positive] type of binary numbers *) + +Require Import Bool. +Require Import ZArith. + +Inductive ad : Set := + | ad_z : ad + | ad_x : positive -> ad. + +Lemma ad_sum : forall a:ad, {p : positive | a = ad_x p} + {a = ad_z}. +Proof. + destruct a; auto. + left; exists p; trivial. +Qed. + +Fixpoint p_xor (p p2:positive) {struct p} : ad := + match p with + | xH => + match p2 with + | xH => ad_z + | xO p'2 => ad_x (xI p'2) + | xI p'2 => ad_x (xO p'2) + end + | xO p' => + match p2 with + | xH => ad_x (xI p') + | xO p'2 => + match p_xor p' p'2 with + | ad_z => ad_z + | ad_x p'' => ad_x (xO p'') + end + | xI p'2 => + match p_xor p' p'2 with + | ad_z => ad_x 1 + | ad_x p'' => ad_x (xI p'') + end + end + | xI p' => + match p2 with + | xH => ad_x (xO p') + | xO p'2 => + match p_xor p' p'2 with + | ad_z => ad_x 1 + | ad_x p'' => ad_x (xI p'') + end + | xI p'2 => + match p_xor p' p'2 with + | ad_z => ad_z + | ad_x p'' => ad_x (xO p'') + end + end + end. + +Definition ad_xor (a a':ad) := + match a with + | ad_z => a' + | ad_x p => match a' with + | ad_z => a + | ad_x p' => p_xor p p' + end + end. + +Lemma ad_xor_neutral_left : forall a:ad, ad_xor ad_z a = a. +Proof. + trivial. +Qed. + +Lemma ad_xor_neutral_right : forall a:ad, ad_xor a ad_z = a. +Proof. + destruct a; trivial. +Qed. + +Lemma ad_xor_comm : forall a a':ad, ad_xor a a' = ad_xor a' a. +Proof. + destruct a; destruct a'; simpl in |- *; auto. + generalize p0; clear p0; induction p as [p Hrecp| p Hrecp| ]; simpl in |- *; + auto. + destruct p0; simpl in |- *; trivial; intros. + rewrite Hrecp; trivial. + rewrite Hrecp; trivial. + destruct p0; simpl in |- *; trivial; intros. + rewrite Hrecp; trivial. + rewrite Hrecp; trivial. + destruct p0 as [p| p| ]; simpl in |- *; auto. +Qed. + +Lemma ad_xor_nilpotent : forall a:ad, ad_xor a a = ad_z. +Proof. + destruct a; trivial. + simpl in |- *. induction p as [p IHp| p IHp| ]; trivial. + simpl in |- *. rewrite IHp; reflexivity. + simpl in |- *. rewrite IHp; reflexivity. +Qed. + +Fixpoint ad_bit_1 (p:positive) : nat -> bool := + match p with + | xH => fun n:nat => match n with + | O => true + | S _ => false + end + | xO p => + fun n:nat => match n with + | O => false + | S n' => ad_bit_1 p n' + end + | xI p => fun n:nat => match n with + | O => true + | S n' => ad_bit_1 p n' + end + end. + +Definition ad_bit (a:ad) := + match a with + | ad_z => fun _:nat => false + | ad_x p => ad_bit_1 p + end. + +Definition eqf (f g:nat -> bool) := forall n:nat, f n = g n. + +Lemma ad_faithful_1 : forall a:ad, eqf (ad_bit ad_z) (ad_bit a) -> ad_z = a. +Proof. + destruct a. trivial. + induction p as [p IHp| p IHp| ]; intro H. absurd (ad_z = ad_x p). discriminate. + exact (IHp (fun n:nat => H (S n))). + absurd (ad_z = ad_x p). discriminate. + exact (IHp (fun n:nat => H (S n))). + absurd (false = true). discriminate. + exact (H 0). +Qed. + +Lemma ad_faithful_2 : + forall a:ad, eqf (ad_bit (ad_x 1)) (ad_bit a) -> ad_x 1 = a. +Proof. + destruct a. intros. absurd (true = false). discriminate. + exact (H 0). + destruct p. intro H. absurd (ad_z = ad_x p). discriminate. + exact (ad_faithful_1 (ad_x p) (fun n:nat => H (S n))). + intros. absurd (true = false). discriminate. + exact (H 0). + trivial. +Qed. + +Lemma ad_faithful_3 : + forall (a:ad) (p:positive), + (forall p':positive, eqf (ad_bit (ad_x p)) (ad_bit (ad_x p')) -> p = p') -> + eqf (ad_bit (ad_x (xO p))) (ad_bit a) -> ad_x (xO p) = a. +Proof. + destruct a. intros. cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xO p)))). + intro. rewrite (ad_faithful_1 (ad_x (xO p)) H1). reflexivity. + unfold eqf in |- *. intro. unfold eqf in H0. rewrite H0. reflexivity. + case p. intros. absurd (false = true). discriminate. + exact (H0 0). + intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity. + intros. absurd (false = true). discriminate. + exact (H0 0). +Qed. + +Lemma ad_faithful_4 : + forall (a:ad) (p:positive), + (forall p':positive, eqf (ad_bit (ad_x p)) (ad_bit (ad_x p')) -> p = p') -> + eqf (ad_bit (ad_x (xI p))) (ad_bit a) -> ad_x (xI p) = a. +Proof. + destruct a. intros. cut (eqf (ad_bit ad_z) (ad_bit (ad_x (xI p)))). + intro. rewrite (ad_faithful_1 (ad_x (xI p)) H1). reflexivity. + unfold eqf in |- *. intro. unfold eqf in H0. rewrite H0. reflexivity. + case p. intros. rewrite (H p0 (fun n:nat => H0 (S n))). reflexivity. + intros. absurd (true = false). discriminate. + exact (H0 0). + intros. absurd (ad_z = ad_x p0). discriminate. + cut (eqf (ad_bit (ad_x 1)) (ad_bit (ad_x (xI p0)))). + intro. exact (ad_faithful_1 (ad_x p0) (fun n:nat => H1 (S n))). + unfold eqf in |- *. unfold eqf in H0. intro. rewrite H0. reflexivity. +Qed. + +Lemma ad_faithful : forall a a':ad, eqf (ad_bit a) (ad_bit a') -> a = a'. +Proof. + destruct a. exact ad_faithful_1. + induction p. intros a' H. apply ad_faithful_4. intros. cut (ad_x p = ad_x p'). + intro. inversion H1. reflexivity. + exact (IHp (ad_x p') H0). + assumption. + intros. apply ad_faithful_3. intros. cut (ad_x p = ad_x p'). intro. inversion H1. reflexivity. + exact (IHp (ad_x p') H0). + assumption. + exact ad_faithful_2. +Qed. + +Definition adf_xor (f g:nat -> bool) (n:nat) := xorb (f n) (g n). + +Lemma ad_xor_sem_1 : forall a':ad, ad_bit (ad_xor ad_z a') 0 = ad_bit a' 0. +Proof. + trivial. +Qed. + +Lemma ad_xor_sem_2 : + forall a':ad, ad_bit (ad_xor (ad_x 1) a') 0 = negb (ad_bit a' 0). +Proof. + intro. case a'. trivial. + simpl in |- *. intro. + case p; trivial. +Qed. + +Lemma ad_xor_sem_3 : + forall (p:positive) (a':ad), + ad_bit (ad_xor (ad_x (xO p)) a') 0 = ad_bit a' 0. +Proof. + intros. case a'. trivial. + simpl in |- *. intro. + case p0; trivial. intro. + case (p_xor p p1); trivial. + intro. case (p_xor p p1); trivial. +Qed. + +Lemma ad_xor_sem_4 : + forall (p:positive) (a':ad), + ad_bit (ad_xor (ad_x (xI p)) a') 0 = negb (ad_bit a' 0). +Proof. + intros. case a'. trivial. + simpl in |- *. intro. case p0; trivial. intro. + case (p_xor p p1); trivial. + intro. + case (p_xor p p1); trivial. +Qed. + +Lemma ad_xor_sem_5 : + forall a a':ad, ad_bit (ad_xor a a') 0 = adf_xor (ad_bit a) (ad_bit a') 0. +Proof. + destruct a. intro. change (ad_bit a' 0 = xorb false (ad_bit a' 0)) in |- *. rewrite false_xorb. trivial. + case p. exact ad_xor_sem_4. + intros. change (ad_bit (ad_xor (ad_x (xO p0)) a') 0 = xorb false (ad_bit a' 0)) + in |- *. + rewrite false_xorb. apply ad_xor_sem_3. exact ad_xor_sem_2. +Qed. + +Lemma ad_xor_sem_6 : + forall n:nat, + (forall a a':ad, ad_bit (ad_xor a a') n = adf_xor (ad_bit a) (ad_bit a') n) -> + forall a a':ad, + ad_bit (ad_xor a a') (S n) = adf_xor (ad_bit a) (ad_bit a') (S n). +Proof. + intros. case a. unfold adf_xor in |- *. unfold ad_bit at 2 in |- *. rewrite false_xorb. reflexivity. + case a'. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. intro. rewrite xorb_false. reflexivity. + intros. case p0. case p. intros. + change + (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xI p1))) (S n) = + adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) + in |- *. + rewrite <- H. simpl in |- *. + case (p_xor p2 p1); trivial. + intros. + change + (ad_bit (ad_xor (ad_x (xI p2)) (ad_x (xO p1))) (S n) = + adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) + in |- *. + rewrite <- H. simpl in |- *. + case (p_xor p2 p1); trivial. + intro. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. unfold ad_bit_1 in |- *. rewrite xorb_false. reflexivity. + case p. intros. + change + (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xI p1))) (S n) = + adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) + in |- *. + rewrite <- H. simpl in |- *. + case (p_xor p2 p1); trivial. + intros. + change + (ad_bit (ad_xor (ad_x (xO p2)) (ad_x (xO p1))) (S n) = + adf_xor (ad_bit (ad_x p2)) (ad_bit (ad_x p1)) n) + in |- *. + rewrite <- H. simpl in |- *. + case (p_xor p2 p1); trivial. + intro. unfold adf_xor in |- *. unfold ad_bit at 3 in |- *. unfold ad_bit_1 in |- *. rewrite xorb_false. reflexivity. + unfold adf_xor in |- *. unfold ad_bit at 2 in |- *. unfold ad_bit_1 in |- *. rewrite false_xorb. simpl in |- *. case p; trivial. +Qed. + +Lemma ad_xor_semantics : + forall a a':ad, eqf (ad_bit (ad_xor a a')) (adf_xor (ad_bit a) (ad_bit a')). +Proof. + unfold eqf in |- *. intros. generalize a a'. elim n. exact ad_xor_sem_5. + exact ad_xor_sem_6. +Qed. + +Lemma eqf_sym : forall f f':nat -> bool, eqf f f' -> eqf f' f. +Proof. + unfold eqf in |- *. intros. rewrite H. reflexivity. +Qed. + +Lemma eqf_refl : forall f:nat -> bool, eqf f f. +Proof. + unfold eqf in |- *. trivial. +Qed. + +Lemma eqf_trans : + forall f f' f'':nat -> bool, eqf f f' -> eqf f' f'' -> eqf f f''. +Proof. + unfold eqf in |- *. intros. rewrite H. exact (H0 n). +Qed. + +Lemma adf_xor_eq : + forall f f':nat -> bool, eqf (adf_xor f f') (fun n:nat => false) -> eqf f f'. +Proof. + unfold eqf in |- *. unfold adf_xor in |- *. intros. apply xorb_eq. apply H. +Qed. + +Lemma ad_xor_eq : forall a a':ad, ad_xor a a' = ad_z -> a = a'. +Proof. + intros. apply ad_faithful. apply adf_xor_eq. apply eqf_trans with (f' := ad_bit (ad_xor a a')). + apply eqf_sym. apply ad_xor_semantics. + rewrite H. unfold eqf in |- *. trivial. +Qed. + +Lemma adf_xor_assoc : + forall f f' f'':nat -> bool, + eqf (adf_xor (adf_xor f f') f'') (adf_xor f (adf_xor f' f'')). +Proof. + unfold eqf in |- *. unfold adf_xor in |- *. intros. apply xorb_assoc. +Qed. + +Lemma eqf_xor_1 : + forall f f' f'' f''':nat -> bool, + eqf f f' -> eqf f'' f''' -> eqf (adf_xor f f'') (adf_xor f' f'''). +Proof. + unfold eqf in |- *. intros. unfold adf_xor in |- *. rewrite H. rewrite H0. reflexivity. +Qed. + +Lemma ad_xor_assoc : + forall a a' a'':ad, ad_xor (ad_xor a a') a'' = ad_xor a (ad_xor a' a''). +Proof. + intros. apply ad_faithful. + apply eqf_trans with + (f' := adf_xor (adf_xor (ad_bit a) (ad_bit a')) (ad_bit a'')). + apply eqf_trans with (f' := adf_xor (ad_bit (ad_xor a a')) (ad_bit a'')). + apply ad_xor_semantics. + apply eqf_xor_1. apply ad_xor_semantics. + apply eqf_refl. + apply eqf_trans with + (f' := adf_xor (ad_bit a) (adf_xor (ad_bit a') (ad_bit a''))). + apply adf_xor_assoc. + apply eqf_trans with (f' := adf_xor (ad_bit a) (ad_bit (ad_xor a' a''))). + apply eqf_xor_1. apply eqf_refl. + apply eqf_sym. apply ad_xor_semantics. + apply eqf_sym. apply ad_xor_semantics. +Qed. + +Definition ad_double (a:ad) := + match a with + | ad_z => ad_z + | ad_x p => ad_x (xO p) + end. + +Definition ad_double_plus_un (a:ad) := + match a with + | ad_z => ad_x 1 + | ad_x p => ad_x (xI p) + end. + +Definition ad_div_2 (a:ad) := + match a with + | ad_z => ad_z + | ad_x xH => ad_z + | ad_x (xO p) => ad_x p + | ad_x (xI p) => ad_x p + end. + +Lemma ad_double_div_2 : forall a:ad, ad_div_2 (ad_double a) = a. +Proof. + destruct a; trivial. +Qed. + +Lemma ad_double_plus_un_div_2 : + forall a:ad, ad_div_2 (ad_double_plus_un a) = a. +Proof. + destruct a; trivial. +Qed. + +Lemma ad_double_inj : forall a0 a1:ad, ad_double a0 = ad_double a1 -> a0 = a1. +Proof. + intros. rewrite <- (ad_double_div_2 a0). rewrite H. apply ad_double_div_2. +Qed. + +Lemma ad_double_plus_un_inj : + forall a0 a1:ad, ad_double_plus_un a0 = ad_double_plus_un a1 -> a0 = a1. +Proof. + intros. rewrite <- (ad_double_plus_un_div_2 a0). rewrite H. apply ad_double_plus_un_div_2. +Qed. + +Definition ad_bit_0 (a:ad) := + match a with + | ad_z => false + | ad_x (xO _) => false + | _ => true + end. + +Lemma ad_double_bit_0 : forall a:ad, ad_bit_0 (ad_double a) = false. +Proof. + destruct a; trivial. +Qed. + +Lemma ad_double_plus_un_bit_0 : + forall a:ad, ad_bit_0 (ad_double_plus_un a) = true. +Proof. + destruct a; trivial. +Qed. + +Lemma ad_div_2_double : + forall a:ad, ad_bit_0 a = false -> ad_double (ad_div_2 a) = a. +Proof. + destruct a. trivial. destruct p. intro H. discriminate H. + intros. reflexivity. + intro H. discriminate H. +Qed. + +Lemma ad_div_2_double_plus_un : + forall a:ad, ad_bit_0 a = true -> ad_double_plus_un (ad_div_2 a) = a. +Proof. + destruct a. intro. discriminate H. + destruct p. intros. reflexivity. + intro H. discriminate H. + intro. reflexivity. +Qed. + +Lemma ad_bit_0_correct : forall a:ad, ad_bit a 0 = ad_bit_0 a. +Proof. + destruct a; trivial. + destruct p; trivial. +Qed. + +Lemma ad_div_2_correct : + forall (a:ad) (n:nat), ad_bit (ad_div_2 a) n = ad_bit a (S n). +Proof. + destruct a; trivial. + destruct p; trivial. +Qed. + +Lemma ad_xor_bit_0 : + forall a a':ad, ad_bit_0 (ad_xor a a') = xorb (ad_bit_0 a) (ad_bit_0 a'). +Proof. + intros. rewrite <- ad_bit_0_correct. rewrite (ad_xor_semantics a a' 0). + unfold adf_xor in |- *. rewrite ad_bit_0_correct. rewrite ad_bit_0_correct. reflexivity. +Qed. + +Lemma ad_xor_div_2 : + forall a a':ad, ad_div_2 (ad_xor a a') = ad_xor (ad_div_2 a) (ad_div_2 a'). +Proof. + intros. apply ad_faithful. unfold eqf in |- *. intro. + rewrite (ad_xor_semantics (ad_div_2 a) (ad_div_2 a') n). + rewrite ad_div_2_correct. + rewrite (ad_xor_semantics a a' (S n)). + unfold adf_xor in |- *. rewrite ad_div_2_correct. rewrite ad_div_2_correct. + reflexivity. +Qed. + +Lemma ad_neg_bit_0 : + forall a a':ad, + ad_bit_0 (ad_xor a a') = true -> ad_bit_0 a = negb (ad_bit_0 a'). +Proof. + intros. rewrite <- true_xorb. rewrite <- H. rewrite ad_xor_bit_0. + rewrite xorb_assoc. rewrite xorb_nilpotent. rewrite xorb_false. reflexivity. +Qed. + +Lemma ad_neg_bit_0_1 : + forall a a':ad, ad_xor a a' = ad_x 1 -> ad_bit_0 a = negb (ad_bit_0 a'). +Proof. + intros. apply ad_neg_bit_0. rewrite H. reflexivity. +Qed. + +Lemma ad_neg_bit_0_2 : + forall (a a':ad) (p:positive), + ad_xor a a' = ad_x (xI p) -> ad_bit_0 a = negb (ad_bit_0 a'). +Proof. + intros. apply ad_neg_bit_0. rewrite H. reflexivity. +Qed. + +Lemma ad_same_bit_0 : + forall (a a':ad) (p:positive), + ad_xor a a' = ad_x (xO p) -> ad_bit_0 a = ad_bit_0 a'. +Proof. + intros. rewrite <- (xorb_false (ad_bit_0 a)). cut (ad_bit_0 (ad_x (xO p)) = false). + intro. rewrite <- H0. rewrite <- H. rewrite ad_xor_bit_0. rewrite <- xorb_assoc. + rewrite xorb_nilpotent. rewrite false_xorb. reflexivity. + reflexivity. +Qed.
\ No newline at end of file diff --git a/theories/IntMap/Adist.v b/theories/IntMap/Adist.v new file mode 100644 index 00000000..cdb4c885 --- /dev/null +++ b/theories/IntMap/Adist.v @@ -0,0 +1,336 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Adist.v,v 1.9.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import ZArith. +Require Import Arith. +Require Import Min. +Require Import Addr. + +Fixpoint ad_plength_1 (p:positive) : nat := + match p with + | xH => 0 + | xI _ => 0 + | xO p' => S (ad_plength_1 p') + end. + +Inductive natinf : Set := + | infty : natinf + | ni : nat -> natinf. + +Definition ad_plength (a:ad) := + match a with + | ad_z => infty + | ad_x p => ni (ad_plength_1 p) + end. + +Lemma ad_plength_infty : forall a:ad, ad_plength a = infty -> a = ad_z. +Proof. + simple induction a; trivial. + unfold ad_plength in |- *; intros; discriminate H. +Qed. + +Lemma ad_plength_zeros : + forall (a:ad) (n:nat), + ad_plength a = ni n -> forall k:nat, k < n -> ad_bit a k = false. +Proof. + simple induction a; trivial. + simple induction p. simple induction n. intros. inversion H1. + simple induction k. simpl in H1. discriminate H1. + intros. simpl in H1. discriminate H1. + simple induction k. trivial. + generalize H0. case n. intros. inversion H3. + intros. simpl in |- *. unfold ad_bit in H. apply (H n0). simpl in H1. inversion H1. reflexivity. + exact (lt_S_n n1 n0 H3). + simpl in |- *. intros n H. inversion H. intros. inversion H0. +Qed. + +Lemma ad_plength_one : + forall (a:ad) (n:nat), ad_plength a = ni n -> ad_bit a n = true. +Proof. + simple induction a. intros. inversion H. + simple induction p. intros. simpl in H0. inversion H0. reflexivity. + intros. simpl in H0. inversion H0. simpl in |- *. unfold ad_bit in H. apply H. reflexivity. + intros. simpl in H. inversion H. reflexivity. +Qed. + +Lemma ad_plength_first_one : + forall (a:ad) (n:nat), + (forall k:nat, k < n -> ad_bit a k = false) -> + ad_bit a n = true -> ad_plength a = ni n. +Proof. + simple induction a. intros. simpl in H0. discriminate H0. + simple induction p. intros. generalize H0. case n. intros. reflexivity. + intros. absurd (ad_bit (ad_x (xI p0)) 0 = false). trivial with bool. + auto with bool arith. + intros. generalize H0 H1. case n. intros. simpl in H3. discriminate H3. + intros. simpl in |- *. unfold ad_plength in H. + cut (ni (ad_plength_1 p0) = ni n0). intro. inversion H4. reflexivity. + apply H. intros. change (ad_bit (ad_x (xO p0)) (S k) = false) in |- *. apply H2. apply lt_n_S. exact H4. + exact H3. + intro. case n. trivial. + intros. simpl in H0. discriminate H0. +Qed. + +Definition ni_min (d d':natinf) := + match d with + | infty => d' + | ni n => match d' with + | infty => d + | ni n' => ni (min n n') + end + end. + +Lemma ni_min_idemp : forall d:natinf, ni_min d d = d. +Proof. + simple induction d; trivial. + unfold ni_min in |- *. + simple induction n; trivial. + intros. + simpl in |- *. + inversion H. + rewrite H1. + rewrite H1. + reflexivity. +Qed. + +Lemma ni_min_comm : forall d d':natinf, ni_min d d' = ni_min d' d. +Proof. + simple induction d. simple induction d'; trivial. + simple induction d'; trivial. elim n. simple induction n0; trivial. + intros. elim n1; trivial. intros. unfold ni_min in H. cut (min n0 n2 = min n2 n0). + intro. unfold ni_min in |- *. simpl in |- *. rewrite H1. reflexivity. + cut (ni (min n0 n2) = ni (min n2 n0)). intros. + inversion H1; trivial. + exact (H n2). +Qed. + +Lemma ni_min_assoc : + forall d d' d'':natinf, ni_min (ni_min d d') d'' = ni_min d (ni_min d' d''). +Proof. + simple induction d; trivial. simple induction d'; trivial. + simple induction d''; trivial. + unfold ni_min in |- *. intro. cut (min (min n n0) n1 = min n (min n0 n1)). + intro. rewrite H. reflexivity. + generalize n0 n1. elim n; trivial. + simple induction n3; trivial. simple induction n5; trivial. + intros. simpl in |- *. auto. +Qed. + +Lemma ni_min_O_l : forall d:natinf, ni_min (ni 0) d = ni 0. +Proof. + simple induction d; trivial. +Qed. + +Lemma ni_min_O_r : forall d:natinf, ni_min d (ni 0) = ni 0. +Proof. + intros. rewrite ni_min_comm. apply ni_min_O_l. +Qed. + +Lemma ni_min_inf_l : forall d:natinf, ni_min infty d = d. +Proof. + trivial. +Qed. + +Lemma ni_min_inf_r : forall d:natinf, ni_min d infty = d. +Proof. + simple induction d; trivial. +Qed. + +Definition ni_le (d d':natinf) := ni_min d d' = d. + +Lemma ni_le_refl : forall d:natinf, ni_le d d. +Proof. + exact ni_min_idemp. +Qed. + +Lemma ni_le_antisym : forall d d':natinf, ni_le d d' -> ni_le d' d -> d = d'. +Proof. + unfold ni_le in |- *. intros d d'. rewrite ni_min_comm. intro H. rewrite H. trivial. +Qed. + +Lemma ni_le_trans : + forall d d' d'':natinf, ni_le d d' -> ni_le d' d'' -> ni_le d d''. +Proof. + unfold ni_le in |- *. intros. rewrite <- H. rewrite ni_min_assoc. rewrite H0. reflexivity. +Qed. + +Lemma ni_le_min_1 : forall d d':natinf, ni_le (ni_min d d') d. +Proof. + unfold ni_le in |- *. intros. rewrite (ni_min_comm d d'). rewrite ni_min_assoc. + rewrite ni_min_idemp. reflexivity. +Qed. + +Lemma ni_le_min_2 : forall d d':natinf, ni_le (ni_min d d') d'. +Proof. + unfold ni_le in |- *. intros. rewrite ni_min_assoc. rewrite ni_min_idemp. reflexivity. +Qed. + +Lemma ni_min_case : forall d d':natinf, ni_min d d' = d \/ ni_min d d' = d'. +Proof. + simple induction d. intro. right. exact (ni_min_inf_l d'). + simple induction d'. left. exact (ni_min_inf_r (ni n)). + unfold ni_min in |- *. cut (forall n0:nat, min n n0 = n \/ min n n0 = n0). + intros. case (H n0). intro. left. rewrite H0. reflexivity. + intro. right. rewrite H0. reflexivity. + elim n. intro. left. reflexivity. + simple induction n1. right. reflexivity. + intros. case (H n2). intro. left. simpl in |- *. rewrite H1. reflexivity. + intro. right. simpl in |- *. rewrite H1. reflexivity. +Qed. + +Lemma ni_le_total : forall d d':natinf, ni_le d d' \/ ni_le d' d. +Proof. + unfold ni_le in |- *. intros. rewrite (ni_min_comm d' d). apply ni_min_case. +Qed. + +Lemma ni_le_min_induc : + forall d d' dm:natinf, + ni_le dm d -> + ni_le dm d' -> + (forall d'':natinf, ni_le d'' d -> ni_le d'' d' -> ni_le d'' dm) -> + ni_min d d' = dm. +Proof. + intros. case (ni_min_case d d'). intro. rewrite H2. + apply ni_le_antisym. apply H1. apply ni_le_refl. + exact H2. + exact H. + intro. rewrite H2. apply ni_le_antisym. apply H1. unfold ni_le in |- *. rewrite ni_min_comm. exact H2. + apply ni_le_refl. + exact H0. +Qed. + +Lemma le_ni_le : forall m n:nat, m <= n -> ni_le (ni m) (ni n). +Proof. + cut (forall m n:nat, m <= n -> min m n = m). + intros. unfold ni_le, ni_min in |- *. rewrite (H m n H0). reflexivity. + simple induction m. trivial. + simple induction n0. intro. inversion H0. + intros. simpl in |- *. rewrite (H n1 (le_S_n n n1 H1)). reflexivity. +Qed. + +Lemma ni_le_le : forall m n:nat, ni_le (ni m) (ni n) -> m <= n. +Proof. + unfold ni_le in |- *. unfold ni_min in |- *. intros. inversion H. apply le_min_r. +Qed. + +Lemma ad_plength_lb : + forall (a:ad) (n:nat), + (forall k:nat, k < n -> ad_bit a k = false) -> ni_le (ni n) (ad_plength a). +Proof. + simple induction a. intros. exact (ni_min_inf_r (ni n)). + intros. unfold ad_plength in |- *. apply le_ni_le. case (le_or_lt n (ad_plength_1 p)). trivial. + intro. absurd (ad_bit (ad_x p) (ad_plength_1 p) = false). + rewrite + (ad_plength_one (ad_x p) (ad_plength_1 p) + (refl_equal (ad_plength (ad_x p)))). + discriminate. + apply H. exact H0. +Qed. + +Lemma ad_plength_ub : + forall (a:ad) (n:nat), ad_bit a n = true -> ni_le (ad_plength a) (ni n). +Proof. + simple induction a. intros. discriminate H. + intros. unfold ad_plength in |- *. apply le_ni_le. case (le_or_lt (ad_plength_1 p) n). trivial. + intro. absurd (ad_bit (ad_x p) n = true). + rewrite + (ad_plength_zeros (ad_x p) (ad_plength_1 p) + (refl_equal (ad_plength (ad_x p))) n H0). + discriminate. + exact H. +Qed. + + +(** We define an ultrametric distance between addresses: + $d(a,a')=1/2^pd(a,a')$, + where $pd(a,a')$ is the number of identical bits at the beginning + of $a$ and $a'$ (infinity if $a=a'$). + Instead of working with $d$, we work with $pd$, namely + [ad_pdist]: *) + +Definition ad_pdist (a a':ad) := ad_plength (ad_xor a a'). + +(** d is a distance, so $d(a,a')=0$ iff $a=a'$; this means that + $pd(a,a')=infty$ iff $a=a'$: *) + +Lemma ad_pdist_eq_1 : forall a:ad, ad_pdist a a = infty. +Proof. + intros. unfold ad_pdist in |- *. rewrite ad_xor_nilpotent. reflexivity. +Qed. + +Lemma ad_pdist_eq_2 : forall a a':ad, ad_pdist a a' = infty -> a = a'. +Proof. + intros. apply ad_xor_eq. apply ad_plength_infty. exact H. +Qed. + +(** $d$ is a distance, so $d(a,a')=d(a',a)$: *) + +Lemma ad_pdist_comm : forall a a':ad, ad_pdist a a' = ad_pdist a' a. +Proof. + unfold ad_pdist in |- *. intros. rewrite ad_xor_comm. reflexivity. +Qed. + +(** $d$ is an ultrametric distance, that is, not only $d(a,a')\leq + d(a,a'')+d(a'',a')$, + but in fact $d(a,a')\leq max(d(a,a''),d(a'',a'))$. + This means that $min(pd(a,a''),pd(a'',a'))<=pd(a,a')$ (lemma [ad_pdist_ultra] below). + This follows from the fact that $a ~Ra~|a| = 1/2^{\texttt{ad\_plength}}(a))$ + is an ultrametric norm, i.e. that $|a-a'| \leq max (|a-a''|, |a''-a'|)$, + or equivalently that $|a+b|<=max(|a|,|b|)$, i.e. that + min $(\texttt{ad\_plength}(a), \texttt{ad\_plength}(b)) \leq + \texttt{ad\_plength} (a~\texttt{xor}~ b)$ + (lemma [ad_plength_ultra]). +*) + +Lemma ad_plength_ultra_1 : + forall a a':ad, + ni_le (ad_plength a) (ad_plength a') -> + ni_le (ad_plength a) (ad_plength (ad_xor a a')). +Proof. + simple induction a. intros. unfold ni_le in H. unfold ad_plength at 1 3 in H. + rewrite (ni_min_inf_l (ad_plength a')) in H. + rewrite (ad_plength_infty a' H). simpl in |- *. apply ni_le_refl. + intros. unfold ad_plength at 1 in |- *. apply ad_plength_lb. intros. + cut (forall a'':ad, ad_xor (ad_x p) a' = a'' -> ad_bit a'' k = false). + intros. apply H1. reflexivity. + intro a''. case a''. intro. reflexivity. + intros. rewrite <- H1. rewrite (ad_xor_semantics (ad_x p) a' k). unfold adf_xor in |- *. + rewrite + (ad_plength_zeros (ad_x p) (ad_plength_1 p) + (refl_equal (ad_plength (ad_x p))) k H0). + generalize H. case a'. trivial. + intros. cut (ad_bit (ad_x p1) k = false). intros. rewrite H3. reflexivity. + apply ad_plength_zeros with (n := ad_plength_1 p1). reflexivity. + apply (lt_le_trans k (ad_plength_1 p) (ad_plength_1 p1)). exact H0. + apply ni_le_le. exact H2. +Qed. + +Lemma ad_plength_ultra : + forall a a':ad, + ni_le (ni_min (ad_plength a) (ad_plength a')) (ad_plength (ad_xor a a')). +Proof. + intros. case (ni_le_total (ad_plength a) (ad_plength a')). intro. + cut (ni_min (ad_plength a) (ad_plength a') = ad_plength a). + intro. rewrite H0. apply ad_plength_ultra_1. exact H. + exact H. + intro. cut (ni_min (ad_plength a) (ad_plength a') = ad_plength a'). + intro. rewrite H0. rewrite ad_xor_comm. apply ad_plength_ultra_1. exact H. + rewrite ni_min_comm. exact H. +Qed. + +Lemma ad_pdist_ultra : + forall a a' a'':ad, + ni_le (ni_min (ad_pdist a a'') (ad_pdist a'' a')) (ad_pdist a a'). +Proof. + intros. unfold ad_pdist in |- *. cut (ad_xor (ad_xor a a'') (ad_xor a'' a') = ad_xor a a'). + intro. rewrite <- H. apply ad_plength_ultra. + rewrite ad_xor_assoc. rewrite <- (ad_xor_assoc a'' a'' a'). rewrite ad_xor_nilpotent. + rewrite ad_xor_neutral_left. reflexivity. +Qed.
\ No newline at end of file diff --git a/theories/IntMap/Allmaps.v b/theories/IntMap/Allmaps.v new file mode 100644 index 00000000..68744220 --- /dev/null +++ b/theories/IntMap/Allmaps.v @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Allmaps.v,v 1.3.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Export Addr. +Require Export Adist. +Require Export Addec. +Require Export Map. + +Require Export Fset. +Require Export Mapaxioms. +Require Export Mapiter. + +Require Export Mapsubset. +Require Export Lsort. +Require Export Mapfold. +Require Export Mapcard. +Require Export Mapcanon. +Require Export Mapc. +Require Export Maplists. +Require Export Adalloc.
\ No newline at end of file diff --git a/theories/IntMap/Fset.v b/theories/IntMap/Fset.v new file mode 100644 index 00000000..8d217be9 --- /dev/null +++ b/theories/IntMap/Fset.v @@ -0,0 +1,371 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Fset.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +(*s Sets operations on maps *) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. + +Section Dom. + + Variables A B : Set. + + Fixpoint MapDomRestrTo (m:Map A) : Map B -> Map A := + match m with + | M0 => fun _:Map B => M0 A + | M1 a y => + fun m':Map B => match MapGet B m' a with + | NONE => M0 A + | _ => m + end + | M2 m1 m2 => + fun m':Map B => + match m' with + | M0 => M0 A + | M1 a' y' => + match MapGet A m a' with + | NONE => M0 A + | SOME y => M1 A a' y + end + | M2 m'1 m'2 => + makeM2 A (MapDomRestrTo m1 m'1) (MapDomRestrTo m2 m'2) + end + end. + + Lemma MapDomRestrTo_semantics : + forall (m:Map A) (m':Map B), + eqm A (MapGet A (MapDomRestrTo m m')) + (fun a0:ad => + match MapGet B m' a0 with + | NONE => NONE A + | _ => MapGet A m a0 + end). + Proof. + unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial. + intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a a1)). intro H. rewrite H. + rewrite <- (ad_eq_complete _ _ H). case (MapGet B m' a). reflexivity. + intro. apply M1_semantics_1. + intro H. rewrite H. case (MapGet B m' a). + case (MapGet B m' a1); reflexivity. + case (MapGet B m' a1); intros; exact (M1_semantics_2 A a a1 a0 H). + simple induction m'. trivial. + unfold MapDomRestrTo in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). + intro H1. + rewrite (ad_eq_complete _ _ H1). rewrite (M1_semantics_1 B a1 a0). + case (MapGet A (M2 A m0 m1) a1). reflexivity. + intro. apply M1_semantics_1. + intro H1. rewrite (M1_semantics_2 B a a1 a0 H1). case (MapGet A (M2 A m0 m1) a). reflexivity. + intro. exact (M1_semantics_2 A a a1 a2 H1). + intros. change + (MapGet A (makeM2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3)) a = + match MapGet B (M2 B m2 m3) a with + | NONE => NONE A + | SOME _ => MapGet A (M2 A m0 m1) a + end) in |- *. + rewrite (makeM2_M2 A (MapDomRestrTo m0 m2) (MapDomRestrTo m1 m3) a). + rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)). + rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a). + case (ad_bit_0 a); reflexivity. + Qed. + + Fixpoint MapDomRestrBy (m:Map A) : Map B -> Map A := + match m with + | M0 => fun _:Map B => M0 A + | M1 a y => + fun m':Map B => match MapGet B m' a with + | NONE => m + | _ => M0 A + end + | M2 m1 m2 => + fun m':Map B => + match m' with + | M0 => m + | M1 a' y' => MapRemove A m a' + | M2 m'1 m'2 => + makeM2 A (MapDomRestrBy m1 m'1) (MapDomRestrBy m2 m'2) + end + end. + + Lemma MapDomRestrBy_semantics : + forall (m:Map A) (m':Map B), + eqm A (MapGet A (MapDomRestrBy m m')) + (fun a0:ad => + match MapGet B m' a0 with + | NONE => MapGet A m a0 + | _ => NONE A + end). + Proof. + unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (MapGet B m' a); trivial. + intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a a1)). intro H. rewrite H. + rewrite (ad_eq_complete _ _ H). case (MapGet B m' a1). apply M1_semantics_1. + trivial. + intro H. rewrite H. case (MapGet B m' a). rewrite (M1_semantics_2 A a a1 a0 H). + case (MapGet B m' a1); trivial. + case (MapGet B m' a1); trivial. + simple induction m'. trivial. + unfold MapDomRestrBy in |- *. intros. rewrite (MapRemove_semantics A (M2 A m0 m1) a a1). + elim (sumbool_of_bool (ad_eq a a1)). intro H1. rewrite H1. rewrite (ad_eq_complete _ _ H1). + rewrite (M1_semantics_1 B a1 a0). reflexivity. + intro H1. rewrite H1. rewrite (M1_semantics_2 B a a1 a0 H1). reflexivity. + intros. change + (MapGet A (makeM2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3)) a = + match MapGet B (M2 B m2 m3) a with + | NONE => MapGet A (M2 A m0 m1) a + | SOME _ => NONE A + end) in |- *. + rewrite (makeM2_M2 A (MapDomRestrBy m0 m2) (MapDomRestrBy m1 m3) a). + rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)). + rewrite (MapGet_M2_bit_0_if B m2 m3 a). rewrite (MapGet_M2_bit_0_if A m0 m1 a). + case (ad_bit_0 a); reflexivity. + Qed. + + Definition in_dom (a:ad) (m:Map A) := + match MapGet A m a with + | NONE => false + | _ => true + end. + + Lemma in_dom_M0 : forall a:ad, in_dom a (M0 A) = false. + Proof. + trivial. + Qed. + + Lemma in_dom_M1 : forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = ad_eq a a0. + Proof. + unfold in_dom in |- *. intros. simpl in |- *. case (ad_eq a a0); reflexivity. + Qed. + + Lemma in_dom_M1_1 : forall (a:ad) (y:A), in_dom a (M1 A a y) = true. + Proof. + intros. rewrite in_dom_M1. apply ad_eq_correct. + Qed. + + Lemma in_dom_M1_2 : + forall (a a0:ad) (y:A), in_dom a0 (M1 A a y) = true -> a = a0. + Proof. + intros. apply (ad_eq_complete a a0). rewrite (in_dom_M1 a a0 y) in H. assumption. + Qed. + + Lemma in_dom_some : + forall (m:Map A) (a:ad), + in_dom a m = true -> {y : A | MapGet A m a = SOME A y}. + Proof. + unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). trivial. + intro H0. rewrite H0 in H. discriminate H. + Qed. + + Lemma in_dom_none : + forall (m:Map A) (a:ad), in_dom a m = false -> MapGet A m a = NONE A. + Proof. + unfold in_dom in |- *. intros. elim (option_sum _ (MapGet A m a)). intro H0. elim H0. + intros y H1. rewrite H1 in H. discriminate H. + trivial. + Qed. + + Lemma in_dom_put : + forall (m:Map A) (a0:ad) (y0:A) (a:ad), + in_dom a (MapPut A m a0 y0) = orb (ad_eq a a0) (in_dom a m). + Proof. + unfold in_dom in |- *. intros. rewrite (MapPut_semantics A m a0 y0 a). + elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. + rewrite H. rewrite orb_true_b. reflexivity. + intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. rewrite orb_false_b. + reflexivity. + Qed. + + Lemma in_dom_put_behind : + forall (m:Map A) (a0:ad) (y0:A) (a:ad), + in_dom a (MapPut_behind A m a0 y0) = orb (ad_eq a a0) (in_dom a m). + Proof. + unfold in_dom in |- *. intros. rewrite (MapPut_behind_semantics A m a0 y0 a). + elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. + rewrite H. case (MapGet A m a); reflexivity. + intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. case (MapGet A m a); trivial. + Qed. + + Lemma in_dom_remove : + forall (m:Map A) (a0 a:ad), + in_dom a (MapRemove A m a0) = andb (negb (ad_eq a a0)) (in_dom a m). + Proof. + unfold in_dom in |- *. intros. rewrite (MapRemove_semantics A m a0 a). + elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. + rewrite H. reflexivity. + intro H. rewrite H. rewrite (ad_eq_comm a a0) in H. rewrite H. + case (MapGet A m a); reflexivity. + Qed. + + Lemma in_dom_merge : + forall (m m':Map A) (a:ad), + in_dom a (MapMerge A m m') = orb (in_dom a m) (in_dom a m'). + Proof. + unfold in_dom in |- *. intros. rewrite (MapMerge_semantics A m m' a). + elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0. + case (MapGet A m a); reflexivity. + intro H. rewrite H. rewrite orb_b_false. reflexivity. + Qed. + + Lemma in_dom_delta : + forall (m m':Map A) (a:ad), + in_dom a (MapDelta A m m') = xorb (in_dom a m) (in_dom a m'). + Proof. + unfold in_dom in |- *. intros. rewrite (MapDelta_semantics A m m' a). + elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y H0. rewrite H0. + case (MapGet A m a); reflexivity. + intro H. rewrite H. case (MapGet A m a); reflexivity. + Qed. + +End Dom. + +Section InDom. + + Variables A B : Set. + + Lemma in_dom_restrto : + forall (m:Map A) (m':Map B) (a:ad), + in_dom A a (MapDomRestrTo A B m m') = + andb (in_dom A a m) (in_dom B a m'). + Proof. + unfold in_dom in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a). + elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0. + rewrite andb_b_true. reflexivity. + intro H. rewrite H. rewrite andb_b_false. reflexivity. + Qed. + + Lemma in_dom_restrby : + forall (m:Map A) (m':Map B) (a:ad), + in_dom A a (MapDomRestrBy A B m m') = + andb (in_dom A a m) (negb (in_dom B a m')). + Proof. + unfold in_dom in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a). + elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y H0. rewrite H0. + unfold negb in |- *. rewrite andb_b_false. reflexivity. + intro H. rewrite H. unfold negb in |- *. rewrite andb_b_true. reflexivity. + Qed. + +End InDom. + +Definition FSet := Map unit. + +Section FSetDefs. + + Variable A : Set. + + Definition in_FSet : ad -> FSet -> bool := in_dom unit. + + Fixpoint MapDom (m:Map A) : FSet := + match m with + | M0 => M0 unit + | M1 a _ => M1 unit a tt + | M2 m m' => M2 unit (MapDom m) (MapDom m') + end. + + Lemma MapDom_semantics_1 : + forall (m:Map A) (a:ad) (y:A), + MapGet A m a = SOME A y -> in_FSet a (MapDom m) = true. + Proof. + simple induction m. intros. discriminate H. + unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0 y0. + case (ad_eq a a0). trivial. + intro. discriminate H. + intros m0 H m1 H0 a y. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *. + unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a). + case (ad_bit_0 a). unfold in_FSet, in_dom in H0. intro. apply H0 with (y := y). assumption. + unfold in_FSet, in_dom in H. intro. apply H with (y := y). assumption. + Qed. + + Lemma MapDom_semantics_2 : + forall (m:Map A) (a:ad), + in_FSet a (MapDom m) = true -> {y : A | MapGet A m a = SOME A y}. + Proof. + simple induction m. intros. discriminate H. + unfold MapDom in |- *. unfold in_FSet in |- *. unfold in_dom in |- *. unfold MapGet in |- *. intros a y a0. case (ad_eq a a0). + intro. split with y. reflexivity. + intro. discriminate H. + intros m0 H m1 H0 a. rewrite (MapGet_M2_bit_0_if A m0 m1 a). simpl in |- *. unfold in_FSet in |- *. + unfold in_dom in |- *. rewrite (MapGet_M2_bit_0_if unit (MapDom m0) (MapDom m1) a). + case (ad_bit_0 a). unfold in_FSet, in_dom in H0. intro. apply H0. assumption. + unfold in_FSet, in_dom in H. intro. apply H. assumption. + Qed. + + Lemma MapDom_semantics_3 : + forall (m:Map A) (a:ad), + MapGet A m a = NONE A -> in_FSet a (MapDom m) = false. + Proof. + intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H0. + elim (MapDom_semantics_2 m a H0). intros y H1. rewrite H in H1. discriminate H1. + trivial. + Qed. + + Lemma MapDom_semantics_4 : + forall (m:Map A) (a:ad), + in_FSet a (MapDom m) = false -> MapGet A m a = NONE A. + Proof. + intros. elim (option_sum A (MapGet A m a)). intro H0. elim H0. intros y H1. + rewrite (MapDom_semantics_1 m a y H1) in H. discriminate H. + trivial. + Qed. + + Lemma MapDom_Dom : + forall (m:Map A) (a:ad), in_dom A a m = in_FSet a (MapDom m). + Proof. + intros. elim (sumbool_of_bool (in_FSet a (MapDom m))). intro H. + elim (MapDom_semantics_2 m a H). intros y H0. rewrite H. unfold in_dom in |- *. rewrite H0. + reflexivity. + intro H. rewrite H. unfold in_dom in |- *. rewrite (MapDom_semantics_4 m a H). reflexivity. + Qed. + + Definition FSetUnion (s s':FSet) : FSet := MapMerge unit s s'. + + Lemma in_FSet_union : + forall (s s':FSet) (a:ad), + in_FSet a (FSetUnion s s') = orb (in_FSet a s) (in_FSet a s'). + Proof. + exact (in_dom_merge unit). + Qed. + + Definition FSetInter (s s':FSet) : FSet := MapDomRestrTo unit unit s s'. + + Lemma in_FSet_inter : + forall (s s':FSet) (a:ad), + in_FSet a (FSetInter s s') = andb (in_FSet a s) (in_FSet a s'). + Proof. + exact (in_dom_restrto unit unit). + Qed. + + Definition FSetDiff (s s':FSet) : FSet := MapDomRestrBy unit unit s s'. + + Lemma in_FSet_diff : + forall (s s':FSet) (a:ad), + in_FSet a (FSetDiff s s') = andb (in_FSet a s) (negb (in_FSet a s')). + Proof. + exact (in_dom_restrby unit unit). + Qed. + + Definition FSetDelta (s s':FSet) : FSet := MapDelta unit s s'. + + Lemma in_FSet_delta : + forall (s s':FSet) (a:ad), + in_FSet a (FSetDelta s s') = xorb (in_FSet a s) (in_FSet a s'). + Proof. + exact (in_dom_delta unit). + Qed. + +End FSetDefs. + +Lemma FSet_Dom : forall s:FSet, MapDom unit s = s. +Proof. + simple induction s. trivial. + simpl in |- *. intros a t. elim t. reflexivity. + intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. +Qed.
\ No newline at end of file diff --git a/theories/IntMap/Lsort.v b/theories/IntMap/Lsort.v new file mode 100644 index 00000000..48972872 --- /dev/null +++ b/theories/IntMap/Lsort.v @@ -0,0 +1,628 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Lsort.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import Arith. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import List. +Require Import Mapiter. + +Section LSort. + + Variable A : Set. + + Fixpoint ad_less_1 (a a':ad) (p:positive) {struct p} : bool := + match p with + | xO p' => ad_less_1 (ad_div_2 a) (ad_div_2 a') p' + | _ => andb (negb (ad_bit_0 a)) (ad_bit_0 a') + end. + + Definition ad_less (a a':ad) := + match ad_xor a a' with + | ad_z => false + | ad_x p => ad_less_1 a a' p + end. + + Lemma ad_bit_0_less : + forall a a':ad, + ad_bit_0 a = false -> ad_bit_0 a' = true -> ad_less a a' = true. + Proof. + intros. elim (ad_sum (ad_xor a a')). intro H1. elim H1. intros p H2. unfold ad_less in |- *. + rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. + intros. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H5. + rewrite H in H5. rewrite H0 in H5. discriminate H5. + rewrite H4. reflexivity. + intro. simpl in |- *. rewrite H. rewrite H0. reflexivity. + intro H1. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H2. + rewrite H in H2. rewrite H0 in H2. discriminate H2. + rewrite H1. reflexivity. + Qed. + + Lemma ad_bit_0_gt : + forall a a':ad, + ad_bit_0 a = true -> ad_bit_0 a' = false -> ad_less a a' = false. + Proof. + intros. elim (ad_sum (ad_xor a a')). intro H1. elim H1. intros p H2. unfold ad_less in |- *. + rewrite H2. generalize H2. elim p. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. + intros. cut (ad_bit_0 (ad_xor a a') = false). intro. rewrite (ad_xor_bit_0 a a') in H5. + rewrite H in H5. rewrite H0 in H5. discriminate H5. + rewrite H4. reflexivity. + intro. simpl in |- *. rewrite H. rewrite H0. reflexivity. + intro H1. unfold ad_less in |- *. rewrite H1. reflexivity. + Qed. + + Lemma ad_less_not_refl : forall a:ad, ad_less a a = false. + Proof. + intro. unfold ad_less in |- *. rewrite (ad_xor_nilpotent a). reflexivity. + Qed. + + Lemma ad_ind_double : + forall (a:ad) (P:ad -> Prop), + P ad_z -> + (forall a:ad, P a -> P (ad_double a)) -> + (forall a:ad, P a -> P (ad_double_plus_un a)) -> P a. + Proof. + intros; elim a. trivial. + simple induction p. intros. + apply (H1 (ad_x p0)); trivial. + intros; apply (H0 (ad_x p0)); trivial. + intros; apply (H1 ad_z); assumption. + Qed. + + Lemma ad_rec_double : + forall (a:ad) (P:ad -> Set), + P ad_z -> + (forall a:ad, P a -> P (ad_double a)) -> + (forall a:ad, P a -> P (ad_double_plus_un a)) -> P a. + Proof. + intros; elim a. trivial. + simple induction p. intros. + apply (H1 (ad_x p0)); trivial. + intros; apply (H0 (ad_x p0)); trivial. + intros; apply (H1 ad_z); assumption. + Qed. + + Lemma ad_less_def_1 : + forall a a':ad, ad_less (ad_double a) (ad_double a') = ad_less a a'. + Proof. + simple induction a. simple induction a'. reflexivity. + trivial. + simple induction a'. unfold ad_less in |- *. simpl in |- *. elim p; trivial. + unfold ad_less in |- *. simpl in |- *. intro. case (p_xor p p0). reflexivity. + trivial. + Qed. + + Lemma ad_less_def_2 : + forall a a':ad, + ad_less (ad_double_plus_un a) (ad_double_plus_un a') = ad_less a a'. + Proof. + simple induction a. simple induction a'. reflexivity. + trivial. + simple induction a'. unfold ad_less in |- *. simpl in |- *. elim p; trivial. + unfold ad_less in |- *. simpl in |- *. intro. case (p_xor p p0). reflexivity. + trivial. + Qed. + + Lemma ad_less_def_3 : + forall a a':ad, ad_less (ad_double a) (ad_double_plus_un a') = true. + Proof. + intros. apply ad_bit_0_less. apply ad_double_bit_0. + apply ad_double_plus_un_bit_0. + Qed. + + Lemma ad_less_def_4 : + forall a a':ad, ad_less (ad_double_plus_un a) (ad_double a') = false. + Proof. + intros. apply ad_bit_0_gt. apply ad_double_plus_un_bit_0. + apply ad_double_bit_0. + Qed. + + Lemma ad_less_z : forall a:ad, ad_less a ad_z = false. + Proof. + simple induction a. reflexivity. + unfold ad_less in |- *. intro. rewrite (ad_xor_neutral_right (ad_x p)). elim p; trivial. + Qed. + + Lemma ad_z_less_1 : + forall a:ad, ad_less ad_z a = true -> {p : positive | a = ad_x p}. + Proof. + simple induction a. intro. discriminate H. + intros. split with p. reflexivity. + Qed. + + Lemma ad_z_less_2 : forall a:ad, ad_less ad_z a = false -> a = ad_z. + Proof. + simple induction a. trivial. + unfold ad_less in |- *. simpl in |- *. cut (forall p:positive, ad_less_1 ad_z (ad_x p) p = false -> False). + intros. elim (H p H0). + simple induction p. intros. discriminate H0. + intros. exact (H H0). + intro. discriminate H. + Qed. + + Lemma ad_less_trans : + forall a a' a'':ad, + ad_less a a' = true -> ad_less a' a'' = true -> ad_less a a'' = true. + Proof. + intro a. apply ad_ind_double with + (P := fun a:ad => + forall a' a'':ad, + ad_less a a' = true -> + ad_less a' a'' = true -> ad_less a a'' = true). + intros. elim (sumbool_of_bool (ad_less ad_z a'')). trivial. + intro H1. rewrite (ad_z_less_2 a'' H1) in H0. rewrite (ad_less_z a') in H0. discriminate H0. + intros a0 H a'. apply ad_ind_double with + (P := fun a':ad => + forall a'':ad, + ad_less (ad_double a0) a' = true -> + ad_less a' a'' = true -> ad_less (ad_double a0) a'' = true). + intros. rewrite (ad_less_z (ad_double a0)) in H0. discriminate H0. + intros a1 H0 a'' H1. rewrite (ad_less_def_1 a0 a1) in H1. + apply ad_ind_double with + (P := fun a'':ad => + ad_less (ad_double a1) a'' = true -> + ad_less (ad_double a0) a'' = true). + intro. rewrite (ad_less_z (ad_double a1)) in H2. discriminate H2. + intros. rewrite (ad_less_def_1 a1 a2) in H3. rewrite (ad_less_def_1 a0 a2). + exact (H a1 a2 H1 H3). + intros. apply ad_less_def_3. + intros a1 H0 a'' H1. apply ad_ind_double with + (P := fun a'':ad => + ad_less (ad_double_plus_un a1) a'' = true -> + ad_less (ad_double a0) a'' = true). + intro. rewrite (ad_less_z (ad_double_plus_un a1)) in H2. discriminate H2. + intros. rewrite (ad_less_def_4 a1 a2) in H3. discriminate H3. + intros. apply ad_less_def_3. + intros a0 H a'. apply ad_ind_double with + (P := fun a':ad => + forall a'':ad, + ad_less (ad_double_plus_un a0) a' = true -> + ad_less a' a'' = true -> + ad_less (ad_double_plus_un a0) a'' = true). + intros. rewrite (ad_less_z (ad_double_plus_un a0)) in H0. discriminate H0. + intros. rewrite (ad_less_def_4 a0 a1) in H1. discriminate H1. + intros a1 H0 a'' H1. apply ad_ind_double with + (P := fun a'':ad => + ad_less (ad_double_plus_un a1) a'' = true -> + ad_less (ad_double_plus_un a0) a'' = true). + intro. rewrite (ad_less_z (ad_double_plus_un a1)) in H2. discriminate H2. + intros. rewrite (ad_less_def_4 a1 a2) in H3. discriminate H3. + rewrite (ad_less_def_2 a0 a1) in H1. intros. rewrite (ad_less_def_2 a1 a2) in H3. + rewrite (ad_less_def_2 a0 a2). exact (H a1 a2 H1 H3). + Qed. + + Fixpoint alist_sorted (l:alist A) : bool := + match l with + | nil => true + | (a, _) :: l' => + match l' with + | nil => true + | (a', y') :: l'' => andb (ad_less a a') (alist_sorted l') + end + end. + + Fixpoint alist_nth_ad (n:nat) (l:alist A) {struct l} : ad := + match l with + | nil => ad_z (* dummy *) + | (a, y) :: l' => match n with + | O => a + | S n' => alist_nth_ad n' l' + end + end. + + Definition alist_sorted_1 (l:alist A) := + forall n:nat, + S (S n) <= length l -> + ad_less (alist_nth_ad n l) (alist_nth_ad (S n) l) = true. + + Lemma alist_sorted_imp_1 : + forall l:alist A, alist_sorted l = true -> alist_sorted_1 l. + Proof. + unfold alist_sorted_1 in |- *. simple induction l. intros. elim (le_Sn_O (S n) H0). + intro r. elim r. intros a y. simple induction l0. intros. simpl in H1. + elim (le_Sn_O n (le_S_n (S n) 0 H1)). + intro r0. elim r0. intros a0 y0. simple induction n. intros. simpl in |- *. simpl in H1. + exact (proj1 (andb_prop _ _ H1)). + intros. change + (ad_less (alist_nth_ad n0 ((a0, y0) :: l1)) + (alist_nth_ad (S n0) ((a0, y0) :: l1)) = true) + in |- *. + apply H0. exact (proj2 (andb_prop _ _ H1)). + apply le_S_n. exact H3. + Qed. + + Definition alist_sorted_2 (l:alist A) := + forall m n:nat, + m < n -> + S n <= length l -> ad_less (alist_nth_ad m l) (alist_nth_ad n l) = true. + + Lemma alist_sorted_1_imp_2 : + forall l:alist A, alist_sorted_1 l -> alist_sorted_2 l. + Proof. + unfold alist_sorted_1, alist_sorted_2, lt in |- *. intros l H m n H0. elim H0. exact (H m). + intros. apply ad_less_trans with (a' := alist_nth_ad m0 l). apply H2. apply le_Sn_le. + assumption. + apply H. assumption. + Qed. + + Lemma alist_sorted_2_imp : + forall l:alist A, alist_sorted_2 l -> alist_sorted l = true. + Proof. + unfold alist_sorted_2, lt in |- *. simple induction l. trivial. + intro r. elim r. intros a y. simple induction l0. trivial. + intro r0. elim r0. intros a0 y0. intros. + change (andb (ad_less a a0) (alist_sorted ((a0, y0) :: l1)) = true) + in |- *. + apply andb_true_intro. split. apply (H1 0 1). apply le_n. + simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n. + apply H0. intros. apply (H1 (S m) (S n)). apply le_n_S. assumption. + exact (le_n_S _ _ H3). + Qed. + + Lemma app_length : + forall (C:Set) (l l':list C), length (l ++ l') = length l + length l'. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite (H l'). reflexivity. + Qed. + + Lemma aapp_length : + forall l l':alist A, length (aapp A l l') = length l + length l'. + Proof. + exact (app_length (ad * A)). + Qed. + + Lemma alist_nth_ad_aapp_1 : + forall (l l':alist A) (n:nat), + S n <= length l -> alist_nth_ad n (aapp A l l') = alist_nth_ad n l. + Proof. + simple induction l. intros. elim (le_Sn_O n H). + intro r. elim r. intros a y l' H l''. simple induction n. trivial. + intros. simpl in |- *. apply H. apply le_S_n. exact H1. + Qed. + + Lemma alist_nth_ad_aapp_2 : + forall (l l':alist A) (n:nat), + S n <= length l' -> + alist_nth_ad (length l + n) (aapp A l l') = alist_nth_ad n l'. + Proof. + simple induction l. trivial. + intro r. elim r. intros a y l' H l'' n H0. simpl in |- *. apply H. exact H0. + Qed. + + Lemma interval_split : + forall p q n:nat, + S n <= p + q -> {n' : nat | S n' <= q /\ n = p + n'} + {S n <= p}. + Proof. + simple induction p. simpl in |- *. intros. left. split with n. split; [ assumption | reflexivity ]. + intros p' H q. simple induction n. intros. right. apply le_n_S. apply le_O_n. + intros. elim (H _ _ (le_S_n _ _ H1)). intro H2. left. elim H2. intros n' H3. + elim H3. intros H4 H5. split with n'. split; [ assumption | rewrite H5; reflexivity ]. + intro H2. right. apply le_n_S. assumption. + Qed. + + Lemma alist_conc_sorted : + forall l l':alist A, + alist_sorted_2 l -> + alist_sorted_2 l' -> + (forall n n':nat, + S n <= length l -> + S n' <= length l' -> + ad_less (alist_nth_ad n l) (alist_nth_ad n' l') = true) -> + alist_sorted_2 (aapp A l l'). + Proof. + unfold alist_sorted_2, lt in |- *. intros. rewrite (aapp_length l l') in H3. + elim + (interval_split (length l) (length l') m + (le_trans _ _ _ (le_n_S _ _ (lt_le_weak m n H2)) H3)). + intro H4. elim H4. intros m' H5. elim H5. intros. rewrite H7. + rewrite (alist_nth_ad_aapp_2 l l' m' H6). elim (interval_split (length l) (length l') n H3). + intro H8. elim H8. intros n' H9. elim H9. intros. rewrite H11. + rewrite (alist_nth_ad_aapp_2 l l' n' H10). apply H0. rewrite H7 in H2. rewrite H11 in H2. + change (S (length l) + m' <= length l + n') in H2. + rewrite (plus_Snm_nSm (length l) m') in H2. exact ((fun p n m:nat => plus_le_reg_l n m p) (length l) (S m') n' H2). + exact H10. + intro H8. rewrite H7 in H2. cut (S (length l) <= length l). intros. elim (le_Sn_n _ H9). + apply le_trans with (m := S n). apply le_n_S. apply le_trans with (m := S (length l + m')). + apply le_trans with (m := length l + m'). apply le_plus_l. + apply le_n_Sn. + exact H2. + exact H8. + intro H4. rewrite (alist_nth_ad_aapp_1 l l' m H4). + elim (interval_split (length l) (length l') n H3). intro H5. elim H5. intros n' H6. elim H6. + intros. rewrite H8. rewrite (alist_nth_ad_aapp_2 l l' n' H7). exact (H1 m n' H4 H7). + intro H5. rewrite (alist_nth_ad_aapp_1 l l' n H5). exact (H m n H2 H5). + Qed. + + Lemma alist_nth_ad_semantics : + forall (l:alist A) (n:nat), + S n <= length l -> + {y : A | alist_semantics A l (alist_nth_ad n l) = SOME A y}. + Proof. + simple induction l. intros. elim (le_Sn_O _ H). + intro r. elim r. intros a y l0 H. simple induction n. simpl in |- *. intro. split with y. + rewrite (ad_eq_correct a). reflexivity. + intros. elim (H _ (le_S_n _ _ H1)). intros y0 H2. + elim (sumbool_of_bool (ad_eq a (alist_nth_ad n0 l0))). intro H3. split with y. + rewrite (ad_eq_complete _ _ H3). simpl in |- *. rewrite (ad_eq_correct (alist_nth_ad n0 l0)). + reflexivity. + intro H3. split with y0. simpl in |- *. rewrite H3. assumption. + Qed. + + Lemma alist_of_Map_nth_ad : + forall (m:Map A) (pf:ad -> ad) (l:alist A), + l = + MapFold1 A (alist A) (anil A) (aapp A) + (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) pf m -> + forall n:nat, S n <= length l -> {a' : ad | alist_nth_ad n l = pf a'}. + Proof. + intros. elim (alist_nth_ad_semantics l n H0). intros y H1. + apply (alist_of_Map_semantics_1_1 A m pf (alist_nth_ad n l) y). + rewrite <- H. assumption. + Qed. + + Definition ad_monotonic (pf:ad -> ad) := + forall a a':ad, ad_less a a' = true -> ad_less (pf a) (pf a') = true. + + Lemma ad_double_monotonic : ad_monotonic ad_double. + Proof. + unfold ad_monotonic in |- *. intros. rewrite ad_less_def_1. assumption. + Qed. + + Lemma ad_double_plus_un_monotonic : ad_monotonic ad_double_plus_un. + Proof. + unfold ad_monotonic in |- *. intros. rewrite ad_less_def_2. assumption. + Qed. + + Lemma ad_comp_monotonic : + forall pf pf':ad -> ad, + ad_monotonic pf -> + ad_monotonic pf' -> ad_monotonic (fun a0:ad => pf (pf' a0)). + Proof. + unfold ad_monotonic in |- *. intros. apply H. apply H0. exact H1. + Qed. + + Lemma ad_comp_double_monotonic : + forall pf:ad -> ad, + ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double a0)). + Proof. + intros. apply ad_comp_monotonic. assumption. + exact ad_double_monotonic. + Qed. + + Lemma ad_comp_double_plus_un_monotonic : + forall pf:ad -> ad, + ad_monotonic pf -> ad_monotonic (fun a0:ad => pf (ad_double_plus_un a0)). + Proof. + intros. apply ad_comp_monotonic. assumption. + exact ad_double_plus_un_monotonic. + Qed. + + Lemma alist_of_Map_sorts_1 : + forall (m:Map A) (pf:ad -> ad), + ad_monotonic pf -> + alist_sorted_2 + (MapFold1 A (alist A) (anil A) (aapp A) + (fun (a:ad) (y:A) => acons A (a, y) (anil A)) pf m). + Proof. + simple induction m. simpl in |- *. intros. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity. + intros. simpl in |- *. apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. reflexivity. + intros. simpl in |- *. apply alist_conc_sorted. + exact + (H (fun a0:ad => pf (ad_double a0)) (ad_comp_double_monotonic pf H1)). + exact + (H0 (fun a0:ad => pf (ad_double_plus_un a0)) + (ad_comp_double_plus_un_monotonic pf H1)). + intros. elim + (alist_of_Map_nth_ad m0 (fun a0:ad => pf (ad_double a0)) + (MapFold1 A (alist A) (anil A) (aapp A) + (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) + (fun a0:ad => pf (ad_double a0)) m0) (refl_equal _) n H2). + intros a H4. rewrite H4. elim + (alist_of_Map_nth_ad m1 (fun a0:ad => pf (ad_double_plus_un a0)) + (MapFold1 A (alist A) (anil A) (aapp A) + (fun (a0:ad) (y:A) => acons A (a0, y) (anil A)) + (fun a0:ad => pf (ad_double_plus_un a0)) m1) ( + refl_equal _) n' H3). + intros a' H5. rewrite H5. unfold ad_monotonic in H1. apply H1. apply ad_less_def_3. + Qed. + + Lemma alist_of_Map_sorts : + forall m:Map A, alist_sorted (alist_of_Map A m) = true. + Proof. + intro. apply alist_sorted_2_imp. + exact + (alist_of_Map_sorts_1 m (fun a0:ad => a0) + (fun (a a':ad) (p:ad_less a a' = true) => p)). + Qed. + + Lemma alist_of_Map_sorts1 : + forall m:Map A, alist_sorted_1 (alist_of_Map A m). + Proof. + intro. apply alist_sorted_imp_1. apply alist_of_Map_sorts. + Qed. + + Lemma alist_of_Map_sorts2 : + forall m:Map A, alist_sorted_2 (alist_of_Map A m). + Proof. + intro. apply alist_sorted_1_imp_2. apply alist_of_Map_sorts1. + Qed. + + Lemma ad_less_total : + forall a a':ad, {ad_less a a' = true} + {ad_less a' a = true} + {a = a'}. + Proof. + intro a. refine + (ad_rec_double a + (fun a:ad => + forall a':ad, + {ad_less a a' = true} + {ad_less a' a = true} + {a = a'}) _ _ _). + intro. elim (sumbool_of_bool (ad_less ad_z a')). intro H. left. left. assumption. + intro H. right. rewrite (ad_z_less_2 a' H). reflexivity. + intros a0 H a'. refine + (ad_rec_double a' + (fun a':ad => + {ad_less (ad_double a0) a' = true} + + {ad_less a' (ad_double a0) = true} + {ad_double a0 = a'}) _ _ _). + elim (sumbool_of_bool (ad_less ad_z (ad_double a0))). intro H0. left. right. assumption. + intro H0. right. exact (ad_z_less_2 _ H0). + intros a1 H0. rewrite ad_less_def_1. rewrite ad_less_def_1. elim (H a1). intro H1. + left. assumption. + intro H1. right. rewrite H1. reflexivity. + intros a1 H0. left. left. apply ad_less_def_3. + intros a0 H a'. refine + (ad_rec_double a' + (fun a':ad => + {ad_less (ad_double_plus_un a0) a' = true} + + {ad_less a' (ad_double_plus_un a0) = true} + + {ad_double_plus_un a0 = a'}) _ _ _). + left. right. case a0; reflexivity. + intros a1 H0. left. right. apply ad_less_def_3. + intros a1 H0. rewrite ad_less_def_2. rewrite ad_less_def_2. elim (H a1). intro H1. + left. assumption. + intro H1. right. rewrite H1. reflexivity. + Qed. + + Lemma alist_too_low : + forall (l:alist A) (a a':ad) (y:A), + ad_less a a' = true -> + alist_sorted_2 ((a', y) :: l) -> + alist_semantics A ((a', y) :: l) a = NONE A. + Proof. + simple induction l. intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a' a)). intro H1. + rewrite (ad_eq_complete _ _ H1) in H. rewrite (ad_less_not_refl a) in H. discriminate H. + intro H1. rewrite H1. reflexivity. + intro r. elim r. intros a y l0 H a0 a1 y0 H0 H1. + change + (match ad_eq a1 a0 with + | true => SOME A y0 + | false => alist_semantics A ((a, y) :: l0) a0 + end = NONE A) in |- *. + elim (sumbool_of_bool (ad_eq a1 a0)). intro H2. rewrite (ad_eq_complete _ _ H2) in H0. + rewrite (ad_less_not_refl a0) in H0. discriminate H0. + intro H2. rewrite H2. apply H. apply ad_less_trans with (a' := a1). assumption. + unfold alist_sorted_2 in H1. apply (H1 0 1). apply lt_n_Sn. + simpl in |- *. apply le_n_S. apply le_n_S. apply le_O_n. + apply alist_sorted_1_imp_2. apply alist_sorted_imp_1. + cut (alist_sorted ((a1, y0) :: (a, y) :: l0) = true). intro H3. + exact (proj2 (andb_prop _ _ H3)). + apply alist_sorted_2_imp. assumption. + Qed. + + Lemma alist_semantics_nth_ad : + forall (l:alist A) (a:ad) (y:A), + alist_semantics A l a = SOME A y -> + {n : nat | S n <= length l /\ alist_nth_ad n l = a}. + Proof. + simple induction l. intros. discriminate H. + intro r. elim r. intros a y l0 H a0 y0 H0. simpl in H0. elim (sumbool_of_bool (ad_eq a a0)). + intro H1. rewrite H1 in H0. split with 0. split. simpl in |- *. apply le_n_S. apply le_O_n. + simpl in |- *. exact (ad_eq_complete _ _ H1). + intro H1. rewrite H1 in H0. elim (H a0 y0 H0). intros n' H2. split with (S n'). split. + simpl in |- *. apply le_n_S. exact (proj1 H2). + exact (proj2 H2). + Qed. + + Lemma alist_semantics_tail : + forall (l:alist A) (a:ad) (y:A), + alist_sorted_2 ((a, y) :: l) -> + eqm A (alist_semantics A l) + (fun a0:ad => + if ad_eq a a0 then NONE A else alist_semantics A ((a, y) :: l) a0). + Proof. + unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0. + rewrite <- (ad_eq_complete _ _ H0). unfold alist_sorted_2 in H. + elim (option_sum A (alist_semantics A l a)). intro H1. elim H1. intros y0 H2. + elim (alist_semantics_nth_ad l a y0 H2). intros n H3. elim H3. intros. + cut + (ad_less (alist_nth_ad 0 ((a, y) :: l)) + (alist_nth_ad (S n) ((a, y) :: l)) = true). + intro. simpl in H6. rewrite H5 in H6. rewrite (ad_less_not_refl a) in H6. discriminate H6. + apply H. apply lt_O_Sn. + simpl in |- *. apply le_n_S. assumption. + trivial. + intro H0. simpl in |- *. rewrite H0. reflexivity. + Qed. + + Lemma alist_semantics_same_tail : + forall (l l':alist A) (a:ad) (y:A), + alist_sorted_2 ((a, y) :: l) -> + alist_sorted_2 ((a, y) :: l') -> + eqm A (alist_semantics A ((a, y) :: l)) + (alist_semantics A ((a, y) :: l')) -> + eqm A (alist_semantics A l) (alist_semantics A l'). + Proof. + unfold eqm in |- *. intros. rewrite (alist_semantics_tail _ _ _ H a0). + rewrite (alist_semantics_tail _ _ _ H0 a0). case (ad_eq a a0). reflexivity. + exact (H1 a0). + Qed. + + Lemma alist_sorted_tail : + forall (l:alist A) (a:ad) (y:A), + alist_sorted_2 ((a, y) :: l) -> alist_sorted_2 l. + Proof. + unfold alist_sorted_2 in |- *. intros. apply (H (S m) (S n)). apply lt_n_S. assumption. + simpl in |- *. apply le_n_S. assumption. + Qed. + + Lemma alist_canonical : + forall l l':alist A, + eqm A (alist_semantics A l) (alist_semantics A l') -> + alist_sorted_2 l -> alist_sorted_2 l' -> l = l'. + Proof. + unfold eqm in |- *. simple induction l. simple induction l'. trivial. + intro r. elim r. intros a y l0 H H0 H1 H2. simpl in H0. + cut + (NONE A = + match ad_eq a a with + | true => SOME A y + | false => alist_semantics A l0 a + end). + rewrite (ad_eq_correct a). intro. discriminate H3. + exact (H0 a). + intro r. elim r. intros a y l0 H. simple induction l'. intros. simpl in H0. + cut + (match ad_eq a a with + | true => SOME A y + | false => alist_semantics A l0 a + end = NONE A). + rewrite (ad_eq_correct a). intro. discriminate H3. + exact (H0 a). + intro r'. elim r'. intros a' y' l'0 H0 H1 H2 H3. elim (ad_less_total a a'). intro H4. + elim H4. intro H5. + cut + (alist_semantics A ((a, y) :: l0) a = + alist_semantics A ((a', y') :: l'0) a). + intro. rewrite (alist_too_low l'0 a a' y' H5 H3) in H6. simpl in H6. + rewrite (ad_eq_correct a) in H6. discriminate H6. + exact (H1 a). + intro H5. cut + (alist_semantics A ((a, y) :: l0) a' = + alist_semantics A ((a', y') :: l'0) a'). + intro. rewrite (alist_too_low l0 a' a y H5 H2) in H6. simpl in H6. + rewrite (ad_eq_correct a') in H6. discriminate H6. + exact (H1 a'). + intro H4. rewrite H4. + cut + (alist_semantics A ((a, y) :: l0) a = + alist_semantics A ((a', y') :: l'0) a). + intro. simpl in H5. rewrite H4 in H5. rewrite (ad_eq_correct a') in H5. inversion H5. + rewrite H4 in H1. rewrite H7 in H1. cut (l0 = l'0). intro. rewrite H6. reflexivity. + apply H. rewrite H4 in H2. rewrite H7 in H2. + exact (alist_semantics_same_tail l0 l'0 a' y' H2 H3 H1). + exact (alist_sorted_tail _ _ _ H2). + exact (alist_sorted_tail _ _ _ H3). + exact (H1 a). + Qed. + +End LSort.
\ No newline at end of file diff --git a/theories/IntMap/Map.v b/theories/IntMap/Map.v new file mode 100644 index 00000000..da1fa99e --- /dev/null +++ b/theories/IntMap/Map.v @@ -0,0 +1,865 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Map.v,v 1.7.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +(** Definition of finite sets as trees indexed by adresses *) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. + + +Section MapDefs. + +(** We define maps from ad to A. *) + Variable A : Set. + + Inductive Map : Set := + | M0 : Map + | M1 : ad -> A -> Map + | M2 : Map -> Map -> Map. + + Inductive option : Set := + | NONE : option + | SOME : A -> option. + + Lemma option_sum : forall o:option, {y : A | o = SOME y} + {o = NONE}. + Proof. + simple induction o. right. reflexivity. + left. split with a. reflexivity. + Qed. + + (** The semantics of maps is given by the function [MapGet]. + The semantics of a map [m] is a partial, finite function from + [ad] to [A]: *) + + Fixpoint MapGet (m:Map) : ad -> option := + match m with + | M0 => fun a:ad => NONE + | M1 x y => fun a:ad => if ad_eq x a then SOME y else NONE + | M2 m1 m2 => + fun a:ad => + match a with + | ad_z => MapGet m1 ad_z + | ad_x xH => MapGet m2 ad_z + | ad_x (xO p) => MapGet m1 (ad_x p) + | ad_x (xI p) => MapGet m2 (ad_x p) + end + end. + + Definition newMap := M0. + + Definition MapSingleton := M1. + + Definition eqm (g g':ad -> option) := forall a:ad, g a = g' a. + + Lemma newMap_semantics : eqm (MapGet newMap) (fun a:ad => NONE). + Proof. + simpl in |- *. unfold eqm in |- *. trivial. + Qed. + + Lemma MapSingleton_semantics : + forall (a:ad) (y:A), + eqm (MapGet (MapSingleton a y)) + (fun a':ad => if ad_eq a a' then SOME y else NONE). + Proof. + simpl in |- *. unfold eqm in |- *. trivial. + Qed. + + Lemma M1_semantics_1 : forall (a:ad) (y:A), MapGet (M1 a y) a = SOME y. + Proof. + unfold MapGet in |- *. intros. rewrite (ad_eq_correct a). reflexivity. + Qed. + + Lemma M1_semantics_2 : + forall (a a':ad) (y:A), ad_eq a a' = false -> MapGet (M1 a y) a' = NONE. + Proof. + intros. simpl in |- *. rewrite H. reflexivity. + Qed. + + Lemma Map2_semantics_1 : + forall m m':Map, + eqm (MapGet m) (fun a:ad => MapGet (M2 m m') (ad_double a)). + Proof. + unfold eqm in |- *. simple induction a; trivial. + Qed. + + Lemma Map2_semantics_1_eq : + forall (m m':Map) (f:ad -> option), + eqm (MapGet (M2 m m')) f -> eqm (MapGet m) (fun a:ad => f (ad_double a)). + Proof. + unfold eqm in |- *. + intros. + rewrite <- (H (ad_double a)). + exact (Map2_semantics_1 m m' a). + Qed. + + Lemma Map2_semantics_2 : + forall m m':Map, + eqm (MapGet m') (fun a:ad => MapGet (M2 m m') (ad_double_plus_un a)). + Proof. + unfold eqm in |- *. simple induction a; trivial. + Qed. + + Lemma Map2_semantics_2_eq : + forall (m m':Map) (f:ad -> option), + eqm (MapGet (M2 m m')) f -> + eqm (MapGet m') (fun a:ad => f (ad_double_plus_un a)). + Proof. + unfold eqm in |- *. + intros. + rewrite <- (H (ad_double_plus_un a)). + exact (Map2_semantics_2 m m' a). + Qed. + + Lemma MapGet_M2_bit_0_0 : + forall a:ad, + ad_bit_0 a = false -> + forall m m':Map, MapGet (M2 m m') a = MapGet m (ad_div_2 a). + Proof. + simple induction a; trivial. simple induction p. intros. discriminate H0. + trivial. + intros. discriminate H. + Qed. + + Lemma MapGet_M2_bit_0_1 : + forall a:ad, + ad_bit_0 a = true -> + forall m m':Map, MapGet (M2 m m') a = MapGet m' (ad_div_2 a). + Proof. + simple induction a. intros. discriminate H. + simple induction p. trivial. + intros. discriminate H0. + trivial. + Qed. + + Lemma MapGet_M2_bit_0_if : + forall (m m':Map) (a:ad), + MapGet (M2 m m') a = + (if ad_bit_0 a then MapGet m' (ad_div_2 a) else MapGet m (ad_div_2 a)). + Proof. + intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H. + apply MapGet_M2_bit_0_1; assumption. + intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption. + Qed. + + Lemma MapGet_M2_bit_0 : + forall (m m' m'':Map) (a:ad), + (if ad_bit_0 a then MapGet (M2 m' m) a else MapGet (M2 m m'') a) = + MapGet m (ad_div_2 a). + Proof. + intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. rewrite H. + apply MapGet_M2_bit_0_1; assumption. + intro H. rewrite H. apply MapGet_M2_bit_0_0; assumption. + Qed. + + Lemma Map2_semantics_3 : + forall m m':Map, + eqm (MapGet (M2 m m')) + (fun a:ad => + match ad_bit_0 a with + | false => MapGet m (ad_div_2 a) + | true => MapGet m' (ad_div_2 a) + end). + Proof. + unfold eqm in |- *. + simple induction a; trivial. + simple induction p; trivial. + Qed. + + Lemma Map2_semantics_3_eq : + forall (m m':Map) (f f':ad -> option), + eqm (MapGet m) f -> + eqm (MapGet m') f' -> + eqm (MapGet (M2 m m')) + (fun a:ad => + match ad_bit_0 a with + | false => f (ad_div_2 a) + | true => f' (ad_div_2 a) + end). + Proof. + unfold eqm in |- *. + intros. + rewrite <- (H (ad_div_2 a)). + rewrite <- (H0 (ad_div_2 a)). + exact (Map2_semantics_3 m m' a). + Qed. + + Fixpoint MapPut1 (a:ad) (y:A) (a':ad) (y':A) (p:positive) {struct p} : + Map := + match p with + | xO p' => + let m := MapPut1 (ad_div_2 a) y (ad_div_2 a') y' p' in + match ad_bit_0 a with + | false => M2 m M0 + | true => M2 M0 m + end + | _ => + match ad_bit_0 a with + | false => M2 (M1 (ad_div_2 a) y) (M1 (ad_div_2 a') y') + | true => M2 (M1 (ad_div_2 a') y') (M1 (ad_div_2 a) y) + end + end. + + Lemma MapGet_if_commute : + forall (b:bool) (m m':Map) (a:ad), + MapGet (if b then m else m') a = (if b then MapGet m a else MapGet m' a). + Proof. + intros. case b; trivial. + Qed. + + (*i + Lemma MapGet_M2_bit_0_1' : (m,m',m'',m''':Map) + (a:ad) (MapGet (if (ad_bit_0 a) then (M2 m m') else (M2 m'' m''')) a)= + (MapGet (if (ad_bit_0 a) then m' else m'') (ad_div_2 a)). + Proof. + Intros. Rewrite (MapGet_if_commute (ad_bit_0 a)). Rewrite (MapGet_if_commute (ad_bit_0 a)). + Cut (ad_bit_0 a)=false\/(ad_bit_0 a)=true. Intros. Elim H. Intros. Rewrite H0. + Apply MapGet_M2_bit_0_0. Assumption. + Intros. Rewrite H0. Apply MapGet_M2_bit_0_1. Assumption. + Case (ad_bit_0 a); Auto. + Qed. + i*) + + Lemma MapGet_if_same : + forall (m:Map) (b:bool) (a:ad), MapGet (if b then m else m) a = MapGet m a. + Proof. + simple induction b; trivial. + Qed. + + Lemma MapGet_M2_bit_0_2 : + forall (m m' m'':Map) (a:ad), + MapGet (if ad_bit_0 a then M2 m m' else M2 m' m'') a = + MapGet m' (ad_div_2 a). + Proof. + intros. rewrite MapGet_if_commute. apply MapGet_M2_bit_0. + Qed. + + Lemma MapPut1_semantics_1 : + forall (p:positive) (a a':ad) (y y':A), + ad_xor a a' = ad_x p -> MapGet (MapPut1 a y a' y' p) a = SOME y. + Proof. + simple induction p. intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. + intros. simpl in |- *. rewrite MapGet_M2_bit_0_2. apply H. rewrite <- ad_xor_div_2. rewrite H0. + reflexivity. + intros. unfold MapPut1 in |- *. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. + Qed. + + Lemma MapPut1_semantics_2 : + forall (p:positive) (a a':ad) (y y':A), + ad_xor a a' = ad_x p -> MapGet (MapPut1 a y a' y' p) a' = SOME y'. + Proof. + simple induction p. intros. unfold MapPut1 in |- *. rewrite (ad_neg_bit_0_2 a a' p0 H0). + rewrite if_negb. rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. + intros. simpl in |- *. rewrite (ad_same_bit_0 a a' p0 H0). rewrite MapGet_M2_bit_0_2. + apply H. rewrite <- ad_xor_div_2. rewrite H0. reflexivity. + intros. unfold MapPut1 in |- *. rewrite (ad_neg_bit_0_1 a a' H). rewrite if_negb. + rewrite MapGet_M2_bit_0_2. apply M1_semantics_1. + Qed. + + Lemma MapGet_M2_both_NONE : + forall (m m':Map) (a:ad), + MapGet m (ad_div_2 a) = NONE -> + MapGet m' (ad_div_2 a) = NONE -> MapGet (M2 m m') a = NONE. + Proof. + intros. rewrite (Map2_semantics_3 m m' a). + case (ad_bit_0 a); assumption. + Qed. + + Lemma MapPut1_semantics_3 : + forall (p:positive) (a a' a0:ad) (y y':A), + ad_xor a a' = ad_x p -> + ad_eq a a0 = false -> + ad_eq a' a0 = false -> MapGet (MapPut1 a y a' y' p) a0 = NONE. + Proof. + simple induction p. intros. unfold MapPut1 in |- *. elim (ad_neq a a0 H1). intro. rewrite H3. rewrite if_negb. + rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply ad_div_bit_neq. assumption. + rewrite (ad_neg_bit_0_2 a a' p0 H0) in H3. rewrite (negb_intro (ad_bit_0 a')). + rewrite (negb_intro (ad_bit_0 a0)). rewrite H3. reflexivity. + intro. elim (ad_neq a' a0 H2). intro. rewrite (ad_neg_bit_0_2 a a' p0 H0). rewrite H4. + rewrite (negb_elim (ad_bit_0 a0)). rewrite MapGet_M2_bit_0_2. + apply M1_semantics_2; assumption. + intro; case (ad_bit_0 a); apply MapGet_M2_both_NONE; apply M1_semantics_2; + assumption. + intros. simpl in |- *. elim (ad_neq a a0 H1). intro. rewrite H3. rewrite if_negb. + rewrite MapGet_M2_bit_0_2. reflexivity. + intro. elim (ad_neq a' a0 H2). intro. rewrite (ad_same_bit_0 a a' p0 H0). rewrite H4. + rewrite if_negb. rewrite MapGet_M2_bit_0_2. reflexivity. + intro. cut (ad_xor (ad_div_2 a) (ad_div_2 a') = ad_x p0). intro. + case (ad_bit_0 a); apply MapGet_M2_both_NONE; trivial; apply H; + assumption. + rewrite <- ad_xor_div_2. rewrite H0. reflexivity. + intros. simpl in |- *. elim (ad_neq a a0 H0). intro. rewrite H2. rewrite if_negb. + rewrite MapGet_M2_bit_0_2. apply M1_semantics_2. apply ad_div_bit_neq. assumption. + rewrite (ad_neg_bit_0_1 a a' H) in H2. rewrite (negb_intro (ad_bit_0 a')). + rewrite (negb_intro (ad_bit_0 a0)). rewrite H2. reflexivity. + intro. elim (ad_neq a' a0 H1). intro. rewrite (ad_neg_bit_0_1 a a' H). rewrite H3. + rewrite (negb_elim (ad_bit_0 a0)). rewrite MapGet_M2_bit_0_2. + apply M1_semantics_2; assumption. + intro. case (ad_bit_0 a); apply MapGet_M2_both_NONE; apply M1_semantics_2; + assumption. + Qed. + + Lemma MapPut1_semantics : + forall (p:positive) (a a':ad) (y y':A), + ad_xor a a' = ad_x p -> + eqm (MapGet (MapPut1 a y a' y' p)) + (fun a0:ad => + if ad_eq a a0 + then SOME y + else if ad_eq a' a0 then SOME y' else NONE). + Proof. + unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0. + rewrite <- (ad_eq_complete _ _ H0). exact (MapPut1_semantics_1 p a a' y y' H). + intro H0. rewrite H0. elim (sumbool_of_bool (ad_eq a' a0)). intro H1. + rewrite <- (ad_eq_complete _ _ H1). rewrite (ad_eq_correct a'). + exact (MapPut1_semantics_2 p a a' y y' H). + intro H1. rewrite H1. exact (MapPut1_semantics_3 p a a' a0 y y' H H0 H1). + Qed. + + Lemma MapPut1_semantics' : + forall (p:positive) (a a':ad) (y y':A), + ad_xor a a' = ad_x p -> + eqm (MapGet (MapPut1 a y a' y' p)) + (fun a0:ad => + if ad_eq a' a0 + then SOME y' + else if ad_eq a a0 then SOME y else NONE). + Proof. + unfold eqm in |- *. intros. rewrite (MapPut1_semantics p a a' y y' H a0). + elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0. + rewrite <- (ad_eq_complete a a0 H0). rewrite (ad_eq_comm a' a). + rewrite (ad_xor_eq_false a a' p H). reflexivity. + intro H0. rewrite H0. reflexivity. + Qed. + + Fixpoint MapPut (m:Map) : ad -> A -> Map := + match m with + | M0 => M1 + | M1 a y => + fun (a':ad) (y':A) => + match ad_xor a a' with + | ad_z => M1 a' y' + | ad_x p => MapPut1 a y a' y' p + end + | M2 m1 m2 => + fun (a:ad) (y:A) => + match a with + | ad_z => M2 (MapPut m1 ad_z y) m2 + | ad_x xH => M2 m1 (MapPut m2 ad_z y) + | ad_x (xO p) => M2 (MapPut m1 (ad_x p) y) m2 + | ad_x (xI p) => M2 m1 (MapPut m2 (ad_x p) y) + end + end. + + Lemma MapPut_semantics_1 : + forall (a:ad) (y:A) (a0:ad), + MapGet (MapPut M0 a y) a0 = MapGet (M1 a y) a0. + Proof. + trivial. + Qed. + + Lemma MapPut_semantics_2_1 : + forall (a:ad) (y y':A) (a0:ad), + MapGet (MapPut (M1 a y) a y') a0 = + (if ad_eq a a0 then SOME y' else NONE). + Proof. + simpl in |- *. intros. rewrite (ad_xor_nilpotent a). trivial. + Qed. + + Lemma MapPut_semantics_2_2 : + forall (a a':ad) (y y':A) (a0 a'':ad), + ad_xor a a' = a'' -> + MapGet (MapPut (M1 a y) a' y') a0 = + (if ad_eq a' a0 then SOME y' else if ad_eq a a0 then SOME y else NONE). + Proof. + simple induction a''. intro. rewrite (ad_xor_eq _ _ H). rewrite MapPut_semantics_2_1. + case (ad_eq a' a0); trivial. + intros. simpl in |- *. rewrite H. rewrite (MapPut1_semantics p a a' y y' H a0). + elim (sumbool_of_bool (ad_eq a a0)). intro H0. rewrite H0. rewrite <- (ad_eq_complete _ _ H0). + rewrite (ad_eq_comm a' a). rewrite (ad_xor_eq_false _ _ _ H). reflexivity. + intro H0. rewrite H0. reflexivity. + Qed. + + Lemma MapPut_semantics_2 : + forall (a a':ad) (y y':A) (a0:ad), + MapGet (MapPut (M1 a y) a' y') a0 = + (if ad_eq a' a0 then SOME y' else if ad_eq a a0 then SOME y else NONE). + Proof. + intros. apply MapPut_semantics_2_2 with (a'' := ad_xor a a'); trivial. + Qed. + + Lemma MapPut_semantics_3_1 : + forall (m m':Map) (a:ad) (y:A), + MapPut (M2 m m') a y = + (if ad_bit_0 a + then M2 m (MapPut m' (ad_div_2 a) y) + else M2 (MapPut m (ad_div_2 a) y) m'). + Proof. + simple induction a. trivial. + simple induction p; trivial. + Qed. + + Lemma MapPut_semantics : + forall (m:Map) (a:ad) (y:A), + eqm (MapGet (MapPut m a y)) + (fun a':ad => if ad_eq a a' then SOME y else MapGet m a'). + Proof. + unfold eqm in |- *. simple induction m. exact MapPut_semantics_1. + intros. unfold MapGet at 2 in |- *. apply MapPut_semantics_2; assumption. + intros. rewrite MapPut_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a0). + elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. + elim (sumbool_of_bool (ad_bit_0 a0)). intro H2. rewrite H2. + rewrite (H0 (ad_div_2 a) y (ad_div_2 a0)). elim (sumbool_of_bool (ad_eq a a0)). + intro H3. rewrite H3. rewrite (ad_div_eq _ _ H3). reflexivity. + intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). reflexivity. + intro H2. rewrite H2. rewrite (ad_eq_comm a a0). rewrite (ad_bit_0_neq a0 a H2 H1). + reflexivity. + intro H1. rewrite H1. rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a0)). + intro H2. rewrite H2. rewrite (ad_bit_0_neq a a0 H1 H2). reflexivity. + intro H2. rewrite H2. rewrite (H (ad_div_2 a) y (ad_div_2 a0)). + elim (sumbool_of_bool (ad_eq a a0)). intro H3. rewrite H3. + rewrite (ad_div_eq a a0 H3). reflexivity. + intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq a a0 H3 H1). reflexivity. + Qed. + + Fixpoint MapPut_behind (m:Map) : ad -> A -> Map := + match m with + | M0 => M1 + | M1 a y => + fun (a':ad) (y':A) => + match ad_xor a a' with + | ad_z => m + | ad_x p => MapPut1 a y a' y' p + end + | M2 m1 m2 => + fun (a:ad) (y:A) => + match a with + | ad_z => M2 (MapPut_behind m1 ad_z y) m2 + | ad_x xH => M2 m1 (MapPut_behind m2 ad_z y) + | ad_x (xO p) => M2 (MapPut_behind m1 (ad_x p) y) m2 + | ad_x (xI p) => M2 m1 (MapPut_behind m2 (ad_x p) y) + end + end. + + Lemma MapPut_behind_semantics_3_1 : + forall (m m':Map) (a:ad) (y:A), + MapPut_behind (M2 m m') a y = + (if ad_bit_0 a + then M2 m (MapPut_behind m' (ad_div_2 a) y) + else M2 (MapPut_behind m (ad_div_2 a) y) m'). + Proof. + simple induction a. trivial. + simple induction p; trivial. + Qed. + + Lemma MapPut_behind_as_before_1 : + forall a a' a0:ad, + ad_eq a' a0 = false -> + forall y y':A, + MapGet (MapPut (M1 a y) a' y') a0 = + MapGet (MapPut_behind (M1 a y) a' y') a0. + Proof. + intros a a' a0. simpl in |- *. intros H y y'. elim (ad_sum (ad_xor a a')). intro H0. elim H0. + intros p H1. rewrite H1. reflexivity. + intro H0. rewrite H0. rewrite (ad_xor_eq _ _ H0). rewrite (M1_semantics_2 a' a0 y H). + exact (M1_semantics_2 a' a0 y' H). + Qed. + + Lemma MapPut_behind_as_before : + forall (m:Map) (a:ad) (y:A) (a0:ad), + ad_eq a a0 = false -> + MapGet (MapPut m a y) a0 = MapGet (MapPut_behind m a y) a0. + Proof. + simple induction m. trivial. + intros a y a' y' a0 H. exact (MapPut_behind_as_before_1 a a' a0 H y y'). + intros. rewrite MapPut_semantics_3_1. rewrite MapPut_behind_semantics_3_1. + elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. + rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a0)). intro H3. + rewrite H3. apply H0. rewrite <- H3 in H2. exact (ad_div_bit_neq a a0 H1 H2). + intro H3. rewrite H3. reflexivity. + intro H2. rewrite H2. rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if. + elim (sumbool_of_bool (ad_bit_0 a0)). intro H3. rewrite H3. reflexivity. + intro H3. rewrite H3. apply H. rewrite <- H3 in H2. exact (ad_div_bit_neq a a0 H1 H2). + Qed. + + Lemma MapPut_behind_new : + forall (m:Map) (a:ad) (y:A), + MapGet (MapPut_behind m a y) a = + match MapGet m a with + | SOME y' => SOME y' + | _ => SOME y + end. + Proof. + simple induction m. simpl in |- *. intros. rewrite (ad_eq_correct a). reflexivity. + intros. elim (ad_sum (ad_xor a a1)). intro H. elim H. intros p H0. simpl in |- *. + rewrite H0. rewrite (ad_xor_eq_false a a1 p). exact (MapPut1_semantics_2 p a a1 a0 y H0). + assumption. + intro H. simpl in |- *. rewrite H. rewrite <- (ad_xor_eq _ _ H). rewrite (ad_eq_correct a). + exact (M1_semantics_1 a a0). + intros. rewrite MapPut_behind_semantics_3_1. rewrite (MapGet_M2_bit_0_if m0 m1 a). + elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_1 a H1). + exact (H0 (ad_div_2 a) y). + intro H1. rewrite H1. rewrite (MapGet_M2_bit_0_0 a H1). exact (H (ad_div_2 a) y). + Qed. + + Lemma MapPut_behind_semantics : + forall (m:Map) (a:ad) (y:A), + eqm (MapGet (MapPut_behind m a y)) + (fun a':ad => + match MapGet m a' with + | SOME y' => SOME y' + | _ => if ad_eq a a' then SOME y else NONE + end). + Proof. + unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H. rewrite H. + rewrite (ad_eq_complete _ _ H). apply MapPut_behind_new. + intro H. rewrite H. rewrite <- (MapPut_behind_as_before m a y a0 H). + rewrite (MapPut_semantics m a y a0). rewrite H. case (MapGet m a0); trivial. + Qed. + + Definition makeM2 (m m':Map) := + match m, m' with + | M0, M0 => M0 + | M0, M1 a y => M1 (ad_double_plus_un a) y + | M1 a y, M0 => M1 (ad_double a) y + | _, _ => M2 m m' + end. + + Lemma makeM2_M2 : + forall m m':Map, eqm (MapGet (makeM2 m m')) (MapGet (M2 m m')). + Proof. + unfold eqm in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H. + rewrite (MapGet_M2_bit_0_1 a H m m'). case m'. case m. reflexivity. + intros a0 y. simpl in |- *. rewrite (ad_bit_0_1_not_double a H a0). reflexivity. + intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity. + assumption. + case m. intros a0 y. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))). + intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0). rewrite (ad_div_2_double_plus_un a H). + rewrite (ad_eq_correct a). reflexivity. + intro H0. rewrite H0. rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0. + rewrite (ad_not_div_2_not_double_plus_un a a0 H0). reflexivity. + intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity. + assumption. + intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_1. reflexivity. + assumption. + intros m1 m2. unfold makeM2 in |- *. + cut (MapGet (M2 m (M2 m1 m2)) a = MapGet (M2 m1 m2) (ad_div_2 a)). + case m; trivial. + exact (MapGet_M2_bit_0_1 a H m (M2 m1 m2)). + intro H. rewrite (MapGet_M2_bit_0_0 a H m m'). case m. case m'. reflexivity. + intros a0 y. simpl in |- *. rewrite (ad_bit_0_0_not_double_plus_un a H a0). reflexivity. + intros m1 m2. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity. + assumption. + case m'. intros a0 y. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 (ad_div_2 a))). intro H0. + rewrite H0. rewrite (ad_eq_complete _ _ H0). rewrite (ad_div_2_double a H). + rewrite (ad_eq_correct a). reflexivity. + intro H0. rewrite H0. rewrite (ad_eq_comm (ad_double a0) a). + rewrite (ad_eq_comm a0 (ad_div_2 a)) in H0. rewrite (ad_not_div_2_not_double a a0 H0). + reflexivity. + intros a0 y0 a1 y1. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity. + assumption. + intros m1 m2 a0 y. unfold makeM2 in |- *. rewrite MapGet_M2_bit_0_0. reflexivity. + assumption. + intros m1 m2. unfold makeM2 in |- *. exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m'). + Qed. + + Fixpoint MapRemove (m:Map) : ad -> Map := + match m with + | M0 => fun _:ad => M0 + | M1 a y => + fun a':ad => match ad_eq a a' with + | true => M0 + | false => m + end + | M2 m1 m2 => + fun a:ad => + if ad_bit_0 a + then makeM2 m1 (MapRemove m2 (ad_div_2 a)) + else makeM2 (MapRemove m1 (ad_div_2 a)) m2 + end. + + Lemma MapRemove_semantics : + forall (m:Map) (a:ad), + eqm (MapGet (MapRemove m a)) + (fun a':ad => if ad_eq a a' then NONE else MapGet m a'). + Proof. + unfold eqm in |- *. simple induction m. simpl in |- *. intros. case (ad_eq a a0); trivial. + intros. simpl in |- *. elim (sumbool_of_bool (ad_eq a1 a2)). intro H. rewrite H. + elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. reflexivity. + intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H) in H0. exact (M1_semantics_2 a a2 a0 H0). + intro H. elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. rewrite H. + rewrite <- (ad_eq_complete _ _ H0) in H. rewrite H. reflexivity. + intro H0. rewrite H0. rewrite H. reflexivity. + intros. change + (MapGet + (if ad_bit_0 a + then makeM2 m0 (MapRemove m1 (ad_div_2 a)) + else makeM2 (MapRemove m0 (ad_div_2 a)) m1) a0 = + (if ad_eq a a0 then NONE else MapGet (M2 m0 m1) a0)) + in |- *. + elim (sumbool_of_bool (ad_bit_0 a)). intro H1. rewrite H1. + rewrite (makeM2_M2 m0 (MapRemove m1 (ad_div_2 a)) a0). elim (sumbool_of_bool (ad_bit_0 a0)). + intro H2. rewrite MapGet_M2_bit_0_1. rewrite (H0 (ad_div_2 a) (ad_div_2 a0)). + elim (sumbool_of_bool (ad_eq a a0)). intro H3. rewrite H3. rewrite (ad_div_eq _ _ H3). + reflexivity. + intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). + rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). reflexivity. + assumption. + intro H2. rewrite (MapGet_M2_bit_0_0 a0 H2 m0 (MapRemove m1 (ad_div_2 a))). + rewrite (ad_eq_comm a a0). rewrite (ad_bit_0_neq _ _ H2 H1). + rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). reflexivity. + intro H1. rewrite H1. rewrite (makeM2_M2 (MapRemove m0 (ad_div_2 a)) m1 a0). + elim (sumbool_of_bool (ad_bit_0 a0)). intro H2. rewrite MapGet_M2_bit_0_1. + rewrite (MapGet_M2_bit_0_1 a0 H2 m0 m1). rewrite (ad_bit_0_neq a a0 H1 H2). reflexivity. + assumption. + intro H2. rewrite MapGet_M2_bit_0_0. rewrite (H (ad_div_2 a) (ad_div_2 a0)). + rewrite (MapGet_M2_bit_0_0 a0 H2 m0 m1). elim (sumbool_of_bool (ad_eq a a0)). intro H3. + rewrite H3. rewrite (ad_div_eq _ _ H3). reflexivity. + intro H3. rewrite H3. rewrite <- H2 in H1. rewrite (ad_div_bit_neq _ _ H3 H1). reflexivity. + assumption. + Qed. + + Fixpoint MapCard (m:Map) : nat := + match m with + | M0 => 0 + | M1 _ _ => 1 + | M2 m m' => MapCard m + MapCard m' + end. + + Fixpoint MapMerge (m:Map) : Map -> Map := + match m with + | M0 => fun m':Map => m' + | M1 a y => fun m':Map => MapPut_behind m' a y + | M2 m1 m2 => + fun m':Map => + match m' with + | M0 => m + | M1 a' y' => MapPut m a' y' + | M2 m'1 m'2 => M2 (MapMerge m1 m'1) (MapMerge m2 m'2) + end + end. + + Lemma MapMerge_semantics : + forall m m':Map, + eqm (MapGet (MapMerge m m')) + (fun a0:ad => + match MapGet m' a0 with + | SOME y' => SOME y' + | NONE => MapGet m a0 + end). + Proof. + unfold eqm in |- *. simple induction m. intros. simpl in |- *. case (MapGet m' a); trivial. + intros. simpl in |- *. rewrite (MapPut_behind_semantics m' a a0 a1). reflexivity. + simple induction m'. trivial. + intros. unfold MapMerge in |- *. rewrite (MapPut_semantics (M2 m0 m1) a a0 a1). + elim (sumbool_of_bool (ad_eq a a1)). intro H1. rewrite H1. rewrite (ad_eq_complete _ _ H1). + rewrite (M1_semantics_1 a1 a0). reflexivity. + intro H1. rewrite H1. rewrite (M1_semantics_2 a a1 a0 H1). reflexivity. + intros. cut (MapMerge (M2 m0 m1) (M2 m2 m3) = M2 (MapMerge m0 m2) (MapMerge m1 m3)). + intro. rewrite H3. rewrite MapGet_M2_bit_0_if. rewrite (H0 m3 (ad_div_2 a)). + rewrite (H m2 (ad_div_2 a)). rewrite (MapGet_M2_bit_0_if m2 m3 a). + rewrite (MapGet_M2_bit_0_if m0 m1 a). case (ad_bit_0 a); trivial. + reflexivity. + Qed. + + (** [MapInter], [MapRngRestrTo], [MapRngRestrBy], [MapInverse] + not implemented: need a decidable equality on [A]. *) + + Fixpoint MapDelta (m:Map) : Map -> Map := + match m with + | M0 => fun m':Map => m' + | M1 a y => + fun m':Map => + match MapGet m' a with + | NONE => MapPut m' a y + | _ => MapRemove m' a + end + | M2 m1 m2 => + fun m':Map => + match m' with + | M0 => m + | M1 a' y' => + match MapGet m a' with + | NONE => MapPut m a' y' + | _ => MapRemove m a' + end + | M2 m'1 m'2 => makeM2 (MapDelta m1 m'1) (MapDelta m2 m'2) + end + end. + + Lemma MapDelta_semantics_comm : + forall m m':Map, eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m)). + Proof. + unfold eqm in |- *. simple induction m. simple induction m'; reflexivity. + simple induction m'. reflexivity. + unfold MapDelta in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H. + rewrite <- (ad_eq_complete _ _ H). rewrite (M1_semantics_1 a a2). + rewrite (M1_semantics_1 a a0). simpl in |- *. rewrite (ad_eq_correct a). reflexivity. + intro H. rewrite (M1_semantics_2 a a1 a0 H). rewrite (ad_eq_comm a a1) in H. + rewrite (M1_semantics_2 a1 a a2 H). rewrite (MapPut_semantics (M1 a a0) a1 a2 a3). + rewrite (MapPut_semantics (M1 a1 a2) a a0 a3). elim (sumbool_of_bool (ad_eq a a3)). + intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0) in H. rewrite H. + rewrite (ad_eq_complete _ _ H0). rewrite (M1_semantics_1 a3 a0). reflexivity. + intro H0. rewrite H0. rewrite (M1_semantics_2 a a3 a0 H0). + elim (sumbool_of_bool (ad_eq a1 a3)). intro H1. rewrite H1. + rewrite (ad_eq_complete _ _ H1). exact (M1_semantics_1 a3 a2). + intro H1. rewrite H1. exact (M1_semantics_2 a1 a3 a2 H1). + intros. reflexivity. + simple induction m'. reflexivity. + reflexivity. + intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). + rewrite (makeM2_M2 (MapDelta m2 m0) (MapDelta m3 m1) a). + rewrite (MapGet_M2_bit_0_if (MapDelta m0 m2) (MapDelta m1 m3) a). + rewrite (MapGet_M2_bit_0_if (MapDelta m2 m0) (MapDelta m3 m1) a). + rewrite (H0 m3 (ad_div_2 a)). rewrite (H m2 (ad_div_2 a)). reflexivity. + Qed. + + Lemma MapDelta_semantics_1_1 : + forall (a:ad) (y:A) (m':Map) (a0:ad), + MapGet (M1 a y) a0 = NONE -> + MapGet m' a0 = NONE -> MapGet (MapDelta (M1 a y) m') a0 = NONE. + Proof. + intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1. + rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H. + intro H1. case (MapGet m' a). rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption. + rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial. + Qed. + + Lemma MapDelta_semantics_1 : + forall (m m':Map) (a:ad), + MapGet m a = NONE -> + MapGet m' a = NONE -> MapGet (MapDelta m m') a = NONE. + Proof. + simple induction m. trivial. + exact MapDelta_semantics_1_1. + simple induction m'. trivial. + intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). + apply MapDelta_semantics_1_1; trivial. + intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). + rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5. + apply H0. rewrite (MapGet_M2_bit_0_1 a H5 m0 m1) in H3. exact H3. + rewrite (MapGet_M2_bit_0_1 a H5 m2 m3) in H4. exact H4. + intro H5. rewrite H5. apply H. rewrite (MapGet_M2_bit_0_0 a H5 m0 m1) in H3. exact H3. + rewrite (MapGet_M2_bit_0_0 a H5 m2 m3) in H4. exact H4. + Qed. + + Lemma MapDelta_semantics_2_1 : + forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A), + MapGet (M1 a y) a0 = NONE -> + MapGet m' a0 = SOME y0 -> MapGet (MapDelta (M1 a y) m') a0 = SOME y0. + Proof. + intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1. + rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 a0 y) in H. discriminate H. + intro H1. case (MapGet m' a). rewrite (MapPut_semantics m' a y a0). rewrite H1. assumption. + rewrite (MapRemove_semantics m' a a0). rewrite H1. trivial. + Qed. + + Lemma MapDelta_semantics_2_2 : + forall (a:ad) (y:A) (m':Map) (a0:ad) (y0:A), + MapGet (M1 a y) a0 = SOME y0 -> + MapGet m' a0 = NONE -> MapGet (MapDelta (M1 a y) m') a0 = SOME y0. + Proof. + intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a a0)). intro H1. + rewrite (ad_eq_complete _ _ H1) in H. rewrite (ad_eq_complete _ _ H1). + rewrite H0. rewrite (MapPut_semantics m' a0 y a0). rewrite (ad_eq_correct a0). + rewrite (M1_semantics_1 a0 y) in H. simple inversion H. assumption. + intro H1. rewrite (M1_semantics_2 a a0 y H1) in H. discriminate H. + Qed. + + Lemma MapDelta_semantics_2 : + forall (m m':Map) (a:ad) (y:A), + MapGet m a = NONE -> + MapGet m' a = SOME y -> MapGet (MapDelta m m') a = SOME y. + Proof. + simple induction m. trivial. + exact MapDelta_semantics_2_1. + simple induction m'. intros. discriminate H2. + intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). + apply MapDelta_semantics_2_2; assumption. + intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). + rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5. + apply H0. rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption. + rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption. + intro H5. rewrite H5. apply H. rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption. + rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption. + Qed. + + Lemma MapDelta_semantics_3_1 : + forall (a0:ad) (y0:A) (m':Map) (a:ad) (y y':A), + MapGet (M1 a0 y0) a = SOME y -> + MapGet m' a = SOME y' -> MapGet (MapDelta (M1 a0 y0) m') a = NONE. + Proof. + intros. unfold MapDelta in |- *. elim (sumbool_of_bool (ad_eq a0 a)). intro H1. + rewrite (ad_eq_complete a0 a H1). rewrite H0. rewrite (MapRemove_semantics m' a a). + rewrite (ad_eq_correct a). reflexivity. + intro H1. rewrite (M1_semantics_2 a0 a y0 H1) in H. discriminate H. + Qed. + + Lemma MapDelta_semantics_3 : + forall (m m':Map) (a:ad) (y y':A), + MapGet m a = SOME y -> + MapGet m' a = SOME y' -> MapGet (MapDelta m m') a = NONE. + Proof. + simple induction m. intros. discriminate H. + exact MapDelta_semantics_3_1. + simple induction m'. intros. discriminate H2. + intros. rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). + exact (MapDelta_semantics_3_1 a a0 (M2 m0 m1) a1 y' y H2 H1). + intros. simpl in |- *. rewrite (makeM2_M2 (MapDelta m0 m2) (MapDelta m1 m3) a). + rewrite MapGet_M2_bit_0_if. elim (sumbool_of_bool (ad_bit_0 a)). intro H5. rewrite H5. + apply (H0 m3 (ad_div_2 a) y y'). rewrite <- (MapGet_M2_bit_0_1 a H5 m0 m1). assumption. + rewrite <- (MapGet_M2_bit_0_1 a H5 m2 m3). assumption. + intro H5. rewrite H5. apply (H m2 (ad_div_2 a) y y'). + rewrite <- (MapGet_M2_bit_0_0 a H5 m0 m1). assumption. + rewrite <- (MapGet_M2_bit_0_0 a H5 m2 m3). assumption. + Qed. + + Lemma MapDelta_semantics : + forall m m':Map, + eqm (MapGet (MapDelta m m')) + (fun a0:ad => + match MapGet m a0, MapGet m' a0 with + | NONE, SOME y' => SOME y' + | SOME y, NONE => SOME y + | _, _ => NONE + end). + Proof. + unfold eqm in |- *. intros. elim (option_sum (MapGet m' a)). intro H. elim H. intros a0 H0. + rewrite H0. elim (option_sum (MapGet m a)). intro H1. elim H1. intros a1 H2. rewrite H2. + exact (MapDelta_semantics_3 m m' a a1 a0 H2 H0). + intro H1. rewrite H1. exact (MapDelta_semantics_2 m m' a a0 H1 H0). + intro H. rewrite H. elim (option_sum (MapGet m a)). intro H0. elim H0. intros a0 H1. + rewrite H1. rewrite (MapDelta_semantics_comm m m' a). + exact (MapDelta_semantics_2 m' m a a0 H H1). + intro H0. rewrite H0. exact (MapDelta_semantics_1 m m' a H0 H). + Qed. + + Definition MapEmptyp (m:Map) := match m with + | M0 => true + | _ => false + end. + + Lemma MapEmptyp_correct : MapEmptyp M0 = true. + Proof. + reflexivity. + Qed. + + Lemma MapEmptyp_complete : forall m:Map, MapEmptyp m = true -> m = M0. + Proof. + simple induction m; trivial. intros. discriminate H. + intros. discriminate H1. + Qed. + + (** [MapSplit] not implemented: not the preferred way of recursing over Maps + (use [MapSweep], [MapCollect], or [MapFold] in Mapiter.v. *) + +End MapDefs.
\ No newline at end of file diff --git a/theories/IntMap/Mapaxioms.v b/theories/IntMap/Mapaxioms.v new file mode 100644 index 00000000..9d09f2a9 --- /dev/null +++ b/theories/IntMap/Mapaxioms.v @@ -0,0 +1,763 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapaxioms.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Fset. + +Section MapAxioms. + + Variables A B C : Set. + + Lemma eqm_sym : forall f f':ad -> option A, eqm A f f' -> eqm A f' f. + Proof. + unfold eqm in |- *. intros. rewrite H. reflexivity. + Qed. + + Lemma eqm_refl : forall f:ad -> option A, eqm A f f. + Proof. + unfold eqm in |- *. trivial. + Qed. + + Lemma eqm_trans : + forall f f' f'':ad -> option A, eqm A f f' -> eqm A f' f'' -> eqm A f f''. + Proof. + unfold eqm in |- *. intros. rewrite H. exact (H0 a). + Qed. + + Definition eqmap (m m':Map A) := eqm A (MapGet A m) (MapGet A m'). + + Lemma eqmap_sym : forall m m':Map A, eqmap m m' -> eqmap m' m. + Proof. + intros. unfold eqmap in |- *. apply eqm_sym. assumption. + Qed. + + Lemma eqmap_refl : forall m:Map A, eqmap m m. + Proof. + intros. unfold eqmap in |- *. apply eqm_refl. + Qed. + + Lemma eqmap_trans : + forall m m' m'':Map A, eqmap m m' -> eqmap m' m'' -> eqmap m m''. + Proof. + intros. exact (eqm_trans (MapGet A m) (MapGet A m') (MapGet A m'') H H0). + Qed. + + Lemma MapPut_as_Merge : + forall (m:Map A) (a:ad) (y:A), + eqmap (MapPut A m a y) (MapMerge A m (M1 A a y)). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m a y a0). + rewrite (MapMerge_semantics A m (M1 A a y) a0). unfold MapGet at 2 in |- *. + elim (sumbool_of_bool (ad_eq a a0)); intro H; rewrite H; reflexivity. + Qed. + + Lemma MapPut_ext : + forall m m':Map A, + eqmap m m' -> + forall (a:ad) (y:A), eqmap (MapPut A m a y) (MapPut A m' a y). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapPut_semantics A m' a y a0). + rewrite (MapPut_semantics A m a y a0). + case (ad_eq a a0); [ reflexivity | apply H ]. + Qed. + + Lemma MapPut_behind_as_Merge : + forall (m:Map A) (a:ad) (y:A), + eqmap (MapPut_behind A m a y) (MapMerge A (M1 A a y) m). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m a y a0). + rewrite (MapMerge_semantics A (M1 A a y) m a0). reflexivity. + Qed. + + Lemma MapPut_behind_ext : + forall m m':Map A, + eqmap m m' -> + forall (a:ad) (y:A), + eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapPut_behind_semantics A m' a y a0). + rewrite (MapPut_behind_semantics A m a y a0). rewrite (H a0). reflexivity. + Qed. + + Lemma MapMerge_empty_m_1 : forall m:Map A, MapMerge A (M0 A) m = m. + Proof. + trivial. + Qed. + + Lemma MapMerge_empty_m : forall m:Map A, eqmap (MapMerge A (M0 A) m) m. + Proof. + unfold eqmap, eqm in |- *. trivial. + Qed. + + Lemma MapMerge_m_empty_1 : forall m:Map A, MapMerge A m (M0 A) = m. + Proof. + simple induction m; trivial. + Qed. + + Lemma MapMerge_m_empty : forall m:Map A, eqmap (MapMerge A m (M0 A)) m. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite MapMerge_m_empty_1. reflexivity. + Qed. + + Lemma MapMerge_empty_l : + forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a). + rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a). trivial. + intros. discriminate H0. + exact (H a). + Qed. + + Lemma MapMerge_empty_r : + forall m m':Map A, eqmap (MapMerge A m m') (M0 A) -> eqmap m' (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. cut (MapGet A (MapMerge A m m') a = MapGet A (M0 A) a). + rewrite (MapMerge_semantics A m m' a). case (MapGet A m' a). trivial. + intros. discriminate H0. + exact (H a). + Qed. + + Lemma MapMerge_assoc : + forall m m' m'':Map A, + eqmap (MapMerge A (MapMerge A m m') m'') + (MapMerge A m (MapMerge A m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapMerge A m m') m'' a). + rewrite (MapMerge_semantics A m (MapMerge A m' m'') a). rewrite (MapMerge_semantics A m m' a). + rewrite (MapMerge_semantics A m' m'' a). + case (MapGet A m'' a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapMerge_idempotent : forall m:Map A, eqmap (MapMerge A m m) m. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m m a). + case (MapGet A m a); trivial. + Qed. + + Lemma MapMerge_ext : + forall m1 m2 m'1 m'2:Map A, + eqmap m1 m'1 -> + eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m'2). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A m1 m2 a). + rewrite (MapMerge_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. + Qed. + + Lemma MapMerge_ext_l : + forall m1 m'1 m2:Map A, + eqmap m1 m'1 -> eqmap (MapMerge A m1 m2) (MapMerge A m'1 m2). + Proof. + intros. apply MapMerge_ext. assumption. + apply eqmap_refl. + Qed. + + Lemma MapMerge_ext_r : + forall m1 m2 m'2:Map A, + eqmap m2 m'2 -> eqmap (MapMerge A m1 m2) (MapMerge A m1 m'2). + Proof. + intros. apply MapMerge_ext. apply eqmap_refl. + assumption. + Qed. + + Lemma MapMerge_RestrTo_l : + forall m m' m'':Map A, + eqmap (MapMerge A (MapDomRestrTo A A m m') m'') + (MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapMerge_semantics A (MapDomRestrTo A A m m') m'' a). + rewrite (MapDomRestrTo_semantics A A m m' a). + rewrite + (MapDomRestrTo_semantics A A (MapMerge A m m'') (MapMerge A m' m'') a) + . + rewrite (MapMerge_semantics A m' m'' a). rewrite (MapMerge_semantics A m m'' a). + case (MapGet A m'' a); case (MapGet A m' a); reflexivity. + Qed. + + Lemma MapRemove_as_RestrBy : + forall (m:Map A) (a:ad) (y:B), + eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y)). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m a a0). + rewrite (MapDomRestrBy_semantics A B m (M1 B a y) a0). elim (sumbool_of_bool (ad_eq a a0)). + intro H. rewrite H. rewrite (ad_eq_complete a a0 H). rewrite (M1_semantics_1 B a0 y). + reflexivity. + intro H. rewrite H. rewrite (M1_semantics_2 B a a0 y H). reflexivity. + Qed. + + Lemma MapRemove_ext : + forall m m':Map A, + eqmap m m' -> forall a:ad, eqmap (MapRemove A m a) (MapRemove A m' a). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapRemove_semantics A m' a a0). + rewrite (MapRemove_semantics A m a a0). + case (ad_eq a a0); [ reflexivity | apply H ]. + Qed. + + Lemma MapDomRestrTo_empty_m_1 : + forall m:Map B, MapDomRestrTo A B (M0 A) m = M0 A. + Proof. + trivial. + Qed. + + Lemma MapDomRestrTo_empty_m : + forall m:Map B, eqmap (MapDomRestrTo A B (M0 A) m) (M0 A). + Proof. + unfold eqmap, eqm in |- *. trivial. + Qed. + + Lemma MapDomRestrTo_m_empty_1 : + forall m:Map A, MapDomRestrTo A B m (M0 B) = M0 A. + Proof. + simple induction m; trivial. + Qed. + + Lemma MapDomRestrTo_m_empty : + forall m:Map A, eqmap (MapDomRestrTo A B m (M0 B)) (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_m_empty_1 m). reflexivity. + Qed. + + Lemma MapDomRestrTo_assoc : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'') + (MapDomRestrTo A B m (MapDomRestrTo B C m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B m (MapDomRestrTo B C m' m'') a). + rewrite (MapDomRestrTo_semantics B C m' m'' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrTo_idempotent : + forall m:Map A, eqmap (MapDomRestrTo A A m m) m. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A A m m a). + case (MapGet A m a); trivial. + Qed. + + Lemma MapDomRestrTo_Dom : + forall (m:Map A) (m':Map B), + eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m')). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A unit m (MapDom B m') a). + elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H. + elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. unfold in_FSet, in_dom in H. + generalize H. case (MapGet unit (MapDom B m') a); trivial. intro H1. discriminate H1. + intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H. + generalize H. case (MapGet unit (MapDom B m') a). trivial. + intros H0 H1. discriminate H1. + Qed. + + Lemma MapDomRestrBy_empty_m_1 : + forall m:Map B, MapDomRestrBy A B (M0 A) m = M0 A. + Proof. + trivial. + Qed. + + Lemma MapDomRestrBy_empty_m : + forall m:Map B, eqmap (MapDomRestrBy A B (M0 A) m) (M0 A). + Proof. + unfold eqmap, eqm in |- *. trivial. + Qed. + + Lemma MapDomRestrBy_m_empty_1 : + forall m:Map A, MapDomRestrBy A B m (M0 B) = m. + Proof. + simple induction m; trivial. + Qed. + + Lemma MapDomRestrBy_m_empty : + forall m:Map A, eqmap (MapDomRestrBy A B m (M0 B)) m. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_m_empty_1 m). reflexivity. + Qed. + + Lemma MapDomRestrBy_Dom : + forall (m:Map A) (m':Map B), + eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m')). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrBy_semantics A unit m (MapDom B m') a). + elim (sumbool_of_bool (in_FSet a (MapDom B m'))). intro H. + elim (MapDom_semantics_2 B m' a H). intros y H0. rewrite H0. + unfold in_FSet, in_dom in H. generalize H. case (MapGet unit (MapDom B m') a); trivial. + intro H1. discriminate H1. + intro H. rewrite (MapDom_semantics_4 B m' a H). unfold in_FSet, in_dom in H. + generalize H. case (MapGet unit (MapDom B m') a). trivial. + intros H0 H1. discriminate H1. + Qed. + + Lemma MapDomRestrBy_m_m_1 : + forall m:Map A, eqmap (MapDomRestrBy A A m m) (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A A m m a). + case (MapGet A m a); trivial. + Qed. + + Lemma MapDomRestrBy_By : + forall (m:Map A) (m' m'':Map B), + eqmap (MapDomRestrBy A B (MapDomRestrBy A B m m') m'') + (MapDomRestrBy A B m (MapMerge B m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A B m m') m'' a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrBy_semantics A B m (MapMerge B m' m'') a). + rewrite (MapMerge_semantics B m' m'' a). + case (MapGet B m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrBy_By_comm : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrBy A C (MapDomRestrBy A B m m') m'') + (MapDomRestrBy A B (MapDomRestrBy A C m m'') m'). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrBy_semantics A C (MapDomRestrBy A B m m') m'' a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrBy_semantics A B (MapDomRestrBy A C m m'') m' a). + rewrite (MapDomRestrBy_semantics A C m m'' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrBy_To : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'') + (MapDomRestrTo A B m (MapDomRestrBy B C m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B m (MapDomRestrBy B C m' m'') a). + rewrite (MapDomRestrBy_semantics B C m' m'' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrBy_To_comm : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrBy A C (MapDomRestrTo A B m m') m'') + (MapDomRestrTo A B (MapDomRestrBy A C m m'') m'). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrBy_semantics A C (MapDomRestrTo A B m m') m'' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B (MapDomRestrBy A C m m'') m' a). + rewrite (MapDomRestrBy_semantics A C m m'' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrTo_By : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'') + (MapDomRestrTo A C m (MapDomRestrBy C B m'' m')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A C m (MapDomRestrBy C B m'' m') a). + rewrite (MapDomRestrBy_semantics C B m'' m' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrTo_By_comm : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrTo A C (MapDomRestrBy A B m m') m'') + (MapDomRestrBy A B (MapDomRestrTo A C m m'') m'). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrTo_semantics A C (MapDomRestrBy A B m m') m'' a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrBy_semantics A B (MapDomRestrTo A C m m'') m' a). + rewrite (MapDomRestrTo_semantics A C m m'' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapDomRestrTo_To_comm : + forall (m:Map A) (m':Map B) (m'':Map C), + eqmap (MapDomRestrTo A C (MapDomRestrTo A B m m') m'') + (MapDomRestrTo A B (MapDomRestrTo A C m m'') m'). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrTo_semantics A C (MapDomRestrTo A B m m') m'' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B (MapDomRestrTo A C m m'') m' a). + rewrite (MapDomRestrTo_semantics A C m m'' a). + case (MapGet C m'' a); case (MapGet B m' a); trivial. + Qed. + + Lemma MapMerge_DomRestrTo : + forall (m m':Map A) (m'':Map B), + eqmap (MapDomRestrTo A B (MapMerge A m m') m'') + (MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrTo_semantics A B (MapMerge A m m') m'' a). + rewrite (MapMerge_semantics A m m' a). + rewrite + (MapMerge_semantics A (MapDomRestrTo A B m m'') + (MapDomRestrTo A B m' m'') a). + rewrite (MapDomRestrTo_semantics A B m' m'' a). + rewrite (MapDomRestrTo_semantics A B m m'' a). + case (MapGet B m'' a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapMerge_DomRestrBy : + forall (m m':Map A) (m'':Map B), + eqmap (MapDomRestrBy A B (MapMerge A m m') m'') + (MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m'')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrBy_semantics A B (MapMerge A m m') m'' a). + rewrite (MapMerge_semantics A m m' a). + rewrite + (MapMerge_semantics A (MapDomRestrBy A B m m'') + (MapDomRestrBy A B m' m'') a). + rewrite (MapDomRestrBy_semantics A B m' m'' a). + rewrite (MapDomRestrBy_semantics A B m m'' a). + case (MapGet B m'' a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapDelta_empty_m_1 : forall m:Map A, MapDelta A (M0 A) m = m. + Proof. + trivial. + Qed. + + Lemma MapDelta_empty_m : forall m:Map A, eqmap (MapDelta A (M0 A) m) m. + Proof. + unfold eqmap, eqm in |- *. trivial. + Qed. + + Lemma MapDelta_m_empty_1 : forall m:Map A, MapDelta A m (M0 A) = m. + Proof. + simple induction m; trivial. + Qed. + + Lemma MapDelta_m_empty : forall m:Map A, eqmap (MapDelta A m (M0 A)) m. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite MapDelta_m_empty_1. reflexivity. + Qed. + + Lemma MapDelta_nilpotent : forall m:Map A, eqmap (MapDelta A m m) (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m a). + case (MapGet A m a); trivial. + Qed. + + Lemma MapDelta_as_Merge : + forall m m':Map A, + eqmap (MapDelta A m m') + (MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m)). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite (MapDelta_semantics A m m' a). + rewrite + (MapMerge_semantics A (MapDomRestrBy A A m m') ( + MapDomRestrBy A A m' m) a). + rewrite (MapDomRestrBy_semantics A A m' m a). + rewrite (MapDomRestrBy_semantics A A m m' a). + case (MapGet A m a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapDelta_as_DomRestrBy : + forall m m':Map A, + eqmap (MapDelta A m m') + (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a). + rewrite + (MapDomRestrBy_semantics A A (MapMerge A m m') ( + MapDomRestrTo A A m m') a). + rewrite (MapDomRestrTo_semantics A A m m' a). rewrite (MapMerge_semantics A m m' a). + case (MapGet A m a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapDelta_as_DomRestrBy_2 : + forall m m':Map A, + eqmap (MapDelta A m m') + (MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m)). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a). + rewrite + (MapDomRestrBy_semantics A A (MapMerge A m m') ( + MapDomRestrTo A A m' m) a). + rewrite (MapDomRestrTo_semantics A A m' m a). rewrite (MapMerge_semantics A m m' a). + case (MapGet A m a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapDelta_sym : + forall m m':Map A, eqmap (MapDelta A m m') (MapDelta A m' m). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m m' a). + rewrite (MapDelta_semantics A m' m a). + case (MapGet A m a); case (MapGet A m' a); trivial. + Qed. + + Lemma MapDelta_ext : + forall m1 m2 m'1 m'2:Map A, + eqmap m1 m'1 -> + eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m'2). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics A m1 m2 a). + rewrite (MapDelta_semantics A m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. + Qed. + + Lemma MapDelta_ext_l : + forall m1 m'1 m2:Map A, + eqmap m1 m'1 -> eqmap (MapDelta A m1 m2) (MapDelta A m'1 m2). + Proof. + intros. apply MapDelta_ext. assumption. + apply eqmap_refl. + Qed. + + Lemma MapDelta_ext_r : + forall m1 m2 m'2:Map A, + eqmap m2 m'2 -> eqmap (MapDelta A m1 m2) (MapDelta A m1 m'2). + Proof. + intros. apply MapDelta_ext. apply eqmap_refl. + assumption. + Qed. + + Lemma MapDom_Split_1 : + forall (m:Map A) (m':Map B), + eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite + (MapMerge_semantics A (MapDomRestrTo A B m m') ( + MapDomRestrBy A B m m') a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + case (MapGet B m' a); case (MapGet A m a); trivial. + Qed. + + Lemma MapDom_Split_2 : + forall (m:Map A) (m':Map B), + eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m')). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite + (MapMerge_semantics A (MapDomRestrBy A B m m') ( + MapDomRestrTo A B m m') a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + case (MapGet B m' a); case (MapGet A m a); trivial. + Qed. + + Lemma MapDom_Split_3 : + forall (m:Map A) (m':Map B), + eqmap + (MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m')) + (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. + rewrite + (MapDomRestrTo_semantics A A (MapDomRestrTo A B m m') + (MapDomRestrBy A B m m') a). + rewrite (MapDomRestrBy_semantics A B m m' a). + rewrite (MapDomRestrTo_semantics A B m m' a). + case (MapGet B m' a); case (MapGet A m a); trivial. + Qed. + +End MapAxioms. + +Lemma MapDomRestrTo_ext : + forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A) + (m'2:Map B), + eqmap A m1 m'1 -> + eqmap B m2 m'2 -> + eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m'2). +Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrTo_semantics A B m1 m2 a). + rewrite (MapDomRestrTo_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. +Qed. + +Lemma MapDomRestrTo_ext_l : + forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A), + eqmap A m1 m'1 -> + eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m'1 m2). +Proof. + intros. apply MapDomRestrTo_ext; [ assumption | apply eqmap_refl ]. +Qed. + +Lemma MapDomRestrTo_ext_r : + forall (A B:Set) (m1:Map A) (m2 m'2:Map B), + eqmap B m2 m'2 -> + eqmap A (MapDomRestrTo A B m1 m2) (MapDomRestrTo A B m1 m'2). +Proof. + intros. apply MapDomRestrTo_ext; [ apply eqmap_refl | assumption ]. +Qed. + +Lemma MapDomRestrBy_ext : + forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A) + (m'2:Map B), + eqmap A m1 m'1 -> + eqmap B m2 m'2 -> + eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m'2). +Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDomRestrBy_semantics A B m1 m2 a). + rewrite (MapDomRestrBy_semantics A B m'1 m'2 a). rewrite (H a). rewrite (H0 a). reflexivity. +Qed. + +Lemma MapDomRestrBy_ext_l : + forall (A B:Set) (m1:Map A) (m2:Map B) (m'1:Map A), + eqmap A m1 m'1 -> + eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m'1 m2). +Proof. + intros. apply MapDomRestrBy_ext; [ assumption | apply eqmap_refl ]. +Qed. + +Lemma MapDomRestrBy_ext_r : + forall (A B:Set) (m1:Map A) (m2 m'2:Map B), + eqmap B m2 m'2 -> + eqmap A (MapDomRestrBy A B m1 m2) (MapDomRestrBy A B m1 m'2). +Proof. + intros. apply MapDomRestrBy_ext; [ apply eqmap_refl | assumption ]. +Qed. + +Lemma MapDomRestrBy_m_m : + forall (A:Set) (m:Map A), + eqmap A (MapDomRestrBy A unit m (MapDom A m)) (M0 A). +Proof. + intros. apply eqmap_trans with (m' := MapDomRestrBy A A m m). apply eqmap_sym. + apply MapDomRestrBy_Dom. + apply MapDomRestrBy_m_m_1. +Qed. + +Lemma FSetDelta_assoc : + forall s s' s'':FSet, + eqmap unit (MapDelta _ (MapDelta _ s s') s'') + (MapDelta _ s (MapDelta _ s' s'')). +Proof. + unfold eqmap, eqm in |- *. intros. rewrite (MapDelta_semantics unit (MapDelta unit s s') s'' a). + rewrite (MapDelta_semantics unit s s' a). + rewrite (MapDelta_semantics unit s (MapDelta unit s' s'') a). + rewrite (MapDelta_semantics unit s' s'' a). + case (MapGet _ s a); case (MapGet _ s' a); case (MapGet _ s'' a); trivial. + intros. elim u. elim u1. reflexivity. +Qed. + +Lemma FSet_ext : + forall s s':FSet, + (forall a:ad, in_FSet a s = in_FSet a s') -> eqmap unit s s'. +Proof. + unfold in_FSet, eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_dom _ a s)). intro H0. + elim (in_dom_some _ s a H0). intros y H1. rewrite (H a) in H0. elim (in_dom_some _ s' a H0). + intros y' H2. rewrite H1. rewrite H2. elim y. elim y'. reflexivity. + intro H0. rewrite (in_dom_none _ s a H0). rewrite (H a) in H0. rewrite (in_dom_none _ s' a H0). + reflexivity. +Qed. + +Lemma FSetUnion_comm : + forall s s':FSet, eqmap unit (FSetUnion s s') (FSetUnion s' s). +Proof. + intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_union. apply orb_comm. +Qed. + +Lemma FSetUnion_assoc : + forall s s' s'':FSet, + eqmap unit (FSetUnion (FSetUnion s s') s'') + (FSetUnion s (FSetUnion s' s'')). +Proof. + exact (MapMerge_assoc unit). +Qed. + +Lemma FSetUnion_M0_s : forall s:FSet, eqmap unit (FSetUnion (M0 unit) s) s. +Proof. + exact (MapMerge_empty_m unit). +Qed. + +Lemma FSetUnion_s_M0 : forall s:FSet, eqmap unit (FSetUnion s (M0 unit)) s. +Proof. + exact (MapMerge_m_empty unit). +Qed. + +Lemma FSetUnion_idempotent : forall s:FSet, eqmap unit (FSetUnion s s) s. +Proof. + exact (MapMerge_idempotent unit). +Qed. + +Lemma FSetInter_comm : + forall s s':FSet, eqmap unit (FSetInter s s') (FSetInter s' s). +Proof. + intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_inter. apply andb_comm. +Qed. + +Lemma FSetInter_assoc : + forall s s' s'':FSet, + eqmap unit (FSetInter (FSetInter s s') s'') + (FSetInter s (FSetInter s' s'')). +Proof. + exact (MapDomRestrTo_assoc unit unit unit). +Qed. + +Lemma FSetInter_M0_s : + forall s:FSet, eqmap unit (FSetInter (M0 unit) s) (M0 unit). +Proof. + exact (MapDomRestrTo_empty_m unit unit). +Qed. + +Lemma FSetInter_s_M0 : + forall s:FSet, eqmap unit (FSetInter s (M0 unit)) (M0 unit). +Proof. + exact (MapDomRestrTo_m_empty unit unit). +Qed. + +Lemma FSetInter_idempotent : forall s:FSet, eqmap unit (FSetInter s s) s. +Proof. + exact (MapDomRestrTo_idempotent unit). +Qed. + +Lemma FSetUnion_Inter_l : + forall s s' s'':FSet, + eqmap unit (FSetUnion (FSetInter s s') s'') + (FSetInter (FSetUnion s s'') (FSetUnion s' s'')). +Proof. + intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter. + rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union. + case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. +Qed. + +Lemma FSetUnion_Inter_r : + forall s s' s'':FSet, + eqmap unit (FSetUnion s (FSetInter s' s'')) + (FSetInter (FSetUnion s s') (FSetUnion s s'')). +Proof. + intros. apply FSet_ext. intro. rewrite in_FSet_union. rewrite in_FSet_inter. + rewrite in_FSet_inter. rewrite in_FSet_union. rewrite in_FSet_union. + case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. +Qed. + +Lemma FSetInter_Union_l : + forall s s' s'':FSet, + eqmap unit (FSetInter (FSetUnion s s') s'') + (FSetUnion (FSetInter s s'') (FSetInter s' s'')). +Proof. + intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union. + rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter. + case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. +Qed. + +Lemma FSetInter_Union_r : + forall s s' s'':FSet, + eqmap unit (FSetInter s (FSetUnion s' s'')) + (FSetUnion (FSetInter s s') (FSetInter s s'')). +Proof. + intros. apply FSet_ext. intro. rewrite in_FSet_inter. rewrite in_FSet_union. + rewrite in_FSet_union. rewrite in_FSet_inter. rewrite in_FSet_inter. + case (in_FSet a s); case (in_FSet a s'); case (in_FSet a s''); reflexivity. +Qed.
\ No newline at end of file diff --git a/theories/IntMap/Mapc.v b/theories/IntMap/Mapc.v new file mode 100644 index 00000000..7a394abb --- /dev/null +++ b/theories/IntMap/Mapc.v @@ -0,0 +1,542 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapc.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import Arith. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Mapaxioms. +Require Import Fset. +Require Import Mapiter. +Require Import Mapsubset. +Require Import List. +Require Import Lsort. +Require Import Mapcard. +Require Import Mapcanon. + +Section MapC. + + Variables A B C : Set. + + Lemma MapPut_as_Merge_c : + forall m:Map A, + mapcanon A m -> + forall (a:ad) (y:A), MapPut A m a y = MapMerge A m (M1 A a y). + Proof. + intros. apply mapcanon_unique. exact (MapPut_canon A m H a y). + apply MapMerge_canon. assumption. + apply M1_canon. + apply MapPut_as_Merge. + Qed. + + Lemma MapPut_behind_as_Merge_c : + forall m:Map A, + mapcanon A m -> + forall (a:ad) (y:A), MapPut_behind A m a y = MapMerge A (M1 A a y) m. + Proof. + intros. apply mapcanon_unique. exact (MapPut_behind_canon A m H a y). + apply MapMerge_canon. apply M1_canon. + assumption. + apply MapPut_behind_as_Merge. + Qed. + + Lemma MapMerge_empty_m_c : forall m:Map A, MapMerge A (M0 A) m = m. + Proof. + trivial. + Qed. + + Lemma MapMerge_assoc_c : + forall m m' m'':Map A, + mapcanon A m -> + mapcanon A m' -> + mapcanon A m'' -> + MapMerge A (MapMerge A m m') m'' = MapMerge A m (MapMerge A m' m''). + Proof. + intros. apply mapcanon_unique. + apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption. + apply MapMerge_canon; try assumption. apply MapMerge_canon; try assumption. + apply MapMerge_assoc. + Qed. + + Lemma MapMerge_idempotent_c : + forall m:Map A, mapcanon A m -> MapMerge A m m = m. + Proof. + intros. apply mapcanon_unique. apply MapMerge_canon; assumption. + assumption. + apply MapMerge_idempotent. + Qed. + + Lemma MapMerge_RestrTo_l_c : + forall m m' m'':Map A, + mapcanon A m -> + mapcanon A m'' -> + MapMerge A (MapDomRestrTo A A m m') m'' = + MapDomRestrTo A A (MapMerge A m m'') (MapMerge A m' m''). + Proof. + intros. apply mapcanon_unique. apply MapMerge_canon. apply MapDomRestrTo_canon; assumption. + assumption. + apply MapDomRestrTo_canon; apply MapMerge_canon; assumption. + apply MapMerge_RestrTo_l. + Qed. + + Lemma MapRemove_as_RestrBy_c : + forall m:Map A, + mapcanon A m -> + forall (a:ad) (y:B), MapRemove A m a = MapDomRestrBy A B m (M1 B a y). + Proof. + intros. apply mapcanon_unique. apply MapRemove_canon; assumption. + apply MapDomRestrBy_canon; assumption. + apply MapRemove_as_RestrBy. + Qed. + + Lemma MapDomRestrTo_assoc_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrTo A C (MapDomRestrTo A B m m') m'' = + MapDomRestrTo A B m (MapDomRestrTo B C m' m''). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon; try assumption. + apply MapDomRestrTo_canon; try assumption. + apply MapDomRestrTo_canon; try assumption. + apply MapDomRestrTo_assoc. + Qed. + + Lemma MapDomRestrTo_idempotent_c : + forall m:Map A, mapcanon A m -> MapDomRestrTo A A m m = m. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption. + assumption. + apply MapDomRestrTo_idempotent. + Qed. + + Lemma MapDomRestrTo_Dom_c : + forall (m:Map A) (m':Map B), + mapcanon A m -> + MapDomRestrTo A B m m' = MapDomRestrTo A unit m (MapDom B m'). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_Dom. + Qed. + + Lemma MapDomRestrBy_Dom_c : + forall (m:Map A) (m':Map B), + mapcanon A m -> + MapDomRestrBy A B m m' = MapDomRestrBy A unit m (MapDom B m'). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_Dom. + Qed. + + Lemma MapDomRestrBy_By_c : + forall (m:Map A) (m' m'':Map B), + mapcanon A m -> + MapDomRestrBy A B (MapDomRestrBy A B m m') m'' = + MapDomRestrBy A B m (MapMerge B m' m''). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon; try assumption. + apply MapDomRestrBy_canon; try assumption. + apply MapDomRestrBy_canon; try assumption. + apply MapDomRestrBy_By. + Qed. + + Lemma MapDomRestrBy_By_comm_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrBy A C (MapDomRestrBy A B m m') m'' = + MapDomRestrBy A B (MapDomRestrBy A C m m'') m'. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon. + apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_canon. apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_By_comm. + Qed. + + Lemma MapDomRestrBy_To_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrBy A C (MapDomRestrTo A B m m') m'' = + MapDomRestrTo A B m (MapDomRestrBy B C m' m''). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon. + apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_canon; assumption. + apply MapDomRestrBy_To. + Qed. + + Lemma MapDomRestrBy_To_comm_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrBy A C (MapDomRestrTo A B m m') m'' = + MapDomRestrTo A B (MapDomRestrBy A C m m'') m'. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon. + apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_canon. apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_To_comm. + Qed. + + Lemma MapDomRestrTo_By_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrTo A C (MapDomRestrBy A B m m') m'' = + MapDomRestrTo A C m (MapDomRestrBy C B m'' m'). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon. + apply MapDomRestrBy_canon; assumption. + apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_By. + Qed. + + Lemma MapDomRestrTo_By_comm_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrTo A C (MapDomRestrBy A B m m') m'' = + MapDomRestrBy A B (MapDomRestrTo A C m m'') m'. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon. + apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_canon. apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_By_comm. + Qed. + + Lemma MapDomRestrTo_To_comm_c : + forall (m:Map A) (m':Map B) (m'':Map C), + mapcanon A m -> + MapDomRestrTo A C (MapDomRestrTo A B m m') m'' = + MapDomRestrTo A B (MapDomRestrTo A C m m'') m'. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon. + apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_canon. apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_To_comm. + Qed. + + Lemma MapMerge_DomRestrTo_c : + forall (m m':Map A) (m'':Map B), + mapcanon A m -> + mapcanon A m' -> + MapDomRestrTo A B (MapMerge A m m') m'' = + MapMerge A (MapDomRestrTo A B m m'') (MapDomRestrTo A B m' m''). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon. + apply MapMerge_canon; assumption. + apply MapMerge_canon. apply MapDomRestrTo_canon; assumption. + apply MapDomRestrTo_canon; assumption. + apply MapMerge_DomRestrTo. + Qed. + + Lemma MapMerge_DomRestrBy_c : + forall (m m':Map A) (m'':Map B), + mapcanon A m -> + mapcanon A m' -> + MapDomRestrBy A B (MapMerge A m m') m'' = + MapMerge A (MapDomRestrBy A B m m'') (MapDomRestrBy A B m' m''). + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon. apply MapMerge_canon; assumption. + apply MapMerge_canon. apply MapDomRestrBy_canon; assumption. + apply MapDomRestrBy_canon; assumption. + apply MapMerge_DomRestrBy. + Qed. + + Lemma MapDelta_nilpotent_c : + forall m:Map A, mapcanon A m -> MapDelta A m m = M0 A. + Proof. + intros. apply mapcanon_unique. apply MapDelta_canon; assumption. + apply M0_canon. + apply MapDelta_nilpotent. + Qed. + + Lemma MapDelta_as_Merge_c : + forall m m':Map A, + mapcanon A m -> + mapcanon A m' -> + MapDelta A m m' = + MapMerge A (MapDomRestrBy A A m m') (MapDomRestrBy A A m' m). + Proof. + intros. apply mapcanon_unique. apply MapDelta_canon; assumption. + apply MapMerge_canon; apply MapDomRestrBy_canon; assumption. + apply MapDelta_as_Merge. + Qed. + + Lemma MapDelta_as_DomRestrBy_c : + forall m m':Map A, + mapcanon A m -> + mapcanon A m' -> + MapDelta A m m' = + MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m'). + Proof. + intros. apply mapcanon_unique. apply MapDelta_canon; assumption. + apply MapDomRestrBy_canon. apply MapMerge_canon; assumption. + apply MapDelta_as_DomRestrBy. + Qed. + + Lemma MapDelta_as_DomRestrBy_2_c : + forall m m':Map A, + mapcanon A m -> + mapcanon A m' -> + MapDelta A m m' = + MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m' m). + Proof. + intros. apply mapcanon_unique. apply MapDelta_canon; assumption. + apply MapDomRestrBy_canon. apply MapMerge_canon; assumption. + apply MapDelta_as_DomRestrBy_2. + Qed. + + Lemma MapDelta_sym_c : + forall m m':Map A, + mapcanon A m -> mapcanon A m' -> MapDelta A m m' = MapDelta A m' m. + Proof. + intros. apply mapcanon_unique. apply MapDelta_canon; assumption. + apply MapDelta_canon; assumption. apply MapDelta_sym. + Qed. + + Lemma MapDom_Split_1_c : + forall (m:Map A) (m':Map B), + mapcanon A m -> + m = MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'). + Proof. + intros. apply mapcanon_unique. assumption. + apply MapMerge_canon. apply MapDomRestrTo_canon; assumption. + apply MapDomRestrBy_canon; assumption. + apply MapDom_Split_1. + Qed. + + Lemma MapDom_Split_2_c : + forall (m:Map A) (m':Map B), + mapcanon A m -> + m = MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m'). + Proof. + intros. apply mapcanon_unique. assumption. + apply MapMerge_canon. apply MapDomRestrBy_canon; assumption. + apply MapDomRestrTo_canon; assumption. + apply MapDom_Split_2. + Qed. + + Lemma MapDom_Split_3_c : + forall (m:Map A) (m':Map B), + mapcanon A m -> + MapDomRestrTo A A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m') = + M0 A. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrTo_canon. + apply MapDomRestrTo_canon; assumption. + apply M0_canon. + apply MapDom_Split_3. + Qed. + + Lemma Map_of_alist_of_Map_c : + forall m:Map A, mapcanon A m -> Map_of_alist A (alist_of_Map A m) = m. + Proof. + intros. apply mapcanon_unique; try assumption. apply Map_of_alist_canon. + apply Map_of_alist_of_Map. + Qed. + + Lemma alist_of_Map_of_alist_c : + forall l:alist A, + alist_sorted_2 A l -> alist_of_Map A (Map_of_alist A l) = l. + Proof. + intros. apply alist_canonical. apply alist_of_Map_of_alist. + apply alist_of_Map_sorts2. + assumption. + Qed. + + Lemma MapSubset_antisym_c : + forall (m:Map A) (m':Map B), + mapcanon A m -> + mapcanon B m' -> + MapSubset A B m m' -> MapSubset B A m' m -> MapDom A m = MapDom B m'. + Proof. + intros. apply (mapcanon_unique unit). apply MapDom_canon; assumption. + apply MapDom_canon; assumption. + apply MapSubset_antisym; assumption. + Qed. + + Lemma FSubset_antisym_c : + forall s s':FSet, + mapcanon unit s -> + mapcanon unit s' -> MapSubset _ _ s s' -> MapSubset _ _ s' s -> s = s'. + Proof. + intros. apply (mapcanon_unique unit); try assumption. apply FSubset_antisym; assumption. + Qed. + + Lemma MapDisjoint_empty_c : + forall m:Map A, mapcanon A m -> MapDisjoint A A m m -> m = M0 A. + Proof. + intros. apply mapcanon_unique; try assumption; try apply M0_canon. + apply MapDisjoint_empty; assumption. + Qed. + + Lemma MapDelta_disjoint_c : + forall m m':Map A, + mapcanon A m -> + mapcanon A m' -> + MapDisjoint A A m m' -> MapDelta A m m' = MapMerge A m m'. + Proof. + intros. apply mapcanon_unique. apply MapDelta_canon; assumption. + apply MapMerge_canon; assumption. apply MapDelta_disjoint; assumption. + Qed. + +End MapC. + +Lemma FSetDelta_assoc_c : + forall s s' s'':FSet, + mapcanon unit s -> + mapcanon unit s' -> + mapcanon unit s'' -> + MapDelta _ (MapDelta _ s s') s'' = MapDelta _ s (MapDelta _ s' s''). +Proof. + intros. apply (mapcanon_unique unit). apply MapDelta_canon. apply MapDelta_canon; assumption. + assumption. + apply MapDelta_canon. assumption. + apply MapDelta_canon; assumption. + apply FSetDelta_assoc; assumption. +Qed. + +Lemma FSet_ext_c : + forall s s':FSet, + mapcanon unit s -> + mapcanon unit s' -> (forall a:ad, in_FSet a s = in_FSet a s') -> s = s'. +Proof. + intros. apply (mapcanon_unique unit); try assumption. apply FSet_ext. assumption. +Qed. + +Lemma FSetUnion_comm_c : + forall s s':FSet, + mapcanon unit s -> mapcanon unit s' -> FSetUnion s s' = FSetUnion s' s. +Proof. + intros. + apply (mapcanon_unique unit); + try (unfold FSetUnion in |- *; apply MapMerge_canon; assumption). + apply FSetUnion_comm. +Qed. + +Lemma FSetUnion_assoc_c : + forall s s' s'':FSet, + mapcanon unit s -> + mapcanon unit s' -> + mapcanon unit s'' -> + FSetUnion (FSetUnion s s') s'' = FSetUnion s (FSetUnion s' s''). +Proof. + exact (MapMerge_assoc_c unit). +Qed. + +Lemma FSetUnion_M0_s_c : forall s:FSet, FSetUnion (M0 unit) s = s. +Proof. + exact (MapMerge_empty_m_c unit). +Qed. + +Lemma FSetUnion_s_M0_c : forall s:FSet, FSetUnion s (M0 unit) = s. +Proof. + exact (MapMerge_m_empty_1 unit). +Qed. + +Lemma FSetUnion_idempotent : + forall s:FSet, mapcanon unit s -> FSetUnion s s = s. +Proof. + exact (MapMerge_idempotent_c unit). +Qed. + +Lemma FSetInter_comm_c : + forall s s':FSet, + mapcanon unit s -> mapcanon unit s' -> FSetInter s s' = FSetInter s' s. +Proof. + intros. + apply (mapcanon_unique unit); + try (unfold FSetInter in |- *; apply MapDomRestrTo_canon; assumption). + apply FSetInter_comm. +Qed. + +Lemma FSetInter_assoc_c : + forall s s' s'':FSet, + mapcanon unit s -> + FSetInter (FSetInter s s') s'' = FSetInter s (FSetInter s' s''). +Proof. + exact (MapDomRestrTo_assoc_c unit unit unit). +Qed. + +Lemma FSetInter_M0_s_c : forall s:FSet, FSetInter (M0 unit) s = M0 unit. +Proof. + trivial. +Qed. + +Lemma FSetInter_s_M0_c : forall s:FSet, FSetInter s (M0 unit) = M0 unit. +Proof. + exact (MapDomRestrTo_m_empty_1 unit unit). +Qed. + +Lemma FSetInter_idempotent : + forall s:FSet, mapcanon unit s -> FSetInter s s = s. +Proof. + exact (MapDomRestrTo_idempotent_c unit). +Qed. + +Lemma FSetUnion_Inter_l_c : + forall s s' s'':FSet, + mapcanon unit s -> + mapcanon unit s'' -> + FSetUnion (FSetInter s s') s'' = + FSetInter (FSetUnion s s'') (FSetUnion s' s''). +Proof. + intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption. + unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption. + unfold FSetInter in |- *; unfold FSetUnion in |- *; + apply MapDomRestrTo_canon; apply MapMerge_canon; + assumption. + apply FSetUnion_Inter_l. +Qed. + +Lemma FSetUnion_Inter_r : + forall s s' s'':FSet, + mapcanon unit s -> + mapcanon unit s' -> + FSetUnion s (FSetInter s' s'') = + FSetInter (FSetUnion s s') (FSetUnion s s''). +Proof. + intros. apply (mapcanon_unique unit). unfold FSetUnion in |- *. apply MapMerge_canon; try assumption. + unfold FSetInter in |- *. apply MapDomRestrTo_canon; assumption. + unfold FSetInter in |- *; unfold FSetUnion in |- *; + apply MapDomRestrTo_canon; apply MapMerge_canon; + assumption. + apply FSetUnion_Inter_r. +Qed. + +Lemma FSetInter_Union_l_c : + forall s s' s'':FSet, + mapcanon unit s -> + mapcanon unit s' -> + FSetInter (FSetUnion s s') s'' = + FSetUnion (FSetInter s s'') (FSetInter s' s''). +Proof. + intros. apply (mapcanon_unique unit). unfold FSetInter in |- *. + apply MapDomRestrTo_canon; try assumption. unfold FSetUnion in |- *. + apply MapMerge_canon; assumption. + unfold FSetUnion in |- *; unfold FSetInter in |- *; apply MapMerge_canon; + apply MapDomRestrTo_canon; assumption. + apply FSetInter_Union_l. +Qed. + +Lemma FSetInter_Union_r : + forall s s' s'':FSet, + mapcanon unit s -> + mapcanon unit s' -> + FSetInter s (FSetUnion s' s'') = + FSetUnion (FSetInter s s') (FSetInter s s''). +Proof. + intros. apply (mapcanon_unique unit). unfold FSetInter in |- *. + apply MapDomRestrTo_canon; try assumption. + unfold FSetUnion in |- *. apply MapMerge_canon; unfold FSetInter in |- *; apply MapDomRestrTo_canon; + assumption. + apply FSetInter_Union_r. +Qed.
\ No newline at end of file diff --git a/theories/IntMap/Mapcanon.v b/theories/IntMap/Mapcanon.v new file mode 100644 index 00000000..868fbe5e --- /dev/null +++ b/theories/IntMap/Mapcanon.v @@ -0,0 +1,399 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapcanon.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import Arith. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Mapaxioms. +Require Import Mapiter. +Require Import Fset. +Require Import List. +Require Import Lsort. +Require Import Mapsubset. +Require Import Mapcard. + +Section MapCanon. + + Variable A : Set. + + Inductive mapcanon : Map A -> Prop := + | M0_canon : mapcanon (M0 A) + | M1_canon : forall (a:ad) (y:A), mapcanon (M1 A a y) + | M2_canon : + forall m1 m2:Map A, + mapcanon m1 -> + mapcanon m2 -> 2 <= MapCard A (M2 A m1 m2) -> mapcanon (M2 A m1 m2). + + Lemma mapcanon_M2 : + forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> 2 <= MapCard A (M2 A m1 m2). + Proof. + intros. inversion H. assumption. + Qed. + + Lemma mapcanon_M2_1 : + forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m1. + Proof. + intros. inversion H. assumption. + Qed. + + Lemma mapcanon_M2_2 : + forall m1 m2:Map A, mapcanon (M2 A m1 m2) -> mapcanon m2. + Proof. + intros. inversion H. assumption. + Qed. + + Lemma M2_eqmap_1 : + forall m0 m1 m2 m3:Map A, + eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m0 m2. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite <- (ad_double_div_2 a). + rewrite <- (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m0 m1). + rewrite <- (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m2 m3). + exact (H (ad_double a)). + Qed. + + Lemma M2_eqmap_2 : + forall m0 m1 m2 m3:Map A, + eqmap A (M2 A m0 m1) (M2 A m2 m3) -> eqmap A m1 m3. + Proof. + unfold eqmap, eqm in |- *. intros. rewrite <- (ad_double_plus_un_div_2 a). + rewrite <- (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m0 m1). + rewrite <- (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m2 m3). + exact (H (ad_double_plus_un a)). + Qed. + + Lemma mapcanon_unique : + forall m m':Map A, mapcanon m -> mapcanon m' -> eqmap A m m' -> m = m'. + Proof. + simple induction m. simple induction m'. trivial. + intros a y H H0 H1. cut (NONE A = MapGet A (M1 A a y) a). simpl in |- *. rewrite (ad_eq_correct a). + intro. discriminate H2. + exact (H1 a). + intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4). + rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2). + intros a y. simple induction m'. intros. cut (MapGet A (M1 A a y) a = NONE A). simpl in |- *. + rewrite (ad_eq_correct a). intro. discriminate H2. + exact (H1 a). + intros a0 y0 H H0 H1. cut (MapGet A (M1 A a y) a = MapGet A (M1 A a0 y0) a). simpl in |- *. + rewrite (ad_eq_correct a). intro. elim (sumbool_of_bool (ad_eq a0 a)). intro H3. + rewrite H3 in H2. inversion H2. rewrite (ad_eq_complete _ _ H3). reflexivity. + intro H3. rewrite H3 in H2. discriminate H2. + exact (H1 a). + intros. cut (2 <= MapCard A (M1 A a y)). intro. elim (le_Sn_O _ (le_S_n _ _ H4)). + rewrite (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H2). + simple induction m'. intros. cut (2 <= MapCard A (M0 A)). intro. elim (le_Sn_O _ H4). + rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1). + intros a y H1 H2 H3. cut (2 <= MapCard A (M1 A a y)). intro. + elim (le_Sn_O _ (le_S_n _ _ H4)). + rewrite <- (MapCard_ext A _ _ H3). exact (mapcanon_M2 _ _ H1). + intros. rewrite (H m2). rewrite (H0 m3). reflexivity. + exact (mapcanon_M2_2 _ _ H3). + exact (mapcanon_M2_2 _ _ H4). + exact (M2_eqmap_2 _ _ _ _ H5). + exact (mapcanon_M2_1 _ _ H3). + exact (mapcanon_M2_1 _ _ H4). + exact (M2_eqmap_1 _ _ _ _ H5). + Qed. + + Lemma MapPut1_canon : + forall (p:positive) (a a':ad) (y y':A), mapcanon (MapPut1 A a y a' y' p). + Proof. + simple induction p. simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M1_canon. + apply M1_canon. + apply le_n. + apply M2_canon. apply M1_canon. + apply M1_canon. + apply le_n. + simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M0_canon. + apply H. + simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n. + apply M2_canon. apply H. + apply M0_canon. + simpl in |- *. rewrite MapCard_Put1_equals_2. apply le_n. + simpl in |- *. simpl in |- *. intros. case (ad_bit_0 a). apply M2_canon. apply M1_canon. + apply M1_canon. + simpl in |- *. apply le_n. + apply M2_canon. apply M1_canon. + apply M1_canon. + simpl in |- *. apply le_n. + Qed. + + Lemma MapPut_canon : + forall m:Map A, + mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut A m a y). + Proof. + simple induction m. intros. simpl in |- *. apply M1_canon. + intros a0 y0 H a y. simpl in |- *. case (ad_xor a0 a). apply M1_canon. + intro. apply MapPut1_canon. + intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). + exact (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1). + apply plus_le_compat. exact (MapCard_Put_lb A m0 ad_z y). + apply le_n. + intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1). + apply H0. exact (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). + exact (mapcanon_M2 m0 m1 H1). + apply plus_le_compat_l. exact (MapCard_Put_lb A m1 (ad_x p0) y). + intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). + exact (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). + exact (mapcanon_M2 m0 m1 H1). + apply plus_le_compat_r. exact (MapCard_Put_lb A m0 (ad_x p0) y). + apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1). + apply H0. apply (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). + exact (mapcanon_M2 m0 m1 H1). + apply plus_le_compat_l. exact (MapCard_Put_lb A m1 ad_z y). + Qed. + + Lemma MapPut_behind_canon : + forall m:Map A, + mapcanon m -> forall (a:ad) (y:A), mapcanon (MapPut_behind A m a y). + Proof. + simple induction m. intros. simpl in |- *. apply M1_canon. + intros a0 y0 H a y. simpl in |- *. case (ad_xor a0 a). apply M1_canon. + intro. apply MapPut1_canon. + intros. simpl in |- *. elim a. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). + exact (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). exact (mapcanon_M2 _ _ H1). + apply plus_le_compat. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 ad_z y). + apply le_n. + intro. case p. intro. apply M2_canon. exact (mapcanon_M2_1 m0 m1 H1). + apply H0. exact (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). + exact (mapcanon_M2 m0 m1 H1). + apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 (ad_x p0) y). + intro. apply M2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). + exact (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). + exact (mapcanon_M2 m0 m1 H1). + apply plus_le_compat_r. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m0 (ad_x p0) y). + apply M2_canon. apply (mapcanon_M2_1 m0 m1 H1). + apply H0. apply (mapcanon_M2_2 m0 m1 H1). + simpl in |- *. apply le_trans with (m := MapCard A m0 + MapCard A m1). + exact (mapcanon_M2 m0 m1 H1). + apply plus_le_compat_l. rewrite MapCard_Put_behind_Put. exact (MapCard_Put_lb A m1 ad_z y). + Qed. + + Lemma makeM2_canon : + forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (makeM2 A m m'). + Proof. + intro. case m. intro. case m'. intros. exact M0_canon. + intros a y H H0. exact (M1_canon (ad_double_plus_un a) y). + intros. simpl in |- *. apply M2_canon; try assumption. exact (mapcanon_M2 m0 m1 H0). + intros a y m'. case m'. intros. exact (M1_canon (ad_double a) y). + intros a0 y0 H H0. simpl in |- *. apply M2_canon; try assumption. apply le_n. + intros. simpl in |- *. apply M2_canon; try assumption. + apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H0). + exact (le_plus_r (MapCard A (M1 A a y)) (MapCard A (M2 A m0 m1))). + simpl in |- *. intros. apply M2_canon; try assumption. + apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H). + exact (le_plus_l (MapCard A (M2 A m0 m1)) (MapCard A m')). + Qed. + + Fixpoint MapCanonicalize (m:Map A) : Map A := + match m with + | M2 m0 m1 => makeM2 A (MapCanonicalize m0) (MapCanonicalize m1) + | _ => m + end. + + Lemma mapcanon_exists_1 : forall m:Map A, eqmap A m (MapCanonicalize m). + Proof. + simple induction m. apply eqmap_refl. + intros. apply eqmap_refl. + intros. simpl in |- *. unfold eqmap, eqm in |- *. intro. + rewrite (makeM2_M2 A (MapCanonicalize m0) (MapCanonicalize m1) a). + rewrite MapGet_M2_bit_0_if. rewrite MapGet_M2_bit_0_if. + rewrite <- (H (ad_div_2 a)). rewrite <- (H0 (ad_div_2 a)). reflexivity. + Qed. + + Lemma mapcanon_exists_2 : forall m:Map A, mapcanon (MapCanonicalize m). + Proof. + simple induction m. apply M0_canon. + intros. simpl in |- *. apply M1_canon. + intros. simpl in |- *. apply makeM2_canon; assumption. + Qed. + + Lemma mapcanon_exists : + forall m:Map A, {m' : Map A | eqmap A m m' /\ mapcanon m'}. + Proof. + intro. split with (MapCanonicalize m). split. apply mapcanon_exists_1. + apply mapcanon_exists_2. + Qed. + + Lemma MapRemove_canon : + forall m:Map A, mapcanon m -> forall a:ad, mapcanon (MapRemove A m a). + Proof. + simple induction m. intros. exact M0_canon. + intros a y H a0. simpl in |- *. case (ad_eq a a0). exact M0_canon. + assumption. + intros. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1). + apply H0. exact (mapcanon_M2_2 _ _ H1). + apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1). + exact (mapcanon_M2_2 _ _ H1). + Qed. + + Lemma MapMerge_canon : + forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapMerge A m m'). + Proof. + simple induction m. intros. exact H0. + simpl in |- *. intros a y m' H H0. exact (MapPut_behind_canon m' H0 a y). + simple induction m'. intros. exact H1. + intros a y H1 H2. unfold MapMerge in |- *. exact (MapPut_canon _ H1 a y). + intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 _ _ H3). + exact (mapcanon_M2_1 _ _ H4). + apply H0. exact (mapcanon_M2_2 _ _ H3). + exact (mapcanon_M2_2 _ _ H4). + change (2 <= MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3))) in |- *. + apply le_trans with (m := MapCard A (M2 A m0 m1)). exact (mapcanon_M2 _ _ H3). + exact (MapMerge_Card_lb_l A (M2 A m0 m1) (M2 A m2 m3)). + Qed. + + Lemma MapDelta_canon : + forall m m':Map A, mapcanon m -> mapcanon m' -> mapcanon (MapDelta A m m'). + Proof. + simple induction m. intros. exact H0. + simpl in |- *. intros a y m' H H0. case (MapGet A m' a). exact (MapPut_canon m' H0 a y). + intro. exact (MapRemove_canon m' H0 a). + simple induction m'. intros. exact H1. + unfold MapDelta in |- *. intros a y H1 H2. case (MapGet A (M2 A m0 m1) a). + exact (MapPut_canon _ H1 a y). + intro. exact (MapRemove_canon _ H1 a). + intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H3). + exact (mapcanon_M2_1 _ _ H4). + apply H0. exact (mapcanon_M2_2 _ _ H3). + exact (mapcanon_M2_2 _ _ H4). + Qed. + + Variable B : Set. + + Lemma MapDomRestrTo_canon : + forall m:Map A, + mapcanon m -> forall m':Map B, mapcanon (MapDomRestrTo A B m m'). + Proof. + simple induction m. intros. exact M0_canon. + simpl in |- *. intros a y H m'. case (MapGet B m' a). exact M0_canon. + intro. apply M1_canon. + simple induction m'. exact M0_canon. + unfold MapDomRestrTo in |- *. intros a y. case (MapGet A (M2 A m0 m1) a). exact M0_canon. + intro. apply M1_canon. + intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 m0 m1 H1). + apply H0. exact (mapcanon_M2_2 m0 m1 H1). + Qed. + + Lemma MapDomRestrBy_canon : + forall m:Map A, + mapcanon m -> forall m':Map B, mapcanon (MapDomRestrBy A B m m'). + Proof. + simple induction m. intros. exact M0_canon. + simpl in |- *. intros a y H m'. case (MapGet B m' a). assumption. + intro. exact M0_canon. + simple induction m'. exact H1. + intros a y. simpl in |- *. case (ad_bit_0 a). apply makeM2_canon. exact (mapcanon_M2_1 _ _ H1). + apply MapRemove_canon. exact (mapcanon_M2_2 _ _ H1). + apply makeM2_canon. apply MapRemove_canon. exact (mapcanon_M2_1 _ _ H1). + exact (mapcanon_M2_2 _ _ H1). + intros. simpl in |- *. apply makeM2_canon. apply H. exact (mapcanon_M2_1 _ _ H1). + apply H0. exact (mapcanon_M2_2 _ _ H1). + Qed. + + Lemma Map_of_alist_canon : forall l:alist A, mapcanon (Map_of_alist A l). + Proof. + simple induction l. exact M0_canon. + intro r. elim r. intros a y l0 H. simpl in |- *. apply MapPut_canon. assumption. + Qed. + + Lemma MapSubset_c_1 : + forall (m:Map A) (m':Map B), + mapcanon m -> MapSubset A B m m' -> MapDomRestrBy A B m m' = M0 A. + Proof. + intros. apply mapcanon_unique. apply MapDomRestrBy_canon. assumption. + apply M0_canon. + exact (MapSubset_imp_2 _ _ m m' H0). + Qed. + + Lemma MapSubset_c_2 : + forall (m:Map A) (m':Map B), + MapDomRestrBy A B m m' = M0 A -> MapSubset A B m m'. + Proof. + intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. rewrite H. apply eqmap_refl. + Qed. + +End MapCanon. + +Section FSetCanon. + + Variable A : Set. + + Lemma MapDom_canon : + forall m:Map A, mapcanon A m -> mapcanon unit (MapDom A m). + Proof. + simple induction m. intro. exact (M0_canon unit). + intros a y H. exact (M1_canon unit a _). + intros. simpl in |- *. apply M2_canon. apply H. exact (mapcanon_M2_1 A _ _ H1). + apply H0. exact (mapcanon_M2_2 A _ _ H1). + change (2 <= MapCard unit (MapDom A (M2 A m0 m1))) in |- *. rewrite <- MapCard_Dom. + exact (mapcanon_M2 A _ _ H1). + Qed. + +End FSetCanon. + +Section MapFoldCanon. + + Variables A B : Set. + + Lemma MapFold_canon_1 : + forall m0:Map B, + mapcanon B m0 -> + forall op:Map B -> Map B -> Map B, + (forall m1:Map B, + mapcanon B m1 -> + forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) -> + forall f:ad -> A -> Map B, + (forall (a:ad) (y:A), mapcanon B (f a y)) -> + forall (m:Map A) (pf:ad -> ad), + mapcanon B (MapFold1 A (Map B) m0 op f pf m). + Proof. + simple induction m. intro. exact H. + intros a y pf. simpl in |- *. apply H1. + intros. simpl in |- *. apply H0. apply H2. + apply H3. + Qed. + + Lemma MapFold_canon : + forall m0:Map B, + mapcanon B m0 -> + forall op:Map B -> Map B -> Map B, + (forall m1:Map B, + mapcanon B m1 -> + forall m2:Map B, mapcanon B m2 -> mapcanon B (op m1 m2)) -> + forall f:ad -> A -> Map B, + (forall (a:ad) (y:A), mapcanon B (f a y)) -> + forall m:Map A, mapcanon B (MapFold A (Map B) m0 op f m). + Proof. + intros. exact (MapFold_canon_1 m0 H op H0 f H1 m (fun a:ad => a)). + Qed. + + Lemma MapCollect_canon : + forall f:ad -> A -> Map B, + (forall (a:ad) (y:A), mapcanon B (f a y)) -> + forall m:Map A, mapcanon B (MapCollect A B f m). + Proof. + intros. rewrite MapCollect_as_Fold. apply MapFold_canon. apply M0_canon. + intros. exact (MapMerge_canon B m1 m2 H0 H1). + assumption. + Qed. + +End MapFoldCanon.
\ No newline at end of file diff --git a/theories/IntMap/Mapcard.v b/theories/IntMap/Mapcard.v new file mode 100644 index 00000000..49f9fe91 --- /dev/null +++ b/theories/IntMap/Mapcard.v @@ -0,0 +1,764 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapcard.v,v 1.5.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import Arith. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Mapaxioms. +Require Import Mapiter. +Require Import Fset. +Require Import Mapsubset. +Require Import List. +Require Import Lsort. +Require Import Peano_dec. + +Section MapCard. + + Variables A B : Set. + + Lemma MapCard_M0 : MapCard A (M0 A) = 0. + Proof. + trivial. + Qed. + + Lemma MapCard_M1 : forall (a:ad) (y:A), MapCard A (M1 A a y) = 1. + Proof. + trivial. + Qed. + + Lemma MapCard_is_O : + forall m:Map A, MapCard A m = 0 -> forall a:ad, MapGet A m a = NONE A. + Proof. + simple induction m. trivial. + intros a y H. discriminate H. + intros. simpl in H1. elim (plus_is_O _ _ H1). intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a). + case (ad_bit_0 a). apply H0. assumption. + apply H. assumption. + Qed. + + Lemma MapCard_is_not_O : + forall (m:Map A) (a:ad) (y:A), + MapGet A m a = SOME A y -> {n : nat | MapCard A m = S n}. + Proof. + simple induction m. intros. discriminate H. + intros a y a0 y0 H. simpl in H. elim (sumbool_of_bool (ad_eq a a0)). intro H0. split with 0. + reflexivity. + intro H0. rewrite H0 in H. discriminate H. + intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. + rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. elim (H0 (ad_div_2 a) y H1). intros n H3. + simpl in |- *. rewrite H3. split with (MapCard A m0 + n). + rewrite <- (plus_Snm_nSm (MapCard A m0) n). reflexivity. + intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. elim (H (ad_div_2 a) y H1). + intros n H3. simpl in |- *. rewrite H3. split with (n + MapCard A m1). reflexivity. + Qed. + + Lemma MapCard_is_one : + forall m:Map A, + MapCard A m = 1 -> {a : ad & {y : A | MapGet A m a = SOME A y}}. + Proof. + simple induction m. intro. discriminate H. + intros a y H. split with a. split with y. apply M1_semantics_1. + intros. simpl in H1. elim (plus_is_one (MapCard A m0) (MapCard A m1) H1). + intro H2. elim H2. intros. elim (H0 H4). intros a H5. split with (ad_double_plus_un a). + rewrite (MapGet_M2_bit_0_1 A _ (ad_double_plus_un_bit_0 a) m0 m1). + rewrite ad_double_plus_un_div_2. exact H5. + intro H2. elim H2. intros. elim (H H3). intros a H5. split with (ad_double a). + rewrite (MapGet_M2_bit_0_0 A _ (ad_double_bit_0 a) m0 m1). + rewrite ad_double_div_2. exact H5. + Qed. + + Lemma MapCard_is_one_unique : + forall m:Map A, + MapCard A m = 1 -> + forall (a a':ad) (y y':A), + MapGet A m a = SOME A y -> + MapGet A m a' = SOME A y' -> a = a' /\ y = y'. + Proof. + simple induction m. intro. discriminate H. + intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. rewrite (ad_eq_complete _ _ H2) in H0. + rewrite (M1_semantics_1 A a1 a0) in H0. inversion H0. elim (sumbool_of_bool (ad_eq a a')). + intro H5. rewrite (ad_eq_complete _ _ H5) in H1. rewrite (M1_semantics_1 A a' a0) in H1. + inversion H1. rewrite <- (ad_eq_complete _ _ H2). rewrite <- (ad_eq_complete _ _ H5). + rewrite <- H4. rewrite <- H6. split; reflexivity. + intro H5. rewrite (M1_semantics_2 A a a' a0 H5) in H1. discriminate H1. + intro H2. rewrite (M1_semantics_2 A a a1 a0 H2) in H0. discriminate H0. + intros. simpl in H1. elim (plus_is_one _ _ H1). intro H4. elim H4. intros. + rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. elim (sumbool_of_bool (ad_bit_0 a)). + intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3. + elim (sumbool_of_bool (ad_bit_0 a')). intro H8. rewrite H8 in H3. elim (H0 H6 _ _ _ _ H2 H3). + intros. split. rewrite <- (ad_div_2_double_plus_un a H7). + rewrite <- (ad_div_2_double_plus_un a' H8). rewrite H9. reflexivity. + assumption. + intro H8. rewrite H8 in H3. rewrite (MapCard_is_O m0 H5 (ad_div_2 a')) in H3. + discriminate H3. + intro H7. rewrite H7 in H2. rewrite (MapCard_is_O m0 H5 (ad_div_2 a)) in H2. + discriminate H2. + intro H4. elim H4. intros. rewrite (MapGet_M2_bit_0_if A m0 m1 a) in H2. + elim (sumbool_of_bool (ad_bit_0 a)). intro H7. rewrite H7 in H2. + rewrite (MapCard_is_O m1 H6 (ad_div_2 a)) in H2. discriminate H2. + intro H7. rewrite H7 in H2. rewrite (MapGet_M2_bit_0_if A m0 m1 a') in H3. + elim (sumbool_of_bool (ad_bit_0 a')). intro H8. rewrite H8 in H3. + rewrite (MapCard_is_O m1 H6 (ad_div_2 a')) in H3. discriminate H3. + intro H8. rewrite H8 in H3. elim (H H5 _ _ _ _ H2 H3). intros. split. + rewrite <- (ad_div_2_double a H7). rewrite <- (ad_div_2_double a' H8). + rewrite H9. reflexivity. + assumption. + Qed. + + Lemma length_as_fold : + forall (C:Set) (l:list C), + length l = fold_right (fun (_:C) (n:nat) => S n) 0 l. + Proof. + simple induction l. reflexivity. + intros. simpl in |- *. rewrite H. reflexivity. + Qed. + + Lemma length_as_fold_2 : + forall l:alist A, + length l = + fold_right (fun (r:ad * A) (n:nat) => let (a, y) := r in 1 + n) 0 l. + Proof. + simple induction l. reflexivity. + intros. simpl in |- *. rewrite H. elim a; reflexivity. + Qed. + + Lemma MapCard_as_Fold_1 : + forall (m:Map A) (pf:ad -> ad), + MapCard A m = MapFold1 A nat 0 plus (fun (_:ad) (_:A) => 1) pf m. + Proof. + simple induction m. trivial. + trivial. + intros. simpl in |- *. rewrite <- (H (fun a0:ad => pf (ad_double a0))). + rewrite <- (H0 (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity. + Qed. + + Lemma MapCard_as_Fold : + forall m:Map A, + MapCard A m = MapFold A nat 0 plus (fun (_:ad) (_:A) => 1) m. + Proof. + intro. exact (MapCard_as_Fold_1 m (fun a0:ad => a0)). + Qed. + + Lemma MapCard_as_length : + forall m:Map A, MapCard A m = length (alist_of_Map A m). + Proof. + intro. rewrite MapCard_as_Fold. rewrite length_as_fold_2. + apply MapFold_as_fold with + (op := plus) (neutral := 0) (f := fun (_:ad) (_:A) => 1). exact plus_assoc_reverse. + trivial. + intro. rewrite <- plus_n_O. reflexivity. + Qed. + + Lemma MapCard_Put1_equals_2 : + forall (p:positive) (a a':ad) (y y':A), + MapCard A (MapPut1 A a y a' y' p) = 2. + Proof. + simple induction p. intros. simpl in |- *. case (ad_bit_0 a); reflexivity. + intros. simpl in |- *. case (ad_bit_0 a). exact (H (ad_div_2 a) (ad_div_2 a') y y'). + simpl in |- *. rewrite <- plus_n_O. exact (H (ad_div_2 a) (ad_div_2 a') y y'). + intros. simpl in |- *. case (ad_bit_0 a); reflexivity. + Qed. + + Lemma MapCard_Put_sum : + forall (m m':Map A) (a:ad) (y:A) (n n':nat), + m' = MapPut A m a y -> + n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}. + Proof. + simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. right. + rewrite H0. rewrite H1. reflexivity. + intros a y m' a0 y0 n n' H H0 H1. simpl in H. elim (ad_sum (ad_xor a a0)). intro H2. + elim H2. intros p H3. rewrite H3 in H. rewrite H in H1. + rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H1. simpl in H0. right. + rewrite H0. rewrite H1. reflexivity. + intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. simpl in H0. left. + rewrite H0. rewrite H1. reflexivity. + intros. simpl in H2. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. + elim (sumbool_of_bool (ad_bit_0 a)). intro H4. rewrite H4 in H1. + elim + (H0 (MapPut A m1 (ad_div_2 a) y) (ad_div_2 a) y ( + MapCard A m1) (MapCard A (MapPut A m1 (ad_div_2 a) y)) ( + refl_equal _) (refl_equal _) (refl_equal _)). + intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3. left. + assumption. + intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. + rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)) in H3. + simpl in H3. rewrite <- H2 in H3. right. assumption. + intro H4. rewrite H4 in H1. + elim + (H (MapPut A m0 (ad_div_2 a) y) (ad_div_2 a) y ( + MapCard A m0) (MapCard A (MapPut A m0 (ad_div_2 a) y)) ( + refl_equal _) (refl_equal _) (refl_equal _)). + intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. rewrite <- H2 in H3. + left. assumption. + intro H5. rewrite H1 in H3. simpl in H3. rewrite H5 in H3. simpl in H3. rewrite <- H2 in H3. + right. assumption. + Qed. + + Lemma MapCard_Put_lb : + forall (m:Map A) (a:ad) (y:A), MapCard A (MapPut A m a y) >= MapCard A m. + Proof. + unfold ge in |- *. intros. + elim + (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m) + (MapCard A (MapPut A m a y)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H. rewrite H. apply le_n. + intro H. rewrite H. apply le_n_Sn. + Qed. + + Lemma MapCard_Put_ub : + forall (m:Map A) (a:ad) (y:A), + MapCard A (MapPut A m a y) <= S (MapCard A m). + Proof. + intros. + elim + (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m) + (MapCard A (MapPut A m a y)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H. rewrite H. apply le_n_Sn. + intro H. rewrite H. apply le_n. + Qed. + + Lemma MapCard_Put_1 : + forall (m:Map A) (a:ad) (y:A), + MapCard A (MapPut A m a y) = MapCard A m -> + {y : A | MapGet A m a = SOME A y}. + Proof. + simple induction m. intros. discriminate H. + intros a y a0 y0 H. simpl in H. elim (ad_sum (ad_xor a a0)). intro H0. elim H0. + intros p H1. rewrite H1 in H. rewrite (MapCard_Put1_equals_2 p a a0 y y0) in H. + discriminate H. + intro H0. rewrite H0 in H. rewrite (ad_xor_eq _ _ H0). split with y. apply M1_semantics_1. + intros. rewrite (MapPut_semantics_3_1 A m0 m1 a y) in H1. elim (sumbool_of_bool (ad_bit_0 a)). + intro H2. rewrite H2 in H1. simpl in H1. elim (H0 (ad_div_2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). + intros y0 H3. split with y0. rewrite <- H3. exact (MapGet_M2_bit_0_1 A a H2 m0 m1). + intro H2. rewrite H2 in H1. simpl in H1. + rewrite + (plus_comm (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) + in H1. + rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. + elim (H (ad_div_2 a) y ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1)). intros y0 H3. split with y0. + rewrite <- H3. exact (MapGet_M2_bit_0_0 A a H2 m0 m1). + Qed. + + Lemma MapCard_Put_2 : + forall (m:Map A) (a:ad) (y:A), + MapCard A (MapPut A m a y) = S (MapCard A m) -> MapGet A m a = NONE A. + Proof. + simple induction m. trivial. + intros. simpl in H. elim (sumbool_of_bool (ad_eq a a1)). intro H0. + rewrite (ad_eq_complete _ _ H0) in H. rewrite (ad_xor_nilpotent a1) in H. discriminate H. + intro H0. exact (M1_semantics_2 A a a1 a0 H0). + intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. + rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply (H0 (ad_div_2 a) y). + apply (fun n m p:nat => plus_reg_l m p n) with (n := MapCard A m0). + rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). simpl in H1. simpl in |- *. rewrite <- H1. + clear H1. + induction a. discriminate H2. + induction p. reflexivity. + discriminate H2. + reflexivity. + intro H2. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply (H (ad_div_2 a) y). + cut + (MapCard A (MapPut A m0 (ad_div_2 a) y) + MapCard A m1 = + S (MapCard A m0) + MapCard A m1). + intro. rewrite (plus_comm (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) + in H3. + rewrite (plus_comm (S (MapCard A m0)) (MapCard A m1)) in H3. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H3). + simpl in |- *. simpl in H1. rewrite <- H1. induction a. trivial. + induction p. discriminate H2. + reflexivity. + discriminate H2. + Qed. + + Lemma MapCard_Put_1_conv : + forall (m:Map A) (a:ad) (y y':A), + MapGet A m a = SOME A y -> MapCard A (MapPut A m a y') = MapCard A m. + Proof. + intros. + elim + (MapCard_Put_sum m (MapPut A m a y') a y' (MapCard A m) + (MapCard A (MapPut A m a y')) (refl_equal _) ( + refl_equal _) (refl_equal _)). + trivial. + intro H0. rewrite (MapCard_Put_2 m a y' H0) in H. discriminate H. + Qed. + + Lemma MapCard_Put_2_conv : + forall (m:Map A) (a:ad) (y:A), + MapGet A m a = NONE A -> MapCard A (MapPut A m a y) = S (MapCard A m). + Proof. + intros. + elim + (MapCard_Put_sum m (MapPut A m a y) a y (MapCard A m) + (MapCard A (MapPut A m a y)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H0. elim (MapCard_Put_1 m a y H0). intros y' H1. rewrite H1 in H. discriminate H. + trivial. + Qed. + + Lemma MapCard_ext : + forall m m':Map A, + eqm A (MapGet A m) (MapGet A m') -> MapCard A m = MapCard A m'. + Proof. + unfold eqm in |- *. intros. rewrite (MapCard_as_length m). rewrite (MapCard_as_length m'). + rewrite (alist_canonical A (alist_of_Map A m) (alist_of_Map A m')). reflexivity. + unfold eqm in |- *. intro. rewrite (Map_of_alist_semantics A (alist_of_Map A m) a). + rewrite (Map_of_alist_semantics A (alist_of_Map A m') a). rewrite (Map_of_alist_of_Map A m' a). + rewrite (Map_of_alist_of_Map A m a). exact (H a). + apply alist_of_Map_sorts2. + apply alist_of_Map_sorts2. + Qed. + + Lemma MapCard_Dom : forall m:Map A, MapCard A m = MapCard unit (MapDom A m). + Proof. + simple induction m; trivial. intros. simpl in |- *. rewrite H. rewrite H0. reflexivity. + Qed. + + Lemma MapCard_Dom_Put_behind : + forall (m:Map A) (a:ad) (y:A), + MapDom A (MapPut_behind A m a y) = MapDom A (MapPut A m a y). + Proof. + simple induction m. trivial. + intros a y a0 y0. simpl in |- *. elim (ad_sum (ad_xor a a0)). intro H. elim H. + intros p H0. rewrite H0. reflexivity. + intro H. rewrite H. rewrite (ad_xor_eq _ _ H). reflexivity. + intros. simpl in |- *. elim (ad_sum a). intro H1. elim H1. intros p H2. rewrite H2. case p. + intro p0. simpl in |- *. rewrite H0. reflexivity. + intro p0. simpl in |- *. rewrite H. reflexivity. + simpl in |- *. rewrite H0. reflexivity. + intro H1. rewrite H1. simpl in |- *. rewrite H. reflexivity. + Qed. + + Lemma MapCard_Put_behind_Put : + forall (m:Map A) (a:ad) (y:A), + MapCard A (MapPut_behind A m a y) = MapCard A (MapPut A m a y). + Proof. + intros. rewrite MapCard_Dom. rewrite MapCard_Dom. rewrite MapCard_Dom_Put_behind. + reflexivity. + Qed. + + Lemma MapCard_Put_behind_sum : + forall (m m':Map A) (a:ad) (y:A) (n n':nat), + m' = MapPut_behind A m a y -> + n = MapCard A m -> n' = MapCard A m' -> {n' = n} + {n' = S n}. + Proof. + intros. apply (MapCard_Put_sum m (MapPut A m a y) a y n n'); trivial. + rewrite <- MapCard_Put_behind_Put. rewrite <- H. assumption. + Qed. + + Lemma MapCard_makeM2 : + forall m m':Map A, MapCard A (makeM2 A m m') = MapCard A m + MapCard A m'. + Proof. + intros. rewrite (MapCard_ext _ _ (makeM2_M2 A m m')). reflexivity. + Qed. + + Lemma MapCard_Remove_sum : + forall (m m':Map A) (a:ad) (n n':nat), + m' = MapRemove A m a -> + n = MapCard A m -> n' = MapCard A m' -> {n = n'} + {n = S n'}. + Proof. + simple induction m. simpl in |- *. intros. rewrite H in H1. simpl in H1. left. rewrite H1. assumption. + simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. rewrite H2 in H. + rewrite H in H1. simpl in H1. right. rewrite H1. assumption. + intro H2. rewrite H2 in H. rewrite H in H1. simpl in H1. left. rewrite H1. assumption. + intros. simpl in H1. simpl in H2. elim (sumbool_of_bool (ad_bit_0 a)). intro H4. + rewrite H4 in H1. rewrite H1 in H3. + rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H3. + elim + (H0 (MapRemove A m1 (ad_div_2 a)) (ad_div_2 a) ( + MapCard A m1) (MapCard A (MapRemove A m1 (ad_div_2 a))) + (refl_equal _) (refl_equal _) (refl_equal _)). + intro H5. rewrite H5 in H2. left. rewrite H3. exact H2. + intro H5. rewrite H5 in H2. + rewrite <- + (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a)))) + in H2. + right. rewrite H3. exact H2. + intro H4. rewrite H4 in H1. rewrite H1 in H3. + rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H3. + elim + (H (MapRemove A m0 (ad_div_2 a)) (ad_div_2 a) ( + MapCard A m0) (MapCard A (MapRemove A m0 (ad_div_2 a))) + (refl_equal _) (refl_equal _) (refl_equal _)). + intro H5. rewrite H5 in H2. left. rewrite H3. exact H2. + intro H5. rewrite H5 in H2. right. rewrite H3. exact H2. + Qed. + + Lemma MapCard_Remove_ub : + forall (m:Map A) (a:ad), MapCard A (MapRemove A m a) <= MapCard A m. + Proof. + intros. + elim + (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) + (MapCard A (MapRemove A m a)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H. rewrite H. apply le_n. + intro H. rewrite H. apply le_n_Sn. + Qed. + + Lemma MapCard_Remove_lb : + forall (m:Map A) (a:ad), S (MapCard A (MapRemove A m a)) >= MapCard A m. + Proof. + unfold ge in |- *. intros. + elim + (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) + (MapCard A (MapRemove A m a)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H. rewrite H. apply le_n_Sn. + intro H. rewrite H. apply le_n. + Qed. + + Lemma MapCard_Remove_1 : + forall (m:Map A) (a:ad), + MapCard A (MapRemove A m a) = MapCard A m -> MapGet A m a = NONE A. + Proof. + simple induction m. trivial. + simpl in |- *. intros a y a0 H. elim (sumbool_of_bool (ad_eq a a0)). intro H0. + rewrite H0 in H. discriminate H. + intro H0. rewrite H0. reflexivity. + intros. simpl in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2 in H1. + rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1. + rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). + intro H2. rewrite H2 in H1. + rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1. + rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H. + rewrite + (plus_comm (MapCard A (MapRemove A m0 (ad_div_2 a))) (MapCard A m1)) + in H1. + rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). + Qed. + + Lemma MapCard_Remove_2 : + forall (m:Map A) (a:ad), + S (MapCard A (MapRemove A m a)) = MapCard A m -> + {y : A | MapGet A m a = SOME A y}. + Proof. + simple induction m. intros. discriminate H. + intros a y a0 H. simpl in H. elim (sumbool_of_bool (ad_eq a a0)). intro H0. + rewrite (ad_eq_complete _ _ H0). split with y. exact (M1_semantics_1 A a0 y). + intro H0. rewrite H0 in H. discriminate H. + intros. simpl in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. rewrite H2 in H1. + rewrite (MapCard_makeM2 m0 (MapRemove A m1 (ad_div_2 a))) in H1. + rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1). apply H0. + change + (S (MapCard A m0) + MapCard A (MapRemove A m1 (ad_div_2 a)) = + MapCard A m0 + MapCard A m1) in H1. + rewrite + (plus_Snm_nSm (MapCard A m0) (MapCard A (MapRemove A m1 (ad_div_2 a)))) + in H1. + exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). + intro H2. rewrite H2 in H1. rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1). apply H. + rewrite (MapCard_makeM2 (MapRemove A m0 (ad_div_2 a)) m1) in H1. + change + (S (MapCard A (MapRemove A m0 (ad_div_2 a))) + MapCard A m1 = + MapCard A m0 + MapCard A m1) in H1. + rewrite + (plus_comm (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1)) + in H1. + rewrite (plus_comm (MapCard A m0) (MapCard A m1)) in H1. exact ((fun n m p:nat => plus_reg_l m p n) _ _ _ H1). + Qed. + + Lemma MapCard_Remove_1_conv : + forall (m:Map A) (a:ad), + MapGet A m a = NONE A -> MapCard A (MapRemove A m a) = MapCard A m. + Proof. + intros. + elim + (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) + (MapCard A (MapRemove A m a)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H0. rewrite H0. reflexivity. + intro H0. elim (MapCard_Remove_2 m a (sym_eq H0)). intros y H1. rewrite H1 in H. + discriminate H. + Qed. + + Lemma MapCard_Remove_2_conv : + forall (m:Map A) (a:ad) (y:A), + MapGet A m a = SOME A y -> S (MapCard A (MapRemove A m a)) = MapCard A m. + Proof. + intros. + elim + (MapCard_Remove_sum m (MapRemove A m a) a (MapCard A m) + (MapCard A (MapRemove A m a)) (refl_equal _) ( + refl_equal _) (refl_equal _)). + intro H0. rewrite (MapCard_Remove_1 m a (sym_eq H0)) in H. discriminate H. + intro H0. rewrite H0. reflexivity. + Qed. + + Lemma MapMerge_Restr_Card : + forall m m':Map A, + MapCard A m + MapCard A m' = + MapCard A (MapMerge A m m') + MapCard A (MapDomRestrTo A A m m'). + Proof. + simple induction m. simpl in |- *. intro. apply plus_n_O. + simpl in |- *. intros a y m'. elim (option_sum A (MapGet A m' a)). intro H. elim H. intros y0 H0. + rewrite H0. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_1_conv m' a y0 y H0). + simpl in |- *. rewrite <- plus_Snm_nSm. apply plus_n_O. + intro H. rewrite H. rewrite MapCard_Put_behind_Put. rewrite (MapCard_Put_2_conv m' a y H). + apply plus_n_O. + intros. + change + (MapCard A m0 + MapCard A m1 + MapCard A m' = + MapCard A (MapMerge A (M2 A m0 m1) m') + + MapCard A (MapDomRestrTo A A (M2 A m0 m1) m')) + in |- *. + elim m'. reflexivity. + intros a y. unfold MapMerge in |- *. unfold MapDomRestrTo in |- *. + elim (option_sum A (MapGet A (M2 A m0 m1) a)). intro H1. elim H1. intros y0 H2. rewrite H2. + rewrite (MapCard_Put_1_conv (M2 A m0 m1) a y0 y H2). reflexivity. + intro H1. rewrite H1. rewrite (MapCard_Put_2_conv (M2 A m0 m1) a y H1). simpl in |- *. + rewrite <- (plus_Snm_nSm (MapCard A m0 + MapCard A m1) 0). reflexivity. + intros. simpl in |- *. + rewrite + (plus_permute_2_in_4 (MapCard A m0) (MapCard A m1) ( + MapCard A m2) (MapCard A m3)). + rewrite (H m2). rewrite (H0 m3). + rewrite + (MapCard_makeM2 (MapDomRestrTo A A m0 m2) (MapDomRestrTo A A m1 m3)) + . + apply plus_permute_2_in_4. + Qed. + + Lemma MapMerge_disjoint_Card : + forall m m':Map A, + MapDisjoint A A m m' -> + MapCard A (MapMerge A m m') = MapCard A m + MapCard A m'. + Proof. + intros. rewrite (MapMerge_Restr_Card m m'). + rewrite (MapCard_ext _ _ (MapDisjoint_imp_2 _ _ _ _ H)). apply plus_n_O. + Qed. + + Lemma MapSplit_Card : + forall (m:Map A) (m':Map B), + MapCard A m = + MapCard A (MapDomRestrTo A B m m') + MapCard A (MapDomRestrBy A B m m'). + Proof. + intros. rewrite (MapCard_ext _ _ (MapDom_Split_1 A B m m')). apply MapMerge_disjoint_Card. + apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *. apply MapDom_Split_3. + Qed. + + Lemma MapMerge_Card_ub : + forall m m':Map A, + MapCard A (MapMerge A m m') <= MapCard A m + MapCard A m'. + Proof. + intros. rewrite MapMerge_Restr_Card. apply le_plus_l. + Qed. + + Lemma MapDomRestrTo_Card_ub_l : + forall (m:Map A) (m':Map B), + MapCard A (MapDomRestrTo A B m m') <= MapCard A m. + Proof. + intros. rewrite (MapSplit_Card m m'). apply le_plus_l. + Qed. + + Lemma MapDomRestrBy_Card_ub_l : + forall (m:Map A) (m':Map B), + MapCard A (MapDomRestrBy A B m m') <= MapCard A m. + Proof. + intros. rewrite (MapSplit_Card m m'). apply le_plus_r. + Qed. + + Lemma MapMerge_Card_disjoint : + forall m m':Map A, + MapCard A (MapMerge A m m') = MapCard A m + MapCard A m' -> + MapDisjoint A A m m'. + Proof. + simple induction m. intros. apply Map_M0_disjoint. + simpl in |- *. intros. rewrite (MapCard_Put_behind_Put m' a a0) in H. unfold MapDisjoint, in_dom in |- *. + simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H2. + rewrite (ad_eq_complete _ _ H2) in H. rewrite (MapCard_Put_2 m' a1 a0 H) in H1. + discriminate H1. + intro H2. rewrite H2 in H0. discriminate H0. + simple induction m'. intros. apply Map_disjoint_M0. + intros a y H1. rewrite <- (MapCard_ext _ _ (MapPut_as_Merge A (M2 A m0 m1) a y)) in H1. + unfold MapCard at 3 in H1. rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) 0) in H1. + rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. unfold MapDisjoint, in_dom in |- *. + unfold MapGet at 2 in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). intro H4. + rewrite <- (ad_eq_complete _ _ H4) in H2. rewrite (MapCard_Put_2 _ _ _ H1) in H2. + discriminate H2. + intro H4. rewrite H4 in H3. discriminate H3. + intros. unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H6. + unfold MapDisjoint in H0. apply H0 with (m' := m3) (a := ad_div_2 a). apply le_antisym. + apply MapMerge_Card_ub. + apply (fun p n m:nat => plus_le_reg_l n m p) with + (p := MapCard A m0 + MapCard A m2). + rewrite + (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) ( + MapCard A m1) (MapCard A m3)). + change + (MapCard A (M2 A (MapMerge A m0 m2) (MapMerge A m1 m3)) = + MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) + in H3. + rewrite <- H3. simpl in |- *. apply plus_le_compat_r. apply MapMerge_Card_ub. + elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m0 m1) in H7. + unfold in_dom in |- *. rewrite H7. reflexivity. + elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_1 _ a H6 m2 m3) in H7. + unfold in_dom in |- *. rewrite H7. reflexivity. + intro H6. unfold MapDisjoint in H. apply H with (m' := m2) (a := ad_div_2 a). apply le_antisym. + apply MapMerge_Card_ub. + apply (fun p n m:nat => plus_le_reg_l n m p) with + (p := MapCard A m1 + MapCard A m3). + rewrite + (plus_comm (MapCard A m1 + MapCard A m3) (MapCard A m0 + MapCard A m2)) + . + rewrite + (plus_permute_2_in_4 (MapCard A m0) (MapCard A m2) ( + MapCard A m1) (MapCard A m3)). + rewrite + (plus_comm (MapCard A m1 + MapCard A m3) (MapCard A (MapMerge A m0 m2))) + . + change + (MapCard A (MapMerge A m0 m2) + MapCard A (MapMerge A m1 m3) = + MapCard A m0 + MapCard A m1 + (MapCard A m2 + MapCard A m3)) + in H3. + rewrite <- H3. apply plus_le_compat_l. apply MapMerge_Card_ub. + elim (in_dom_some _ _ _ H4). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m0 m1) in H7. + unfold in_dom in |- *. rewrite H7. reflexivity. + elim (in_dom_some _ _ _ H5). intros y H7. rewrite (MapGet_M2_bit_0_0 _ a H6 m2 m3) in H7. + unfold in_dom in |- *. rewrite H7. reflexivity. + Qed. + + Lemma MapCard_is_Sn : + forall (m:Map A) (n:nat), + MapCard _ m = S n -> {a : ad | in_dom _ a m = true}. + Proof. + simple induction m. intros. discriminate H. + intros a y n H. split with a. unfold in_dom in |- *. rewrite (M1_semantics_1 _ a y). reflexivity. + intros. simpl in H1. elim (O_or_S (MapCard _ m0)). intro H2. elim H2. intros m2 H3. + elim (H _ (sym_eq H3)). intros a H4. split with (ad_double a). unfold in_dom in |- *. + rewrite (MapGet_M2_bit_0_0 A (ad_double a) (ad_double_bit_0 a) m0 m1). + rewrite (ad_double_div_2 a). elim (in_dom_some _ _ _ H4). intros y H5. rewrite H5. reflexivity. + intro H2. rewrite <- H2 in H1. simpl in H1. elim (H0 _ H1). intros a H3. + split with (ad_double_plus_un a). unfold in_dom in |- *. + rewrite + (MapGet_M2_bit_0_1 A (ad_double_plus_un a) (ad_double_plus_un_bit_0 a) + m0 m1). + rewrite (ad_double_plus_un_div_2 a). elim (in_dom_some _ _ _ H3). intros y H4. rewrite H4. + reflexivity. + Qed. + +End MapCard. + +Section MapCard2. + + Variables A B : Set. + + Lemma MapSubset_card_eq_1 : + forall (n:nat) (m:Map A) (m':Map B), + MapSubset _ _ m m' -> + MapCard _ m = n -> MapCard _ m' = n -> MapSubset _ _ m' m. + Proof. + simple induction n. intros. unfold MapSubset, in_dom in |- *. intro. rewrite (MapCard_is_O _ m H0 a). + rewrite (MapCard_is_O _ m' H1 a). intro H2. discriminate H2. + intros. elim (MapCard_is_Sn A m n0 H1). intros a H3. elim (in_dom_some _ _ _ H3). + intros y H4. elim (in_dom_some _ _ _ (H0 _ H3)). intros y' H6. + cut (eqmap _ (MapPut _ (MapRemove _ m a) a y) m). intro. + cut (eqmap _ (MapPut _ (MapRemove _ m' a) a y') m'). intro. + apply MapSubset_ext with + (m0 := MapPut _ (MapRemove _ m' a) a y') + (m2 := MapPut _ (MapRemove _ m a) a y). + assumption. + assumption. + apply MapSubset_Put_mono. apply H. apply MapSubset_Remove_mono. assumption. + rewrite <- (MapCard_Remove_2_conv _ m a y H4) in H1. inversion_clear H1. reflexivity. + rewrite <- (MapCard_Remove_2_conv _ m' a y' H6) in H2. inversion_clear H2. reflexivity. + unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove B m' a) a y' a0). + elim (sumbool_of_bool (ad_eq a a0)). intro H7. rewrite H7. rewrite <- (ad_eq_complete _ _ H7). + apply sym_eq. assumption. + intro H7. rewrite H7. rewrite (MapRemove_semantics _ m' a a0). rewrite H7. reflexivity. + unfold eqmap, eqm in |- *. intro. rewrite (MapPut_semantics _ (MapRemove A m a) a y a0). + elim (sumbool_of_bool (ad_eq a a0)). intro H7. rewrite H7. rewrite <- (ad_eq_complete _ _ H7). + apply sym_eq. assumption. + intro H7. rewrite H7. rewrite (MapRemove_semantics A m a a0). rewrite H7. reflexivity. + Qed. + + Lemma MapDomRestrTo_Card_ub_r : + forall (m:Map A) (m':Map B), + MapCard A (MapDomRestrTo A B m m') <= MapCard B m'. + Proof. + simple induction m. intro. simpl in |- *. apply le_O_n. + intros a y m'. simpl in |- *. elim (option_sum B (MapGet B m' a)). intro H. elim H. intros y0 H0. + rewrite H0. elim (MapCard_is_not_O B m' a y0 H0). intros n H1. rewrite H1. simpl in |- *. + apply le_n_S. apply le_O_n. + intro H. rewrite H. simpl in |- *. apply le_O_n. + simple induction m'. simpl in |- *. apply le_O_n. + + intros a y. unfold MapDomRestrTo in |- *. case (MapGet A (M2 A m0 m1) a). simpl in |- *. apply le_O_n. + intro. simpl in |- *. apply le_n. + intros. simpl in |- *. rewrite + (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3)) + . + apply plus_le_compat. apply H. + apply H0. + Qed. + +End MapCard2. + +Section MapCard3. + + Variables A B : Set. + + Lemma MapMerge_Card_lb_l : + forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m. + Proof. + unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m')). + rewrite (plus_comm (MapCard A m') (MapCard A m)). + rewrite (plus_comm (MapCard A m') (MapCard A (MapMerge A m m'))). + rewrite (MapMerge_Restr_Card A m m'). apply plus_le_compat_l. apply MapDomRestrTo_Card_ub_r. + Qed. + + Lemma MapMerge_Card_lb_r : + forall m m':Map A, MapCard A (MapMerge A m m') >= MapCard A m'. + Proof. + unfold ge in |- *. intros. apply ((fun p n m:nat => plus_le_reg_l n m p) (MapCard A m)). rewrite (MapMerge_Restr_Card A m m'). + rewrite + (plus_comm (MapCard A (MapMerge A m m')) + (MapCard A (MapDomRestrTo A A m m'))). + apply plus_le_compat_r. apply MapDomRestrTo_Card_ub_l. + Qed. + + Lemma MapDomRestrBy_Card_lb : + forall (m:Map A) (m':Map B), + MapCard B m' + MapCard A (MapDomRestrBy A B m m') >= MapCard A m. + Proof. + unfold ge in |- *. intros. rewrite (MapSplit_Card A B m m'). apply plus_le_compat_r. + apply MapDomRestrTo_Card_ub_r. + Qed. + + Lemma MapSubset_Card_le : + forall (m:Map A) (m':Map B), + MapSubset A B m m' -> MapCard A m <= MapCard B m'. + Proof. + intros. apply le_trans with (m := MapCard B m' + MapCard A (MapDomRestrBy A B m m')). + exact (MapDomRestrBy_Card_lb m m'). + rewrite (MapCard_ext _ _ _ (MapSubset_imp_2 _ _ _ _ H)). simpl in |- *. rewrite <- plus_n_O. + apply le_n. + Qed. + + Lemma MapSubset_card_eq : + forall (m:Map A) (m':Map B), + MapSubset _ _ m m' -> + MapCard _ m' <= MapCard _ m -> eqmap _ (MapDom _ m) (MapDom _ m'). + Proof. + intros. apply MapSubset_antisym. assumption. + cut (MapCard B m' = MapCard A m). intro. apply (MapSubset_card_eq_1 A B (MapCard A m)). + assumption. + reflexivity. + assumption. + apply le_antisym. assumption. + apply MapSubset_Card_le. assumption. + Qed. + +End MapCard3.
\ No newline at end of file diff --git a/theories/IntMap/Mapfold.v b/theories/IntMap/Mapfold.v new file mode 100644 index 00000000..641529ee --- /dev/null +++ b/theories/IntMap/Mapfold.v @@ -0,0 +1,424 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapfold.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Fset. +Require Import Mapaxioms. +Require Import Mapiter. +Require Import Lsort. +Require Import Mapsubset. +Require Import List. + +Section MapFoldResults. + + Variable A : Set. + + Variable M : Set. + Variable neutral : M. + Variable op : M -> M -> M. + + Variable nleft : forall a:M, op neutral a = a. + Variable nright : forall a:M, op a neutral = a. + Variable assoc : forall a b c:M, op (op a b) c = op a (op b c). + + Lemma MapFold_ext : + forall (f:ad -> A -> M) (m m':Map A), + eqmap A m m' -> MapFold _ _ neutral op f m = MapFold _ _ neutral op f m'. + Proof. + intros. rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m). + rewrite (MapFold_as_fold A M neutral op assoc nleft nright f m'). + cut (alist_of_Map A m = alist_of_Map A m'). intro. rewrite H0. reflexivity. + apply alist_canonical. unfold eqmap in H. apply eqm_trans with (f' := MapGet A m). + apply eqm_sym. apply alist_of_Map_semantics. + apply eqm_trans with (f' := MapGet A m'). assumption. + apply alist_of_Map_semantics. + apply alist_of_Map_sorts2. + apply alist_of_Map_sorts2. + Qed. + + Lemma MapFold_ext_f_1 : + forall (m:Map A) (f g:ad -> A -> M) (pf:ad -> ad), + (forall (a:ad) (y:A), MapGet _ m a = SOME _ y -> f (pf a) y = g (pf a) y) -> + MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op g pf m. + Proof. + simple induction m. trivial. + simpl in |- *. intros. apply H. rewrite (ad_eq_correct a). reflexivity. + intros. simpl in |- *. rewrite (H f g (fun a0:ad => pf (ad_double a0))). + rewrite (H0 f g (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity. + intros. apply H1. rewrite MapGet_M2_bit_0_1. rewrite ad_double_plus_un_div_2. assumption. + apply ad_double_plus_un_bit_0. + intros. apply H1. rewrite MapGet_M2_bit_0_0. rewrite ad_double_div_2. assumption. + apply ad_double_bit_0. + Qed. + + Lemma MapFold_ext_f : + forall (f g:ad -> A -> M) (m:Map A), + (forall (a:ad) (y:A), MapGet _ m a = SOME _ y -> f a y = g a y) -> + MapFold _ _ neutral op f m = MapFold _ _ neutral op g m. + Proof. + intros. exact (MapFold_ext_f_1 m f g (fun a0:ad => a0) H). + Qed. + + Lemma MapFold1_as_Fold_1 : + forall (m:Map A) (f f':ad -> A -> M) (pf pf':ad -> ad), + (forall (a:ad) (y:A), f (pf a) y = f' (pf' a) y) -> + MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op f' pf' m. + Proof. + simple induction m. trivial. + intros. simpl in |- *. apply H. + intros. simpl in |- *. + rewrite + (H f f' (fun a0:ad => pf (ad_double a0)) + (fun a0:ad => pf' (ad_double a0))). + rewrite + (H0 f f' (fun a0:ad => pf (ad_double_plus_un a0)) + (fun a0:ad => pf' (ad_double_plus_un a0))). + reflexivity. + intros. apply H1. + intros. apply H1. + Qed. + + Lemma MapFold1_as_Fold : + forall (f:ad -> A -> M) (pf:ad -> ad) (m:Map A), + MapFold1 _ _ neutral op f pf m = + MapFold _ _ neutral op (fun (a:ad) (y:A) => f (pf a) y) m. + Proof. + intros. unfold MapFold in |- *. apply MapFold1_as_Fold_1. trivial. + Qed. + + Lemma MapFold1_ext : + forall (f:ad -> A -> M) (m m':Map A), + eqmap A m m' -> + forall pf:ad -> ad, + MapFold1 _ _ neutral op f pf m = MapFold1 _ _ neutral op f pf m'. + Proof. + intros. rewrite MapFold1_as_Fold. rewrite MapFold1_as_Fold. apply MapFold_ext. assumption. + Qed. + + Variable comm : forall a b:M, op a b = op b a. + + Lemma MapFold_Put_disjoint_1 : + forall (p:positive) (f:ad -> A -> M) (pf:ad -> ad) + (a1 a2:ad) (y1 y2:A), + ad_xor a1 a2 = ad_x p -> + MapFold1 A M neutral op f pf (MapPut1 A a1 y1 a2 y2 p) = + op (f (pf a1) y1) (f (pf a2) y2). + Proof. + simple induction p. intros. simpl in |- *. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1. + simpl in |- *. rewrite ad_div_2_double_plus_un. rewrite ad_div_2_double. apply comm. + change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0). + rewrite negb_elim. reflexivity. + assumption. + intro H1. rewrite H1. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un. + reflexivity. + change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H1. rewrite (ad_neg_bit_0_2 _ _ _ H0). + rewrite negb_elim. reflexivity. + assumption. + simpl in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a1)). intro H1. rewrite H1. simpl in |- *. + rewrite nleft. + rewrite + (H f (fun a0:ad => pf (ad_double_plus_un a0)) ( + ad_div_2 a1) (ad_div_2 a2) y1 y2). + rewrite ad_div_2_double_plus_un. rewrite ad_div_2_double_plus_un. reflexivity. + rewrite <- (ad_same_bit_0 _ _ _ H0). assumption. + assumption. + rewrite <- ad_xor_div_2. rewrite H0. reflexivity. + intro H1. rewrite H1. simpl in |- *. rewrite nright. + rewrite + (H f (fun a0:ad => pf (ad_double a0)) (ad_div_2 a1) (ad_div_2 a2) y1 y2) + . + rewrite ad_div_2_double. rewrite ad_div_2_double. reflexivity. + rewrite <- (ad_same_bit_0 _ _ _ H0). assumption. + assumption. + rewrite <- ad_xor_div_2. rewrite H0. reflexivity. + intros. simpl in |- *. elim (sumbool_of_bool (ad_bit_0 a1)). intro H0. rewrite H0. simpl in |- *. + rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un. apply comm. + assumption. + change (ad_bit_0 a2 = negb true) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H). + rewrite negb_elim. reflexivity. + intro H0. rewrite H0. simpl in |- *. rewrite ad_div_2_double. rewrite ad_div_2_double_plus_un. + reflexivity. + change (ad_bit_0 a2 = negb false) in |- *. rewrite <- H0. rewrite (ad_neg_bit_0_1 _ _ H). + rewrite negb_elim. reflexivity. + assumption. + Qed. + + Lemma MapFold_Put_disjoint_2 : + forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad), + MapGet A m a = NONE A -> + MapFold1 A M neutral op f pf (MapPut A m a y) = + op (f (pf a) y) (MapFold1 A M neutral op f pf m). + Proof. + simple induction m. intros. simpl in |- *. rewrite (nright (f (pf a) y)). reflexivity. + intros a1 y1 a2 y2 pf H. simpl in |- *. elim (ad_sum (ad_xor a1 a2)). intro H0. elim H0. + intros p H1. rewrite H1. rewrite comm. exact (MapFold_Put_disjoint_1 p f pf a1 a2 y1 y2 H1). + intro H0. rewrite (ad_eq_complete _ _ (ad_xor_eq_true _ _ H0)) in H. + rewrite (M1_semantics_1 A a2 y1) in H. discriminate H. + intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H2. + cut (MapPut A (M2 A m0 m1) a y = M2 A m0 (MapPut A m1 (ad_div_2 a) y)). intro. + rewrite H3. simpl in |- *. rewrite (H0 (ad_div_2 a) y (fun a0:ad => pf (ad_double_plus_un a0))). + rewrite ad_div_2_double_plus_un. rewrite <- assoc. + rewrite + (comm (MapFold1 A M neutral op f (fun a0:ad => pf (ad_double a0)) m0) + (f (pf a) y)). + rewrite assoc. reflexivity. + assumption. + rewrite (MapGet_M2_bit_0_1 A a H2 m0 m1) in H1. assumption. + simpl in |- *. elim (ad_sum a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5. + reflexivity. + intros p0 H4 H5. rewrite H5 in H2. discriminate H2. + intro H4. rewrite H4. reflexivity. + intro H3. rewrite H3 in H2. discriminate H2. + intro H2. cut (MapPut A (M2 A m0 m1) a y = M2 A (MapPut A m0 (ad_div_2 a) y) m1). + intro. rewrite H3. simpl in |- *. rewrite (H (ad_div_2 a) y (fun a0:ad => pf (ad_double a0))). + rewrite ad_div_2_double. rewrite <- assoc. reflexivity. + assumption. + rewrite (MapGet_M2_bit_0_0 A a H2 m0 m1) in H1. assumption. + simpl in |- *. elim (ad_sum a). intro H3. elim H3. intro p. elim p. intros p0 H4 H5. rewrite H5 in H2. + discriminate H2. + intros p0 H4 H5. rewrite H5. reflexivity. + intro H4. rewrite H4 in H2. discriminate H2. + intro H3. rewrite H3. reflexivity. + Qed. + + Lemma MapFold_Put_disjoint : + forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A), + MapGet A m a = NONE A -> + MapFold A M neutral op f (MapPut A m a y) = + op (f a y) (MapFold A M neutral op f m). + Proof. + intros. exact (MapFold_Put_disjoint_2 f m a y (fun a0:ad => a0) H). + Qed. + + Lemma MapFold_Put_behind_disjoint_2 : + forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A) (pf:ad -> ad), + MapGet A m a = NONE A -> + MapFold1 A M neutral op f pf (MapPut_behind A m a y) = + op (f (pf a) y) (MapFold1 A M neutral op f pf m). + Proof. + intros. cut (eqmap A (MapPut_behind A m a y) (MapPut A m a y)). intro. + rewrite (MapFold1_ext f _ _ H0 pf). apply MapFold_Put_disjoint_2. assumption. + apply eqmap_trans with (m' := MapMerge A (M1 A a y) m). apply MapPut_behind_as_Merge. + apply eqmap_trans with (m' := MapMerge A m (M1 A a y)). + apply eqmap_trans with (m' := MapDelta A (M1 A a y) m). apply eqmap_sym. apply MapDelta_disjoint. + unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a0)). + intro H2. rewrite (ad_eq_complete _ _ H2) in H. rewrite H in H1. discriminate H1. + intro H2. rewrite H2 in H0. discriminate H0. + apply eqmap_trans with (m' := MapDelta A m (M1 A a y)). apply MapDelta_sym. + apply MapDelta_disjoint. unfold MapDisjoint in |- *. unfold in_dom in |- *. simpl in |- *. intros. + elim (sumbool_of_bool (ad_eq a a0)). intro H2. rewrite (ad_eq_complete _ _ H2) in H. + rewrite H in H0. discriminate H0. + intro H2. rewrite H2 in H1. discriminate H1. + apply eqmap_sym. apply MapPut_as_Merge. + Qed. + + Lemma MapFold_Put_behind_disjoint : + forall (f:ad -> A -> M) (m:Map A) (a:ad) (y:A), + MapGet A m a = NONE A -> + MapFold A M neutral op f (MapPut_behind A m a y) = + op (f a y) (MapFold A M neutral op f m). + Proof. + intros. exact (MapFold_Put_behind_disjoint_2 f m a y (fun a0:ad => a0) H). + Qed. + + Lemma MapFold_Merge_disjoint_1 : + forall (f:ad -> A -> M) (m1 m2:Map A) (pf:ad -> ad), + MapDisjoint A A m1 m2 -> + MapFold1 A M neutral op f pf (MapMerge A m1 m2) = + op (MapFold1 A M neutral op f pf m1) (MapFold1 A M neutral op f pf m2). + Proof. + simple induction m1. simpl in |- *. intros. rewrite nleft. reflexivity. + intros. unfold MapMerge in |- *. apply (MapFold_Put_behind_disjoint_2 f m2 a a0 pf). + apply in_dom_none. exact (MapDisjoint_M1_l _ _ m2 a a0 H). + simple induction m2. intros. simpl in |- *. rewrite nright. reflexivity. + intros. unfold MapMerge in |- *. rewrite (MapFold_Put_disjoint_2 f (M2 A m m0) a a0 pf). apply comm. + apply in_dom_none. exact (MapDisjoint_M1_r _ _ (M2 A m m0) a a0 H1). + intros. simpl in |- *. rewrite (H m3 (fun a0:ad => pf (ad_double a0))). + rewrite (H0 m4 (fun a0:ad => pf (ad_double_plus_un a0))). + cut (forall a b c d:M, op (op a b) (op c d) = op (op a c) (op b d)). intro. apply H4. + intros. rewrite assoc. rewrite <- (assoc b c d). rewrite (comm b c). rewrite (assoc c b d). + rewrite assoc. reflexivity. + exact (MapDisjoint_M2_r _ _ _ _ _ _ H3). + exact (MapDisjoint_M2_l _ _ _ _ _ _ H3). + Qed. + + Lemma MapFold_Merge_disjoint : + forall (f:ad -> A -> M) (m1 m2:Map A), + MapDisjoint A A m1 m2 -> + MapFold A M neutral op f (MapMerge A m1 m2) = + op (MapFold A M neutral op f m1) (MapFold A M neutral op f m2). + Proof. + intros. exact (MapFold_Merge_disjoint_1 f m1 m2 (fun a0:ad => a0) H). + Qed. + +End MapFoldResults. + +Section MapFoldDistr. + + Variable A : Set. + + Variable M : Set. + Variable neutral : M. + Variable op : M -> M -> M. + + Variable M' : Set. + Variable neutral' : M'. + Variable op' : M' -> M' -> M'. + + Variable N : Set. + + Variable times : M -> N -> M'. + + Variable absorb : forall c:N, times neutral c = neutral'. + Variable + distr : + forall (a b:M) (c:N), times (op a b) c = op' (times a c) (times b c). + + Lemma MapFold_distr_r_1 : + forall (f:ad -> A -> M) (m:Map A) (c:N) (pf:ad -> ad), + times (MapFold1 A M neutral op f pf m) c = + MapFold1 A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) pf m. + Proof. + simple induction m. intros. exact (absorb c). + trivial. + intros. simpl in |- *. rewrite distr. rewrite H. rewrite H0. reflexivity. + Qed. + + Lemma MapFold_distr_r : + forall (f:ad -> A -> M) (m:Map A) (c:N), + times (MapFold A M neutral op f m) c = + MapFold A M' neutral' op' (fun (a:ad) (y:A) => times (f a y) c) m. + Proof. + intros. exact (MapFold_distr_r_1 f m c (fun a:ad => a)). + Qed. + +End MapFoldDistr. + +Section MapFoldDistrL. + + Variable A : Set. + + Variable M : Set. + Variable neutral : M. + Variable op : M -> M -> M. + + Variable M' : Set. + Variable neutral' : M'. + Variable op' : M' -> M' -> M'. + + Variable N : Set. + + Variable times : N -> M -> M'. + + Variable absorb : forall c:N, times c neutral = neutral'. + Variable + distr : + forall (a b:M) (c:N), times c (op a b) = op' (times c a) (times c b). + + Lemma MapFold_distr_l : + forall (f:ad -> A -> M) (m:Map A) (c:N), + times c (MapFold A M neutral op f m) = + MapFold A M' neutral' op' (fun (a:ad) (y:A) => times c (f a y)) m. + Proof. + intros. apply MapFold_distr_r with (times := fun (a:M) (b:N) => times b a); + assumption. + Qed. + +End MapFoldDistrL. + +Section MapFoldExists. + + Variable A : Set. + + Lemma MapFold_orb_1 : + forall (f:ad -> A -> bool) (m:Map A) (pf:ad -> ad), + MapFold1 A bool false orb f pf m = + match MapSweep1 A f pf m with + | SOME _ => true + | _ => false + end. + Proof. + simple induction m. trivial. + intros a y pf. simpl in |- *. unfold MapSweep2 in |- *. case (f (pf a) y); reflexivity. + intros. simpl in |- *. rewrite (H (fun a0:ad => pf (ad_double a0))). + rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))). + case (MapSweep1 A f (fun a0:ad => pf (ad_double a0)) m0); reflexivity. + Qed. + + Lemma MapFold_orb : + forall (f:ad -> A -> bool) (m:Map A), + MapFold A bool false orb f m = + match MapSweep A f m with + | SOME _ => true + | _ => false + end. + Proof. + intros. exact (MapFold_orb_1 f m (fun a:ad => a)). + Qed. + +End MapFoldExists. + +Section DMergeDef. + + Variable A : Set. + + Definition DMerge := + MapFold (Map A) (Map A) (M0 A) (MapMerge A) (fun (_:ad) (m:Map A) => m). + + Lemma in_dom_DMerge_1 : + forall (m:Map (Map A)) (a:ad), + in_dom A a (DMerge m) = + match MapSweep _ (fun (_:ad) (m0:Map A) => in_dom A a m0) m with + | SOME _ => true + | _ => false + end. + Proof. + unfold DMerge in |- *. intros. + rewrite + (MapFold_distr_l (Map A) (Map A) (M0 A) (MapMerge A) bool false orb ad + (in_dom A) (fun c:ad => refl_equal _) (in_dom_merge A)) + . + apply MapFold_orb. + Qed. + + Lemma in_dom_DMerge_2 : + forall (m:Map (Map A)) (a:ad), + in_dom A a (DMerge m) = true -> + {b : ad & + {m0 : Map A | MapGet _ m b = SOME _ m0 /\ in_dom A a m0 = true}}. + Proof. + intros m a. rewrite in_dom_DMerge_1. + elim + (option_sum _ + (MapSweep (Map A) (fun (_:ad) (m0:Map A) => in_dom A a m0) m)). + intro H. elim H. intro r. elim r. intros b m0 H0. intro. split with b. split with m0. + split. exact (MapSweep_semantics_2 _ _ _ _ _ H0). + exact (MapSweep_semantics_1 _ _ _ _ _ H0). + intro H. rewrite H. intro. discriminate H0. + Qed. + + Lemma in_dom_DMerge_3 : + forall (m:Map (Map A)) (a b:ad) (m0:Map A), + MapGet _ m a = SOME _ m0 -> + in_dom A b m0 = true -> in_dom A b (DMerge m) = true. + Proof. + intros m a b m0 H H0. rewrite in_dom_DMerge_1. + elim + (MapSweep_semantics_4 _ (fun (_:ad) (m'0:Map A) => in_dom A b m'0) _ _ _ + H H0). + intros a' H1. elim H1. intros m'0 H2. rewrite H2. reflexivity. + Qed. + +End DMergeDef.
\ No newline at end of file diff --git a/theories/IntMap/Mapiter.v b/theories/IntMap/Mapiter.v new file mode 100644 index 00000000..f5d443cc --- /dev/null +++ b/theories/IntMap/Mapiter.v @@ -0,0 +1,620 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapiter.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Mapaxioms. +Require Import Fset. +Require Import List. + +Section MapIter. + + Variable A : Set. + + Section MapSweepDef. + + Variable f : ad -> A -> bool. + + Definition MapSweep2 (a0:ad) (y:A) := + if f a0 y then SOME _ (a0, y) else NONE _. + + Fixpoint MapSweep1 (pf:ad -> ad) (m:Map A) {struct m} : + option (ad * A) := + match m with + | M0 => NONE _ + | M1 a y => MapSweep2 (pf a) y + | M2 m m' => + match MapSweep1 (fun a:ad => pf (ad_double a)) m with + | SOME r => SOME _ r + | NONE => MapSweep1 (fun a:ad => pf (ad_double_plus_un a)) m' + end + end. + + Definition MapSweep (m:Map A) := MapSweep1 (fun a:ad => a) m. + + Lemma MapSweep_semantics_1_1 : + forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), + MapSweep1 pf m = SOME _ (a, y) -> f a y = true. + Proof. + simple induction m. intros. discriminate H. + simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (f (pf a) y)). intro H. unfold MapSweep2 in |- *. + rewrite H. intro H0. inversion H0. rewrite <- H3. assumption. + intro H. unfold MapSweep2 in |- *. rewrite H. intro H0. discriminate H0. + simpl in |- *. intros. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). + intro H2. elim H2. intros r H3. rewrite H3 in H1. inversion H1. rewrite H5 in H3. + exact (H (fun a0:ad => pf (ad_double a0)) a y H3). + intro H2. rewrite H2 in H1. exact (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H1). + Qed. + + Lemma MapSweep_semantics_1 : + forall (m:Map A) (a:ad) (y:A), MapSweep m = SOME _ (a, y) -> f a y = true. + Proof. + intros. exact (MapSweep_semantics_1_1 m (fun a:ad => a) a y H). + Qed. + + Lemma MapSweep_semantics_2_1 : + forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), + MapSweep1 pf m = SOME _ (a, y) -> {a' : ad | a = pf a'}. + Proof. + simple induction m. intros. discriminate H. + simpl in |- *. unfold MapSweep2 in |- *. intros a y pf a0 y0. case (f (pf a) y). intros. split with a. + inversion H. reflexivity. + intro. discriminate H. + intros m0 H m1 H0 pf a y. simpl in |- *. + elim + (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H1. elim H1. + intros r H2. rewrite H2. intro H3. inversion H3. rewrite H5 in H2. + elim (H (fun a0:ad => pf (ad_double a0)) a y H2). intros a0 H6. split with (ad_double a0). + assumption. + intro H1. rewrite H1. intro H2. elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H2). + intros a0 H3. split with (ad_double_plus_un a0). assumption. + Qed. + + Lemma MapSweep_semantics_2_2 : + forall (m:Map A) (pf fp:ad -> ad), + (forall a0:ad, fp (pf a0) = a0) -> + forall (a:ad) (y:A), + MapSweep1 pf m = SOME _ (a, y) -> MapGet A m (fp a) = SOME _ y. + Proof. + simple induction m. intros. discriminate H0. + simpl in |- *. intros a y pf fp H a0 y0. unfold MapSweep2 in |- *. elim (sumbool_of_bool (f (pf a) y)). + intro H0. rewrite H0. intro H1. inversion H1. rewrite (H a). rewrite (ad_eq_correct a). + reflexivity. + intro H0. rewrite H0. intro H1. discriminate H1. + intros. rewrite (MapGet_M2_bit_0_if A m0 m1 (fp a)). elim (sumbool_of_bool (ad_bit_0 (fp a))). + intro H3. rewrite H3. elim (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). + intro H4. simpl in H2. apply + (H0 (fun a0:ad => pf (ad_double_plus_un a0)) + (fun a0:ad => ad_div_2 (fp a0))). + intro. rewrite H1. apply ad_double_plus_un_div_2. + elim + (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H5. elim H5. + intros r H6. rewrite H6 in H2. inversion H2. rewrite H8 in H6. + elim (MapSweep_semantics_2_1 m0 (fun a0:ad => pf (ad_double a0)) a y H6). intros a0 H9. + rewrite H9 in H3. rewrite (H1 (ad_double a0)) in H3. rewrite (ad_double_bit_0 a0) in H3. + discriminate H3. + intro H5. rewrite H5 in H2. assumption. + intro H4. simpl in H2. rewrite H4 in H2. + apply + (H0 (fun a0:ad => pf (ad_double_plus_un a0)) + (fun a0:ad => ad_div_2 (fp a0))). intro. + rewrite H1. apply ad_double_plus_un_div_2. + assumption. + intro H3. rewrite H3. simpl in H2. + elim + (option_sum (ad * A) (MapSweep1 (fun a0:ad => pf (ad_double a0)) m0)). intro H4. elim H4. + intros r H5. rewrite H5 in H2. inversion H2. rewrite H7 in H5. + apply + (H (fun a0:ad => pf (ad_double a0)) (fun a0:ad => ad_div_2 (fp a0))). intro. rewrite H1. + apply ad_double_div_2. + assumption. + intro H4. rewrite H4 in H2. + elim + (MapSweep_semantics_2_1 m1 (fun a0:ad => pf (ad_double_plus_un a0)) a y + H2). + intros a0 H5. rewrite H5 in H3. rewrite (H1 (ad_double_plus_un a0)) in H3. + rewrite (ad_double_plus_un_bit_0 a0) in H3. discriminate H3. + Qed. + + Lemma MapSweep_semantics_2 : + forall (m:Map A) (a:ad) (y:A), + MapSweep m = SOME _ (a, y) -> MapGet A m a = SOME _ y. + Proof. + intros. + exact + (MapSweep_semantics_2_2 m (fun a0:ad => a0) (fun a0:ad => a0) + (fun a0:ad => refl_equal a0) a y H). + Qed. + + Lemma MapSweep_semantics_3_1 : + forall (m:Map A) (pf:ad -> ad), + MapSweep1 pf m = NONE _ -> + forall (a:ad) (y:A), MapGet A m a = SOME _ y -> f (pf a) y = false. + Proof. + simple induction m. intros. discriminate H0. + simpl in |- *. unfold MapSweep2 in |- *. intros a y pf. elim (sumbool_of_bool (f (pf a) y)). intro H. + rewrite H. intro. discriminate H0. + intro H. rewrite H. intros H0 a0 y0. elim (sumbool_of_bool (ad_eq a a0)). intro H1. rewrite H1. + intro H2. inversion H2. rewrite <- H4. rewrite <- (ad_eq_complete _ _ H1). assumption. + intro H1. rewrite H1. intro. discriminate H2. + intros. simpl in H1. elim (option_sum (ad * A) (MapSweep1 (fun a:ad => pf (ad_double a)) m0)). + intro H3. elim H3. intros r H4. rewrite H4 in H1. discriminate H1. + intro H3. rewrite H3 in H1. elim (sumbool_of_bool (ad_bit_0 a)). intro H4. + rewrite (MapGet_M2_bit_0_1 A a H4 m0 m1) in H2. rewrite <- (ad_div_2_double_plus_un a H4). + exact (H0 (fun a:ad => pf (ad_double_plus_un a)) H1 (ad_div_2 a) y H2). + intro H4. rewrite (MapGet_M2_bit_0_0 A a H4 m0 m1) in H2. rewrite <- (ad_div_2_double a H4). + exact (H (fun a:ad => pf (ad_double a)) H3 (ad_div_2 a) y H2). + Qed. + + Lemma MapSweep_semantics_3 : + forall m:Map A, + MapSweep m = NONE _ -> + forall (a:ad) (y:A), MapGet A m a = SOME _ y -> f a y = false. + Proof. + intros. + exact (MapSweep_semantics_3_1 m (fun a0:ad => a0) H a y H0). + Qed. + + Lemma MapSweep_semantics_4_1 : + forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), + MapGet A m a = SOME A y -> + f (pf a) y = true -> + {a' : ad & {y' : A | MapSweep1 pf m = SOME _ (a', y')}}. + Proof. + simple induction m. intros. discriminate H. + intros. elim (sumbool_of_bool (ad_eq a a1)). intro H1. split with (pf a1). split with y. + rewrite (ad_eq_complete _ _ H1). unfold MapSweep1, MapSweep2 in |- *. + rewrite (ad_eq_complete _ _ H1) in H. rewrite (M1_semantics_1 _ a1 a0) in H. + inversion H. rewrite H0. reflexivity. + + intro H1. rewrite (M1_semantics_2 _ a a1 a0 H1) in H. discriminate H. + + intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H3. + rewrite (MapGet_M2_bit_0_1 _ _ H3 m0 m1) in H1. + rewrite <- (ad_div_2_double_plus_un a H3) in H2. + elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) (ad_div_2 a) y H1 H2). intros a'' H4. elim H4. + intros y'' H5. simpl in |- *. elim (option_sum _ (MapSweep1 (fun a:ad => pf (ad_double a)) m0)). + intro H6. elim H6. intro r. elim r. intros a''' y''' H7. rewrite H7. split with a'''. + split with y'''. reflexivity. + intro H6. rewrite H6. split with a''. split with y''. assumption. + intro H3. rewrite (MapGet_M2_bit_0_0 _ _ H3 m0 m1) in H1. + rewrite <- (ad_div_2_double a H3) in H2. + elim (H (fun a0:ad => pf (ad_double a0)) (ad_div_2 a) y H1 H2). intros a'' H4. elim H4. + intros y'' H5. split with a''. split with y''. simpl in |- *. rewrite H5. reflexivity. + Qed. + + Lemma MapSweep_semantics_4 : + forall (m:Map A) (a:ad) (y:A), + MapGet A m a = SOME A y -> + f a y = true -> {a' : ad & {y' : A | MapSweep m = SOME _ (a', y')}}. + Proof. + intros. exact (MapSweep_semantics_4_1 m (fun a0:ad => a0) a y H H0). + Qed. + + End MapSweepDef. + + Variable B : Set. + + Fixpoint MapCollect1 (f:ad -> A -> Map B) (pf:ad -> ad) + (m:Map A) {struct m} : Map B := + match m with + | M0 => M0 B + | M1 a y => f (pf a) y + | M2 m1 m2 => + MapMerge B (MapCollect1 f (fun a0:ad => pf (ad_double a0)) m1) + (MapCollect1 f (fun a0:ad => pf (ad_double_plus_un a0)) m2) + end. + + Definition MapCollect (f:ad -> A -> Map B) (m:Map A) := + MapCollect1 f (fun a:ad => a) m. + + Section MapFoldDef. + + Variable M : Set. + Variable neutral : M. + Variable op : M -> M -> M. + + Fixpoint MapFold1 (f:ad -> A -> M) (pf:ad -> ad) + (m:Map A) {struct m} : M := + match m with + | M0 => neutral + | M1 a y => f (pf a) y + | M2 m1 m2 => + op (MapFold1 f (fun a0:ad => pf (ad_double a0)) m1) + (MapFold1 f (fun a0:ad => pf (ad_double_plus_un a0)) m2) + end. + + Definition MapFold (f:ad -> A -> M) (m:Map A) := + MapFold1 f (fun a:ad => a) m. + + Lemma MapFold_empty : forall f:ad -> A -> M, MapFold f (M0 A) = neutral. + Proof. + trivial. + Qed. + + Lemma MapFold_M1 : + forall (f:ad -> A -> M) (a:ad) (y:A), MapFold f (M1 A a y) = f a y. + Proof. + trivial. + Qed. + + Variable State : Set. + Variable f : State -> ad -> A -> State * M. + + Fixpoint MapFold1_state (state:State) (pf:ad -> ad) + (m:Map A) {struct m} : State * M := + match m with + | M0 => (state, neutral) + | M1 a y => f state (pf a) y + | M2 m1 m2 => + match MapFold1_state state (fun a0:ad => pf (ad_double a0)) m1 with + | (state1, x1) => + match + MapFold1_state state1 + (fun a0:ad => pf (ad_double_plus_un a0)) m2 + with + | (state2, x2) => (state2, op x1 x2) + end + end + end. + + Definition MapFold_state (state:State) := + MapFold1_state state (fun a:ad => a). + + Lemma pair_sp : forall (B C:Set) (x:B * C), x = (fst x, snd x). + Proof. + simple induction x. trivial. + Qed. + + Lemma MapFold_state_stateless_1 : + forall (m:Map A) (g:ad -> A -> M) (pf:ad -> ad), + (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) -> + forall state:State, snd (MapFold1_state state pf m) = MapFold1 g pf m. + Proof. + simple induction m. trivial. + intros. simpl in |- *. apply H. + intros. simpl in |- *. rewrite + (pair_sp _ _ (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0)) + . + rewrite (H g (fun a0:ad => pf (ad_double a0)) H1 state). + rewrite + (pair_sp _ _ + (MapFold1_state + (fst (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0)) + (fun a0:ad => pf (ad_double_plus_un a0)) m1)) + . + simpl in |- *. + rewrite + (H0 g (fun a0:ad => pf (ad_double_plus_un a0)) H1 + (fst (MapFold1_state state (fun a0:ad => pf (ad_double a0)) m0))) + . + reflexivity. + Qed. + + Lemma MapFold_state_stateless : + forall g:ad -> A -> M, + (forall (state:State) (a:ad) (y:A), snd (f state a y) = g a y) -> + forall (state:State) (m:Map A), + snd (MapFold_state state m) = MapFold g m. + Proof. + intros. exact (MapFold_state_stateless_1 m g (fun a0:ad => a0) H state). + Qed. + + End MapFoldDef. + + Lemma MapCollect_as_Fold : + forall (f:ad -> A -> Map B) (m:Map A), + MapCollect f m = MapFold (Map B) (M0 B) (MapMerge B) f m. + Proof. + simple induction m; trivial. + Qed. + + Definition alist := list (ad * A). + Definition anil := nil (A:=(ad * A)). + Definition acons := cons (A:=(ad * A)). + Definition aapp := app (A:=(ad * A)). + + Definition alist_of_Map := + MapFold alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil). + + Fixpoint alist_semantics (l:alist) : ad -> option A := + match l with + | nil => fun _:ad => NONE A + | (a, y) :: l' => + fun a0:ad => if ad_eq a a0 then SOME A y else alist_semantics l' a0 + end. + + Lemma alist_semantics_app : + forall (l l':alist) (a:ad), + alist_semantics (aapp l l') a = + match alist_semantics l a with + | NONE => alist_semantics l' a + | SOME y => SOME A y + end. + Proof. + unfold aapp in |- *. simple induction l. trivial. + intros. elim a. intros a1 y1. simpl in |- *. case (ad_eq a1 a0). reflexivity. + apply H. + Qed. + + Lemma alist_of_Map_semantics_1_1 : + forall (m:Map A) (pf:ad -> ad) (a:ad) (y:A), + alist_semantics + (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) pf + m) a = SOME A y -> {a' : ad | a = pf a'}. + Proof. + simple induction m. simpl in |- *. intros. discriminate H. + simpl in |- *. intros a y pf a0 y0. elim (sumbool_of_bool (ad_eq (pf a) a0)). intro H. rewrite H. + intro H0. split with a. rewrite (ad_eq_complete _ _ H). reflexivity. + intro H. rewrite H. intro H0. discriminate H0. + intros. change + (alist_semantics + (aapp + (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) + (fun a0:ad => pf (ad_double a0)) m0) + (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) + (fun a0:ad => pf (ad_double_plus_un a0)) m1)) a = + SOME A y) in H1. + rewrite + (alist_semantics_app + (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil) + (fun a0:ad => pf (ad_double a0)) m0) + (MapFold1 alist anil aapp (fun (a0:ad) (y0:A) => acons (a0, y0) anil) + (fun a0:ad => pf (ad_double_plus_un a0)) m1) a) + in H1. + elim + (option_sum A + (alist_semantics + (MapFold1 alist anil aapp + (fun (a0:ad) (y0:A) => acons (a0, y0) anil) + (fun a0:ad => pf (ad_double a0)) m0) a)). + intro H2. elim H2. intros y0 H3. elim (H (fun a0:ad => pf (ad_double a0)) a y0 H3). intros a0 H4. + split with (ad_double a0). assumption. + intro H2. rewrite H2 in H1. elim (H0 (fun a0:ad => pf (ad_double_plus_un a0)) a y H1). + intros a0 H3. split with (ad_double_plus_un a0). assumption. + Qed. + + Definition ad_inj (pf:ad -> ad) := + forall a0 a1:ad, pf a0 = pf a1 -> a0 = a1. + + Lemma ad_comp_double_inj : + forall pf:ad -> ad, ad_inj pf -> ad_inj (fun a0:ad => pf (ad_double a0)). + Proof. + unfold ad_inj in |- *. intros. apply ad_double_inj. exact (H _ _ H0). + Qed. + + Lemma ad_comp_double_plus_un_inj : + forall pf:ad -> ad, + ad_inj pf -> ad_inj (fun a0:ad => pf (ad_double_plus_un a0)). + Proof. + unfold ad_inj in |- *. intros. apply ad_double_plus_un_inj. exact (H _ _ H0). + Qed. + + Lemma alist_of_Map_semantics_1 : + forall (m:Map A) (pf:ad -> ad), + ad_inj pf -> + forall a:ad, + MapGet A m a = + alist_semantics + (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) + pf m) (pf a). + Proof. + simple induction m. trivial. + simpl in |- *. intros. elim (sumbool_of_bool (ad_eq a a1)). intro H0. rewrite H0. + rewrite (ad_eq_complete _ _ H0). rewrite (ad_eq_correct (pf a1)). reflexivity. + intro H0. rewrite H0. elim (sumbool_of_bool (ad_eq (pf a) (pf a1))). intro H1. + rewrite (H a a1 (ad_eq_complete _ _ H1)) in H0. rewrite (ad_eq_correct a1) in H0. + discriminate H0. + intro H1. rewrite H1. reflexivity. + intros. change + (MapGet A (M2 A m0 m1) a = + alist_semantics + (aapp + (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) + (fun a0:ad => pf (ad_double a0)) m0) + (MapFold1 alist anil aapp (fun (a0:ad) (y:A) => acons (a0, y) anil) + (fun a0:ad => pf (ad_double_plus_un a0)) m1)) ( + pf a)) in |- *. + rewrite alist_semantics_app. rewrite (MapGet_M2_bit_0_if A m0 m1 a). + elim (ad_double_or_double_plus_un a). intro H2. elim H2. intros a0 H3. rewrite H3. + rewrite (ad_double_bit_0 a0). + rewrite <- + (H (fun a1:ad => pf (ad_double a1)) (ad_comp_double_inj pf H1) a0) + . + rewrite ad_double_div_2. case (MapGet A m0 a0). + elim + (option_sum A + (alist_semantics + (MapFold1 alist anil aapp + (fun (a1:ad) (y:A) => acons (a1, y) anil) + (fun a1:ad => pf (ad_double_plus_un a1)) m1) + (pf (ad_double a0)))). + intro H4. elim H4. intros y H5. + elim + (alist_of_Map_semantics_1_1 m1 (fun a1:ad => pf (ad_double_plus_un a1)) + (pf (ad_double a0)) y H5). + intros a1 H6. cut (ad_bit_0 (ad_double a0) = ad_bit_0 (ad_double_plus_un a1)). + intro. rewrite (ad_double_bit_0 a0) in H7. rewrite (ad_double_plus_un_bit_0 a1) in H7. + discriminate H7. + rewrite (H1 (ad_double a0) (ad_double_plus_un a1) H6). reflexivity. + intro H4. rewrite H4. reflexivity. + trivial. + intro H2. elim H2. intros a0 H3. rewrite H3. rewrite (ad_double_plus_un_bit_0 a0). + rewrite <- + (H0 (fun a1:ad => pf (ad_double_plus_un a1)) + (ad_comp_double_plus_un_inj pf H1) a0). + rewrite ad_double_plus_un_div_2. + elim + (option_sum A + (alist_semantics + (MapFold1 alist anil aapp + (fun (a1:ad) (y:A) => acons (a1, y) anil) + (fun a1:ad => pf (ad_double a1)) m0) + (pf (ad_double_plus_un a0)))). + intro H4. elim H4. intros y H5. + elim + (alist_of_Map_semantics_1_1 m0 (fun a1:ad => pf (ad_double a1)) + (pf (ad_double_plus_un a0)) y H5). + intros a1 H6. cut (ad_bit_0 (ad_double_plus_un a0) = ad_bit_0 (ad_double a1)). + intro H7. rewrite (ad_double_plus_un_bit_0 a0) in H7. rewrite (ad_double_bit_0 a1) in H7. + discriminate H7. + rewrite (H1 (ad_double_plus_un a0) (ad_double a1) H6). reflexivity. + intro H4. rewrite H4. reflexivity. + Qed. + + Lemma alist_of_Map_semantics : + forall m:Map A, eqm A (MapGet A m) (alist_semantics (alist_of_Map m)). + Proof. + unfold eqm in |- *. intros. exact + (alist_of_Map_semantics_1 m (fun a0:ad => a0) + (fun (a0 a1:ad) (p:a0 = a1) => p) a). + Qed. + + Fixpoint Map_of_alist (l:alist) : Map A := + match l with + | nil => M0 A + | (a, y) :: l' => MapPut A (Map_of_alist l') a y + end. + + Lemma Map_of_alist_semantics : + forall l:alist, eqm A (alist_semantics l) (MapGet A (Map_of_alist l)). + Proof. + unfold eqm in |- *. simple induction l. trivial. + intros r l0 H a. elim r. intros a0 y0. simpl in |- *. elim (sumbool_of_bool (ad_eq a0 a)). + intro H0. rewrite H0. rewrite (ad_eq_complete _ _ H0). + rewrite (MapPut_semantics A (Map_of_alist l0) a y0 a). rewrite (ad_eq_correct a). + reflexivity. + intro H0. rewrite H0. rewrite (MapPut_semantics A (Map_of_alist l0) a0 y0 a). + rewrite H0. apply H. + Qed. + + Lemma Map_of_alist_of_Map : + forall m:Map A, eqmap A (Map_of_alist (alist_of_Map m)) m. + Proof. + unfold eqmap in |- *. intro. apply eqm_trans with (f' := alist_semantics (alist_of_Map m)). + apply eqm_sym. apply Map_of_alist_semantics. + apply eqm_sym. apply alist_of_Map_semantics. + Qed. + + Lemma alist_of_Map_of_alist : + forall l:alist, + eqm A (alist_semantics (alist_of_Map (Map_of_alist l))) + (alist_semantics l). + Proof. + intro. apply eqm_trans with (f' := MapGet A (Map_of_alist l)). + apply eqm_sym. apply alist_of_Map_semantics. + apply eqm_sym. apply Map_of_alist_semantics. + Qed. + + Lemma fold_right_aapp : + forall (M:Set) (neutral:M) (op:M -> M -> M), + (forall a b c:M, op (op a b) c = op a (op b c)) -> + (forall a:M, op neutral a = a) -> + forall (f:ad -> A -> M) (l l':alist), + fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) + neutral (aapp l l') = + op + (fold_right + (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral + l) + (fold_right + (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) neutral + l'). + Proof. + simple induction l. simpl in |- *. intro. rewrite H0. reflexivity. + intros r l0 H1 l'. elim r. intros a y. simpl in |- *. rewrite H. rewrite (H1 l'). reflexivity. + Qed. + + Lemma MapFold_as_fold_1 : + forall (M:Set) (neutral:M) (op:M -> M -> M), + (forall a b c:M, op (op a b) c = op a (op b c)) -> + (forall a:M, op neutral a = a) -> + (forall a:M, op a neutral = a) -> + forall (f:ad -> A -> M) (m:Map A) (pf:ad -> ad), + MapFold1 M neutral op f pf m = + fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) + neutral + (MapFold1 alist anil aapp (fun (a:ad) (y:A) => acons (a, y) anil) pf + m). + Proof. + simple induction m. trivial. + intros. simpl in |- *. rewrite H1. reflexivity. + intros. simpl in |- *. rewrite (fold_right_aapp M neutral op H H0 f). + rewrite (H2 (fun a0:ad => pf (ad_double a0))). rewrite (H3 (fun a0:ad => pf (ad_double_plus_un a0))). + reflexivity. + Qed. + + Lemma MapFold_as_fold : + forall (M:Set) (neutral:M) (op:M -> M -> M), + (forall a b c:M, op (op a b) c = op a (op b c)) -> + (forall a:M, op neutral a = a) -> + (forall a:M, op a neutral = a) -> + forall (f:ad -> A -> M) (m:Map A), + MapFold M neutral op f m = + fold_right (fun (r:ad * A) (m:M) => let (a, y) := r in op (f a y) m) + neutral (alist_of_Map m). + Proof. + intros. exact (MapFold_as_fold_1 M neutral op H H0 H1 f m (fun a0:ad => a0)). + Qed. + + Lemma alist_MapMerge_semantics : + forall m m':Map A, + eqm A (alist_semantics (aapp (alist_of_Map m') (alist_of_Map m))) + (alist_semantics (alist_of_Map (MapMerge A m m'))). + Proof. + unfold eqm in |- *. intros. rewrite alist_semantics_app. rewrite <- (alist_of_Map_semantics m a). + rewrite <- (alist_of_Map_semantics m' a). + rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). + rewrite (MapMerge_semantics A m m' a). reflexivity. + Qed. + + Lemma alist_MapMerge_semantics_disjoint : + forall m m':Map A, + eqmap A (MapDomRestrTo A A m m') (M0 A) -> + eqm A (alist_semantics (aapp (alist_of_Map m) (alist_of_Map m'))) + (alist_semantics (alist_of_Map (MapMerge A m m'))). + Proof. + unfold eqm in |- *. intros. rewrite alist_semantics_app. rewrite <- (alist_of_Map_semantics m a). + rewrite <- (alist_of_Map_semantics m' a). + rewrite <- (alist_of_Map_semantics (MapMerge A m m') a). rewrite (MapMerge_semantics A m m' a). + elim (option_sum _ (MapGet A m a)). intro H0. elim H0. intros y H1. rewrite H1. + elim (option_sum _ (MapGet A m' a)). intro H2. elim H2. intros y' H3. + cut (MapGet A (MapDomRestrTo A A m m') a = NONE A). + rewrite (MapDomRestrTo_semantics A A m m' a). rewrite H3. rewrite H1. intro. discriminate H4. + exact (H a). + intro H2. rewrite H2. reflexivity. + intro H0. rewrite H0. case (MapGet A m' a); trivial. + Qed. + + Lemma alist_semantics_disjoint_comm : + forall l l':alist, + eqmap A (MapDomRestrTo A A (Map_of_alist l) (Map_of_alist l')) (M0 A) -> + eqm A (alist_semantics (aapp l l')) (alist_semantics (aapp l' l)). + Proof. + unfold eqm in |- *. intros. rewrite (alist_semantics_app l l' a). rewrite (alist_semantics_app l' l a). + rewrite <- (alist_of_Map_of_alist l a). rewrite <- (alist_of_Map_of_alist l' a). + rewrite <- + (alist_semantics_app (alist_of_Map (Map_of_alist l)) + (alist_of_Map (Map_of_alist l')) a). + rewrite <- + (alist_semantics_app (alist_of_Map (Map_of_alist l')) + (alist_of_Map (Map_of_alist l)) a). + rewrite (alist_MapMerge_semantics (Map_of_alist l) (Map_of_alist l') a). + rewrite + (alist_MapMerge_semantics_disjoint (Map_of_alist l) ( + Map_of_alist l') H a). + reflexivity. + Qed. + +End MapIter. diff --git a/theories/IntMap/Maplists.v b/theories/IntMap/Maplists.v new file mode 100644 index 00000000..645c3407 --- /dev/null +++ b/theories/IntMap/Maplists.v @@ -0,0 +1,437 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Maplists.v,v 1.4.2.1 2004/07/16 19:31:04 herbelin Exp $ i*) + +Require Import Addr. +Require Import Addec. +Require Import Map. +Require Import Fset. +Require Import Mapaxioms. +Require Import Mapsubset. +Require Import Mapcard. +Require Import Mapcanon. +Require Import Mapc. +Require Import Bool. +Require Import Sumbool. +Require Import List. +Require Import Arith. +Require Import Mapiter. +Require Import Mapfold. + +Section MapLists. + + Fixpoint ad_in_list (a:ad) (l:list ad) {struct l} : bool := + match l with + | nil => false + | a' :: l' => orb (ad_eq a a') (ad_in_list a l') + end. + + Fixpoint ad_list_stutters (l:list ad) : bool := + match l with + | nil => false + | a :: l' => orb (ad_in_list a l') (ad_list_stutters l') + end. + + Lemma ad_in_list_forms_circuit : + forall (x:ad) (l:list ad), + ad_in_list x l = true -> + {l1 : list ad & {l2 : list ad | l = l1 ++ x :: l2}}. + Proof. + simple induction l. intro. discriminate H. + intros. elim (sumbool_of_bool (ad_eq x a)). intro H1. simpl in H0. split with (nil (A:=ad)). + split with l0. rewrite (ad_eq_complete _ _ H1). reflexivity. + intro H2. simpl in H0. rewrite H2 in H0. simpl in H0. elim (H H0). intros l'1 H3. + split with (a :: l'1). elim H3. intros l2 H4. split with l2. rewrite H4. reflexivity. + Qed. + + Lemma ad_list_stutters_has_circuit : + forall l:list ad, + ad_list_stutters l = true -> + {x : ad & + {l0 : list ad & + {l1 : list ad & {l2 : list ad | l = l0 ++ x :: l1 ++ x :: l2}}}}. + Proof. + simple induction l. intro. discriminate H. + intros. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. split with a. + split with (nil (A:=ad)). simpl in |- *. elim (ad_in_list_forms_circuit a l0 H1). intros l1 H2. + split with l1. elim H2. intros l2 H3. split with l2. rewrite H3. reflexivity. + intro H1. elim (H H1). intros x H2. split with x. elim H2. intros l1 H3. + split with (a :: l1). elim H3. intros l2 H4. split with l2. elim H4. intros l3 H5. + split with l3. rewrite H5. reflexivity. + Qed. + + Fixpoint Elems (l:list ad) : FSet := + match l with + | nil => M0 unit + | a :: l' => MapPut _ (Elems l') a tt + end. + + Lemma Elems_canon : forall l:list ad, mapcanon _ (Elems l). + Proof. + simple induction l. exact (M0_canon unit). + intros. simpl in |- *. apply MapPut_canon. assumption. + Qed. + + Lemma Elems_app : + forall l l':list ad, Elems (l ++ l') = FSetUnion (Elems l) (Elems l'). + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)). + rewrite (MapPut_as_Merge_c unit (Elems (l0 ++ l'))). + change + (FSetUnion (Elems (l0 ++ l')) (M1 unit a tt) = + FSetUnion (FSetUnion (Elems l0) (M1 unit a tt)) (Elems l')) + in |- *. + rewrite FSetUnion_comm_c. rewrite (FSetUnion_comm_c (Elems l0) (M1 unit a tt)). + rewrite FSetUnion_assoc_c. rewrite (H l'). reflexivity. + apply M1_canon. + apply Elems_canon. + apply Elems_canon. + apply Elems_canon. + apply M1_canon. + apply Elems_canon. + apply M1_canon. + apply Elems_canon. + apply Elems_canon. + Qed. + + Lemma Elems_rev : forall l:list ad, Elems (rev l) = Elems l. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite Elems_app. simpl in |- *. rewrite (MapPut_as_Merge_c unit (Elems l0)). + rewrite H. reflexivity. + apply Elems_canon. + Qed. + + Lemma ad_in_elems_in_list : + forall (l:list ad) (a:ad), in_FSet a (Elems l) = ad_in_list a l. + Proof. + simple induction l. trivial. + simpl in |- *. unfold in_FSet in |- *. intros. rewrite (in_dom_put _ (Elems l0) a tt a0). + rewrite (H a0). reflexivity. + Qed. + + Lemma ad_list_not_stutters_card : + forall l:list ad, + ad_list_stutters l = false -> length l = MapCard _ (Elems l). + Proof. + simple induction l. trivial. + simpl in |- *. intros. rewrite MapCard_Put_2_conv. rewrite H. reflexivity. + elim (orb_false_elim _ _ H0). trivial. + elim (sumbool_of_bool (in_FSet a (Elems l0))). rewrite ad_in_elems_in_list. + intro H1. rewrite H1 in H0. discriminate H0. + exact (in_dom_none unit (Elems l0) a). + Qed. + + Lemma ad_list_card : forall l:list ad, MapCard _ (Elems l) <= length l. + Proof. + simple induction l. trivial. + intros. simpl in |- *. apply le_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub. + apply le_n_S. assumption. + Qed. + + Lemma ad_list_stutters_card : + forall l:list ad, + ad_list_stutters l = true -> MapCard _ (Elems l) < length l. + Proof. + simple induction l. intro. discriminate H. + intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. + rewrite <- (ad_in_elems_in_list l0 a) in H1. elim (in_dom_some _ _ _ H1). intros y H2. + rewrite (MapCard_Put_1_conv _ _ _ _ tt H2). apply le_lt_trans with (m := length l0). + apply ad_list_card. + apply lt_n_Sn. + intro H1. apply le_lt_trans with (m := S (MapCard _ (Elems l0))). apply MapCard_Put_ub. + apply lt_n_S. apply H. assumption. + Qed. + + Lemma ad_list_not_stutters_card_conv : + forall l:list ad, + length l = MapCard _ (Elems l) -> ad_list_stutters l = false. + Proof. + intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H0. + cut (MapCard _ (Elems l) < length l). intro. rewrite H in H1. elim (lt_irrefl _ H1). + exact (ad_list_stutters_card _ H0). + trivial. + Qed. + + Lemma ad_list_stutters_card_conv : + forall l:list ad, + MapCard _ (Elems l) < length l -> ad_list_stutters l = true. + Proof. + intros. elim (sumbool_of_bool (ad_list_stutters l)). trivial. + intro H0. rewrite (ad_list_not_stutters_card _ H0) in H. elim (lt_irrefl _ H). + Qed. + + Lemma ad_in_list_l : + forall (l l':list ad) (a:ad), + ad_in_list a l = true -> ad_in_list a (l ++ l') = true. + Proof. + simple induction l. intros. discriminate H. + intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity. + intro H1. rewrite (H l' a0 H1). apply orb_b_true. + Qed. + + Lemma ad_list_stutters_app_l : + forall l l':list ad, + ad_list_stutters l = true -> ad_list_stutters (l ++ l') = true. + Proof. + simple induction l. intros. discriminate H. + intros. simpl in |- *. simpl in H0. elim (orb_true_elim _ _ H0). intro H1. + rewrite (ad_in_list_l l0 l' a H1). reflexivity. + intro H1. rewrite (H l' H1). apply orb_b_true. + Qed. + + Lemma ad_in_list_r : + forall (l l':list ad) (a:ad), + ad_in_list a l' = true -> ad_in_list a (l ++ l') = true. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite (H l' a0 H0). apply orb_b_true. + Qed. + + Lemma ad_list_stutters_app_r : + forall l l':list ad, + ad_list_stutters l' = true -> ad_list_stutters (l ++ l') = true. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite (H l' H0). apply orb_b_true. + Qed. + + Lemma ad_list_stutters_app_conv_l : + forall l l':list ad, + ad_list_stutters (l ++ l') = false -> ad_list_stutters l = false. + Proof. + intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H0. + rewrite (ad_list_stutters_app_l l l' H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_list_stutters_app_conv_r : + forall l l':list ad, + ad_list_stutters (l ++ l') = false -> ad_list_stutters l' = false. + Proof. + intros. elim (sumbool_of_bool (ad_list_stutters l')). intro H0. + rewrite (ad_list_stutters_app_r l l' H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_in_list_app_1 : + forall (l l':list ad) (x:ad), ad_in_list x (l ++ x :: l') = true. + Proof. + simple induction l. simpl in |- *. intros. rewrite (ad_eq_correct x). reflexivity. + intros. simpl in |- *. rewrite (H l' x). apply orb_b_true. + Qed. + + Lemma ad_in_list_app : + forall (l l':list ad) (x:ad), + ad_in_list x (l ++ l') = orb (ad_in_list x l) (ad_in_list x l'). + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite <- orb_assoc. rewrite (H l' x). reflexivity. + Qed. + + Lemma ad_in_list_rev : + forall (l:list ad) (x:ad), ad_in_list x (rev l) = ad_in_list x l. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite ad_in_list_app. rewrite (H x). simpl in |- *. rewrite orb_b_false. + apply orb_comm. + Qed. + + Lemma ad_list_has_circuit_stutters : + forall (l0 l1 l2:list ad) (x:ad), + ad_list_stutters (l0 ++ x :: l1 ++ x :: l2) = true. + Proof. + simple induction l0. simpl in |- *. intros. rewrite (ad_in_list_app_1 l1 l2 x). reflexivity. + intros. simpl in |- *. rewrite (H l1 l2 x). apply orb_b_true. + Qed. + + Lemma ad_list_stutters_prev_l : + forall (l l':list ad) (x:ad), + ad_in_list x l = true -> ad_list_stutters (l ++ x :: l') = true. + Proof. + intros. elim (ad_in_list_forms_circuit _ _ H). intros l0 H0. elim H0. intros l1 H1. + rewrite H1. rewrite app_ass. simpl in |- *. apply ad_list_has_circuit_stutters. + Qed. + + Lemma ad_list_stutters_prev_conv_l : + forall (l l':list ad) (x:ad), + ad_list_stutters (l ++ x :: l') = false -> ad_in_list x l = false. + Proof. + intros. elim (sumbool_of_bool (ad_in_list x l)). intro H0. + rewrite (ad_list_stutters_prev_l l l' x H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_list_stutters_prev_r : + forall (l l':list ad) (x:ad), + ad_in_list x l' = true -> ad_list_stutters (l ++ x :: l') = true. + Proof. + intros. elim (ad_in_list_forms_circuit _ _ H). intros l0 H0. elim H0. intros l1 H1. + rewrite H1. apply ad_list_has_circuit_stutters. + Qed. + + Lemma ad_list_stutters_prev_conv_r : + forall (l l':list ad) (x:ad), + ad_list_stutters (l ++ x :: l') = false -> ad_in_list x l' = false. + Proof. + intros. elim (sumbool_of_bool (ad_in_list x l')). intro H0. + rewrite (ad_list_stutters_prev_r l l' x H0) in H. discriminate H. + trivial. + Qed. + + Lemma ad_list_Elems : + forall l l':list ad, + MapCard _ (Elems l) = MapCard _ (Elems l') -> + length l = length l' -> ad_list_stutters l = ad_list_stutters l'. + Proof. + intros. elim (sumbool_of_bool (ad_list_stutters l)). intro H1. rewrite H1. apply sym_eq. + apply ad_list_stutters_card_conv. rewrite <- H. rewrite <- H0. apply ad_list_stutters_card. + assumption. + intro H1. rewrite H1. apply sym_eq. apply ad_list_not_stutters_card_conv. rewrite <- H. + rewrite <- H0. apply ad_list_not_stutters_card. assumption. + Qed. + + Lemma ad_list_app_length : + forall l l':list ad, length (l ++ l') = length l + length l'. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite (H l'). reflexivity. + Qed. + + Lemma ad_list_stutters_permute : + forall l l':list ad, + ad_list_stutters (l ++ l') = ad_list_stutters (l' ++ l). + Proof. + intros. apply ad_list_Elems. rewrite Elems_app. rewrite Elems_app. + rewrite (FSetUnion_comm_c _ _ (Elems_canon l) (Elems_canon l')). reflexivity. + rewrite ad_list_app_length. rewrite ad_list_app_length. apply plus_comm. + Qed. + + Lemma ad_list_rev_length : forall l:list ad, length (rev l) = length l. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite ad_list_app_length. simpl in |- *. rewrite H. rewrite <- plus_Snm_nSm. + rewrite <- plus_n_O. reflexivity. + Qed. + + Lemma ad_list_stutters_rev : + forall l:list ad, ad_list_stutters (rev l) = ad_list_stutters l. + Proof. + intros. apply ad_list_Elems. rewrite Elems_rev. reflexivity. + apply ad_list_rev_length. + Qed. + + Lemma ad_list_app_rev : + forall (l l':list ad) (x:ad), rev l ++ x :: l' = rev (x :: l) ++ l'. + Proof. + simple induction l. trivial. + intros. simpl in |- *. rewrite (app_ass (rev l0) (a :: nil) (x :: l')). simpl in |- *. + rewrite (H (x :: l') a). simpl in |- *. + rewrite (app_ass (rev l0) (a :: nil) (x :: nil)). simpl in |- *. + rewrite app_ass. simpl in |- *. rewrite app_ass. reflexivity. + Qed. + + Section ListOfDomDef. + + Variable A : Set. + + Definition ad_list_of_dom := + MapFold A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil). + + Lemma ad_in_list_of_dom_in_dom : + forall (m:Map A) (a:ad), ad_in_list a (ad_list_of_dom m) = in_dom A a m. + Proof. + unfold ad_list_of_dom in |- *. intros. + rewrite + (MapFold_distr_l A (list ad) nil (app (A:=ad)) bool false orb ad + (fun (a:ad) (l:list ad) => ad_in_list a l) ( + fun c:ad => refl_equal _) ad_in_list_app + (fun (a0:ad) (_:A) => a0 :: nil) m a). + simpl in |- *. rewrite (MapFold_orb A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m). + elim + (option_sum _ + (MapSweep A (fun (a0:ad) (_:A) => orb (ad_eq a a0) false) m)). intro H. elim H. + intro r. elim r. intros a0 y H0. rewrite H0. unfold in_dom in |- *. + elim (orb_prop _ _ (MapSweep_semantics_1 _ _ _ _ _ H0)). intro H1. + rewrite (ad_eq_complete _ _ H1). rewrite (MapSweep_semantics_2 A _ _ _ _ H0). reflexivity. + intro H1. discriminate H1. + intro H. rewrite H. elim (sumbool_of_bool (in_dom A a m)). intro H0. + elim (in_dom_some A m a H0). intros y H1. + elim (orb_false_elim _ _ (MapSweep_semantics_3 _ _ _ H _ _ H1)). intro H2. + rewrite (ad_eq_correct a) in H2. discriminate H2. + exact (sym_eq (y:=_)). + Qed. + + Lemma Elems_of_list_of_dom : + forall m:Map A, eqmap unit (Elems (ad_list_of_dom m)) (MapDom A m). + Proof. + unfold eqmap, eqm in |- *. intros. elim (sumbool_of_bool (in_FSet a (Elems (ad_list_of_dom m)))). + intro H. elim (in_dom_some _ _ _ H). intro t. elim t. intro H0. + rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H. + rewrite (ad_in_list_of_dom_in_dom m a) in H. rewrite (MapDom_Dom A m a) in H. + elim (in_dom_some _ _ _ H). intro t'. elim t'. intro H1. rewrite H1. assumption. + intro H. rewrite (in_dom_none _ _ _ H). + rewrite (ad_in_elems_in_list (ad_list_of_dom m) a) in H. + rewrite (ad_in_list_of_dom_in_dom m a) in H. rewrite (MapDom_Dom A m a) in H. + rewrite (in_dom_none _ _ _ H). reflexivity. + Qed. + + Lemma Elems_of_list_of_dom_c : + forall m:Map A, mapcanon A m -> Elems (ad_list_of_dom m) = MapDom A m. + Proof. + intros. apply (mapcanon_unique unit). apply Elems_canon. + apply MapDom_canon. assumption. + apply Elems_of_list_of_dom. + Qed. + + Lemma ad_list_of_dom_card_1 : + forall (m:Map A) (pf:ad -> ad), + length + (MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil) + pf m) = MapCard A m. + Proof. + simple induction m; try trivial. simpl in |- *. intros. rewrite ad_list_app_length. + rewrite (H (fun a0:ad => pf (ad_double a0))). rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))). + reflexivity. + Qed. + + Lemma ad_list_of_dom_card : + forall m:Map A, length (ad_list_of_dom m) = MapCard A m. + Proof. + exact (fun m:Map A => ad_list_of_dom_card_1 m (fun a:ad => a)). + Qed. + + Lemma ad_list_of_dom_not_stutters : + forall m:Map A, ad_list_stutters (ad_list_of_dom m) = false. + Proof. + intro. apply ad_list_not_stutters_card_conv. rewrite ad_list_of_dom_card. apply sym_eq. + rewrite (MapCard_Dom A m). apply MapCard_ext. exact (Elems_of_list_of_dom m). + Qed. + + End ListOfDomDef. + + Lemma ad_list_of_dom_Dom_1 : + forall (A:Set) (m:Map A) (pf:ad -> ad), + MapFold1 A (list ad) nil (app (A:=ad)) (fun (a:ad) (_:A) => a :: nil) pf + m = + MapFold1 unit (list ad) nil (app (A:=ad)) + (fun (a:ad) (_:unit) => a :: nil) pf (MapDom A m). + Proof. + simple induction m; try trivial. simpl in |- *. intros. rewrite (H (fun a0:ad => pf (ad_double a0))). + rewrite (H0 (fun a0:ad => pf (ad_double_plus_un a0))). reflexivity. + Qed. + + Lemma ad_list_of_dom_Dom : + forall (A:Set) (m:Map A), + ad_list_of_dom A m = ad_list_of_dom unit (MapDom A m). + Proof. + intros. exact (ad_list_of_dom_Dom_1 A m (fun a0:ad => a0)). + Qed. + +End MapLists.
\ No newline at end of file diff --git a/theories/IntMap/Mapsubset.v b/theories/IntMap/Mapsubset.v new file mode 100644 index 00000000..33b412e3 --- /dev/null +++ b/theories/IntMap/Mapsubset.v @@ -0,0 +1,606 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) +(*i $Id: Mapsubset.v,v 1.4.2.1 2004/07/16 19:31:05 herbelin Exp $ i*) + +Require Import Bool. +Require Import Sumbool. +Require Import Arith. +Require Import ZArith. +Require Import Addr. +Require Import Adist. +Require Import Addec. +Require Import Map. +Require Import Fset. +Require Import Mapaxioms. +Require Import Mapiter. + +Section MapSubsetDef. + + Variables A B : Set. + + Definition MapSubset (m:Map A) (m':Map B) := + forall a:ad, in_dom A a m = true -> in_dom B a m' = true. + + Definition MapSubset_1 (m:Map A) (m':Map B) := + match MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m with + | NONE => true + | _ => false + end. + + Definition MapSubset_2 (m:Map A) (m':Map B) := + eqmap A (MapDomRestrBy A B m m') (M0 A). + + Lemma MapSubset_imp_1 : + forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_1 m m' = true. + Proof. + unfold MapSubset, MapSubset_1 in |- *. intros. + elim + (option_sum _ (MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m)). + intro H0. elim H0. intro r. elim r. intros a y H1. cut (negb (in_dom B a m') = true). + intro. cut (in_dom A a m = false). intro. unfold in_dom in H3. + rewrite (MapSweep_semantics_2 _ _ m a y H1) in H3. discriminate H3. + elim (sumbool_of_bool (in_dom A a m)). intro H3. rewrite (H a H3) in H2. discriminate H2. + trivial. + exact (MapSweep_semantics_1 _ _ m a y H1). + intro H0. rewrite H0. reflexivity. + Qed. + + Lemma MapSubset_1_imp : + forall (m:Map A) (m':Map B), MapSubset_1 m m' = true -> MapSubset m m'. + Proof. + unfold MapSubset, MapSubset_1 in |- *. unfold in_dom at 2 in |- *. intros. elim (option_sum _ (MapGet A m a)). + intro H1. elim H1. intros y H2. + elim + (option_sum _ (MapSweep A (fun (a:ad) (_:A) => negb (in_dom B a m')) m)). intro H3. + elim H3. intro r. elim r. intros a' y' H4. rewrite H4 in H. discriminate H. + intro H3. cut (negb (in_dom B a m') = false). intro. rewrite (negb_intro (in_dom B a m')). + rewrite H4. reflexivity. + exact (MapSweep_semantics_3 _ _ m H3 a y H2). + intro H1. rewrite H1 in H0. discriminate H0. + Qed. + + Lemma map_dom_empty_1 : + forall m:Map A, eqmap A m (M0 A) -> forall a:ad, in_dom _ a m = false. + Proof. + unfold eqmap, eqm, in_dom in |- *. intros. rewrite (H a). reflexivity. + Qed. + + Lemma map_dom_empty_2 : + forall m:Map A, (forall a:ad, in_dom _ a m = false) -> eqmap A m (M0 A). + Proof. + unfold eqmap, eqm, in_dom in |- *. intros. + cut + (match MapGet A m a with + | NONE => false + | SOME _ => true + end = false). + case (MapGet A m a). trivial. + intros. discriminate H0. + exact (H a). + Qed. + + Lemma MapSubset_imp_2 : + forall (m:Map A) (m':Map B), MapSubset m m' -> MapSubset_2 m m'. + Proof. + unfold MapSubset, MapSubset_2 in |- *. intros. apply map_dom_empty_2. intro. rewrite in_dom_restrby. + elim (sumbool_of_bool (in_dom A a m)). intro H0. rewrite H0. rewrite (H a H0). reflexivity. + intro H0. rewrite H0. reflexivity. + Qed. + + Lemma MapSubset_2_imp : + forall (m:Map A) (m':Map B), MapSubset_2 m m' -> MapSubset m m'. + Proof. + unfold MapSubset, MapSubset_2 in |- *. intros. cut (in_dom _ a (MapDomRestrBy A B m m') = false). + rewrite in_dom_restrby. intro. elim (andb_false_elim _ _ H1). rewrite H0. + intro H2. discriminate H2. + intro H2. rewrite (negb_intro (in_dom B a m')). rewrite H2. reflexivity. + exact (map_dom_empty_1 _ H a). + Qed. + +End MapSubsetDef. + +Section MapSubsetOrder. + + Variables A B C : Set. + + Lemma MapSubset_refl : forall m:Map A, MapSubset A A m m. + Proof. + unfold MapSubset in |- *. trivial. + Qed. + + Lemma MapSubset_antisym : + forall (m:Map A) (m':Map B), + MapSubset A B m m' -> + MapSubset B A m' m -> eqmap unit (MapDom A m) (MapDom B m'). + Proof. + unfold MapSubset, eqmap, eqm in |- *. intros. elim (option_sum _ (MapGet _ (MapDom A m) a)). + intro H1. elim H1. intro t. elim t. intro H2. elim (option_sum _ (MapGet _ (MapDom B m') a)). + intro H3. elim H3. intro t'. elim t'. intro H4. rewrite H4. exact H2. + intro H3. cut (in_dom B a m' = true). intro. rewrite (MapDom_Dom B m' a) in H4. + unfold in_FSet, in_dom in H4. rewrite H3 in H4. discriminate H4. + apply H. rewrite (MapDom_Dom A m a). unfold in_FSet, in_dom in |- *. rewrite H2. reflexivity. + intro H1. elim (option_sum _ (MapGet _ (MapDom B m') a)). intro H2. elim H2. intros t H3. + cut (in_dom A a m = true). intro. rewrite (MapDom_Dom A m a) in H4. unfold in_FSet, in_dom in H4. + rewrite H1 in H4. discriminate H4. + apply H0. rewrite (MapDom_Dom B m' a). unfold in_FSet, in_dom in |- *. rewrite H3. reflexivity. + intro H2. rewrite H2. exact H1. + Qed. + + Lemma MapSubset_trans : + forall (m:Map A) (m':Map B) (m'':Map C), + MapSubset A B m m' -> MapSubset B C m' m'' -> MapSubset A C m m''. + Proof. + unfold MapSubset in |- *. intros. apply H0. apply H. assumption. + Qed. + +End MapSubsetOrder. + +Section FSubsetOrder. + + Lemma FSubset_refl : forall s:FSet, MapSubset _ _ s s. + Proof. + exact (MapSubset_refl unit). + Qed. + + Lemma FSubset_antisym : + forall s s':FSet, + MapSubset _ _ s s' -> MapSubset _ _ s' s -> eqmap unit s s'. + Proof. + intros. rewrite <- (FSet_Dom s). rewrite <- (FSet_Dom s'). + exact (MapSubset_antisym _ _ s s' H H0). + Qed. + + Lemma FSubset_trans : + forall s s' s'':FSet, + MapSubset _ _ s s' -> MapSubset _ _ s' s'' -> MapSubset _ _ s s''. + Proof. + exact (MapSubset_trans unit unit unit). + Qed. + +End FSubsetOrder. + +Section MapSubsetExtra. + + Variables A B : Set. + + Lemma MapSubset_Dom_1 : + forall (m:Map A) (m':Map B), + MapSubset A B m m' -> MapSubset unit unit (MapDom A m) (MapDom B m'). + Proof. + unfold MapSubset in |- *. intros. elim (MapDom_semantics_2 _ m a H0). intros y H1. + cut (in_dom A a m = true -> in_dom B a m' = true). intro. unfold in_dom in H2. + rewrite H1 in H2. elim (option_sum _ (MapGet B m' a)). intro H3. elim H3. + intros y' H4. exact (MapDom_semantics_1 _ m' a y' H4). + intro H3. rewrite H3 in H2. cut (false = true). intro. discriminate H4. + apply H2. reflexivity. + exact (H a). + Qed. + + Lemma MapSubset_Dom_2 : + forall (m:Map A) (m':Map B), + MapSubset unit unit (MapDom A m) (MapDom B m') -> MapSubset A B m m'. + Proof. + unfold MapSubset in |- *. intros. unfold in_dom in H0. elim (option_sum _ (MapGet A m a)). + intro H1. elim H1. intros y H2. + elim (MapDom_semantics_2 _ _ _ (H a (MapDom_semantics_1 _ _ _ _ H2))). intros y' H3. + unfold in_dom in |- *. rewrite H3. reflexivity. + intro H1. rewrite H1 in H0. discriminate H0. + Qed. + + Lemma MapSubset_1_Dom : + forall (m:Map A) (m':Map B), + MapSubset_1 A B m m' = MapSubset_1 unit unit (MapDom A m) (MapDom B m'). + Proof. + intros. elim (sumbool_of_bool (MapSubset_1 A B m m')). intro H. rewrite H. + apply sym_eq. apply MapSubset_imp_1. apply MapSubset_Dom_1. exact (MapSubset_1_imp _ _ _ _ H). + intro H. rewrite H. elim (sumbool_of_bool (MapSubset_1 unit unit (MapDom A m) (MapDom B m'))). + intro H0. + rewrite + (MapSubset_imp_1 _ _ _ _ + (MapSubset_Dom_2 _ _ (MapSubset_1_imp _ _ _ _ H0))) + in H. + discriminate H. + intro. apply sym_eq. assumption. + Qed. + + Lemma MapSubset_Put : + forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut A m a y). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite H. apply orb_b_true. + Qed. + + Lemma MapSubset_Put_mono : + forall (m:Map A) (m':Map B) (a:ad) (y:A) (y':B), + MapSubset A B m m' -> MapSubset A B (MapPut A m a y) (MapPut B m' a y'). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_put. rewrite (in_dom_put A m a y a0) in H0. + elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity. + intro H1. rewrite (H _ H1). apply orb_b_true. + Qed. + + Lemma MapSubset_Put_behind : + forall (m:Map A) (a:ad) (y:A), MapSubset A A m (MapPut_behind A m a y). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_put_behind. rewrite H. apply orb_b_true. + Qed. + + Lemma MapSubset_Put_behind_mono : + forall (m:Map A) (m':Map B) (a:ad) (y:A) (y':B), + MapSubset A B m m' -> + MapSubset A B (MapPut_behind A m a y) (MapPut_behind B m' a y'). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_put_behind. + rewrite (in_dom_put_behind A m a y a0) in H0. + elim (orb_true_elim _ _ H0). intro H1. rewrite H1. reflexivity. + intro H1. rewrite (H _ H1). apply orb_b_true. + Qed. + + Lemma MapSubset_Remove : + forall (m:Map A) (a:ad), MapSubset A A (MapRemove A m a) m. + Proof. + unfold MapSubset in |- *. intros. unfold MapSubset in |- *. intros. rewrite (in_dom_remove _ m a a0) in H. + elim (andb_prop _ _ H). trivial. + Qed. + + Lemma MapSubset_Remove_mono : + forall (m:Map A) (m':Map B) (a:ad), + MapSubset A B m m' -> MapSubset A B (MapRemove A m a) (MapRemove B m' a). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_remove. rewrite (in_dom_remove A m a a0) in H0. + elim (andb_prop _ _ H0). intros. rewrite H1. rewrite (H _ H2). reflexivity. + Qed. + + Lemma MapSubset_Merge_l : + forall m m':Map A, MapSubset A A m (MapMerge A m m'). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. reflexivity. + Qed. + + Lemma MapSubset_Merge_r : + forall m m':Map A, MapSubset A A m' (MapMerge A m m'). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite H. apply orb_b_true. + Qed. + + Lemma MapSubset_Merge_mono : + forall (m m':Map A) (m'' m''':Map B), + MapSubset A B m m'' -> + MapSubset A B m' m''' -> + MapSubset A B (MapMerge A m m') (MapMerge B m'' m'''). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_merge. rewrite (in_dom_merge A m m' a) in H1. + elim (orb_true_elim _ _ H1). intro H2. rewrite (H _ H2). reflexivity. + intro H2. rewrite (H0 _ H2). apply orb_b_true. + Qed. + + Lemma MapSubset_DomRestrTo_l : + forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrTo A B m m') m. + Proof. + unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H). + trivial. + Qed. + + Lemma MapSubset_DomRestrTo_r : + forall (m:Map A) (m':Map B), MapSubset A B (MapDomRestrTo A B m m') m'. + Proof. + unfold MapSubset in |- *. intros. rewrite (in_dom_restrto _ _ m m' a) in H. elim (andb_prop _ _ H). + trivial. + Qed. + + Lemma MapSubset_ext : + forall (m0 m1:Map A) (m2 m3:Map B), + eqmap A m0 m1 -> + eqmap B m2 m3 -> MapSubset A B m0 m2 -> MapSubset A B m1 m3. + Proof. + intros. apply MapSubset_2_imp. unfold MapSubset_2 in |- *. + apply eqmap_trans with (m' := MapDomRestrBy A B m0 m2). apply MapDomRestrBy_ext. apply eqmap_sym. + assumption. + apply eqmap_sym. assumption. + exact (MapSubset_imp_2 _ _ _ _ H1). + Qed. + + Variables C D : Set. + + Lemma MapSubset_DomRestrTo_mono : + forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D), + MapSubset _ _ m m'' -> + MapSubset _ _ m' m''' -> + MapSubset _ _ (MapDomRestrTo _ _ m m') (MapDomRestrTo _ _ m'' m'''). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_restrto. rewrite (in_dom_restrto A B m m' a) in H1. + elim (andb_prop _ _ H1). intros. rewrite (H _ H2). rewrite (H0 _ H3). reflexivity. + Qed. + + Lemma MapSubset_DomRestrBy_l : + forall (m:Map A) (m':Map B), MapSubset A A (MapDomRestrBy A B m m') m. + Proof. + unfold MapSubset in |- *. intros. rewrite (in_dom_restrby _ _ m m' a) in H. elim (andb_prop _ _ H). + trivial. + Qed. + + Lemma MapSubset_DomRestrBy_mono : + forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D), + MapSubset _ _ m m'' -> + MapSubset _ _ m''' m' -> + MapSubset _ _ (MapDomRestrBy _ _ m m') (MapDomRestrBy _ _ m'' m'''). + Proof. + unfold MapSubset in |- *. intros. rewrite in_dom_restrby. rewrite (in_dom_restrby A B m m' a) in H1. + elim (andb_prop _ _ H1). intros. rewrite (H _ H2). elim (sumbool_of_bool (in_dom D a m''')). + intro H4. rewrite (H0 _ H4) in H3. discriminate H3. + intro H4. rewrite H4. reflexivity. + Qed. + +End MapSubsetExtra. + +Section MapDisjointDef. + + Variables A B : Set. + + Definition MapDisjoint (m:Map A) (m':Map B) := + forall a:ad, in_dom A a m = true -> in_dom B a m' = true -> False. + + Definition MapDisjoint_1 (m:Map A) (m':Map B) := + match MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m with + | NONE => true + | _ => false + end. + + Definition MapDisjoint_2 (m:Map A) (m':Map B) := + eqmap A (MapDomRestrTo A B m m') (M0 A). + + Lemma MapDisjoint_imp_1 : + forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_1 m m' = true. + Proof. + unfold MapDisjoint, MapDisjoint_1 in |- *. intros. + elim (option_sum _ (MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m)). intro H0. elim H0. + intro r. elim r. intros a y H1. cut (in_dom A a m = true -> in_dom B a m' = true -> False). + intro. unfold in_dom at 1 in H2. rewrite (MapSweep_semantics_2 _ _ _ _ _ H1) in H2. + rewrite (MapSweep_semantics_1 _ _ _ _ _ H1) in H2. elim (H2 (refl_equal _) (refl_equal _)). + exact (H a). + intro H0. rewrite H0. reflexivity. + Qed. + + Lemma MapDisjoint_1_imp : + forall (m:Map A) (m':Map B), MapDisjoint_1 m m' = true -> MapDisjoint m m'. + Proof. + unfold MapDisjoint, MapDisjoint_1 in |- *. intros. + elim (option_sum _ (MapSweep A (fun (a:ad) (_:A) => in_dom B a m') m)). intro H2. elim H2. + intro r. elim r. intros a' y' H3. rewrite H3 in H. discriminate H. + intro H2. unfold in_dom in H0. elim (option_sum _ (MapGet A m a)). intro H3. elim H3. + intros y H4. rewrite (MapSweep_semantics_3 _ _ _ H2 a y H4) in H1. discriminate H1. + intro H3. rewrite H3 in H0. discriminate H0. + Qed. + + Lemma MapDisjoint_imp_2 : + forall (m:Map A) (m':Map B), MapDisjoint m m' -> MapDisjoint_2 m m'. + Proof. + unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros. + rewrite (MapDomRestrTo_semantics A B m m' a). + cut (in_dom A a m = true -> in_dom B a m' = true -> False). intro. + elim (option_sum _ (MapGet A m a)). intro H1. elim H1. intros y H2. unfold in_dom at 1 in H0. + elim (option_sum _ (MapGet B m' a)). intro H3. elim H3. intros y' H4. unfold in_dom at 1 in H0. + rewrite H4 in H0. rewrite H2 in H0. elim (H0 (refl_equal _) (refl_equal _)). + intro H3. rewrite H3. reflexivity. + intro H1. rewrite H1. case (MapGet B m' a); reflexivity. + exact (H a). + Qed. + + Lemma MapDisjoint_2_imp : + forall (m:Map A) (m':Map B), MapDisjoint_2 m m' -> MapDisjoint m m'. + Proof. + unfold MapDisjoint, MapDisjoint_2 in |- *. unfold eqmap, eqm in |- *. intros. elim (in_dom_some _ _ _ H0). + intros y H2. elim (in_dom_some _ _ _ H1). intros y' H3. + cut (MapGet A (MapDomRestrTo A B m m') a = NONE A). intro. + rewrite (MapDomRestrTo_semantics _ _ m m' a) in H4. rewrite H3 in H4. rewrite H2 in H4. + discriminate H4. + exact (H a). + Qed. + + Lemma Map_M0_disjoint : forall m:Map B, MapDisjoint (M0 A) m. + Proof. + unfold MapDisjoint, in_dom in |- *. intros. discriminate H. + Qed. + + Lemma Map_disjoint_M0 : forall m:Map A, MapDisjoint m (M0 B). + Proof. + unfold MapDisjoint, in_dom in |- *. intros. discriminate H0. + Qed. + +End MapDisjointDef. + +Section MapDisjointExtra. + + Variables A B : Set. + + Lemma MapDisjoint_ext : + forall (m0 m1:Map A) (m2 m3:Map B), + eqmap A m0 m1 -> + eqmap B m2 m3 -> MapDisjoint A B m0 m2 -> MapDisjoint A B m1 m3. + Proof. + intros. apply MapDisjoint_2_imp. unfold MapDisjoint_2 in |- *. + apply eqmap_trans with (m' := MapDomRestrTo A B m0 m2). apply eqmap_sym. apply MapDomRestrTo_ext. + assumption. + assumption. + exact (MapDisjoint_imp_2 _ _ _ _ H1). + Qed. + + Lemma MapMerge_disjoint : + forall m m':Map A, + MapDisjoint A A m m' -> + forall a:ad, + in_dom A a (MapMerge A m m') = + orb (andb (in_dom A a m) (negb (in_dom A a m'))) + (andb (in_dom A a m') (negb (in_dom A a m))). + Proof. + unfold MapDisjoint in |- *. intros. rewrite in_dom_merge. elim (sumbool_of_bool (in_dom A a m)). + intro H0. rewrite H0. elim (sumbool_of_bool (in_dom A a m')). intro H1. elim (H a H0 H1). + intro H1. rewrite H1. reflexivity. + intro H0. rewrite H0. simpl in |- *. rewrite andb_b_true. reflexivity. + Qed. + + Lemma MapDisjoint_M2_l : + forall (m0 m1:Map A) (m2 m3:Map B), + MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3) -> MapDisjoint A B m0 m2. + Proof. + unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m0 a)). intro H2. + elim H2. intros y H3. elim (option_sum _ (MapGet B m2 a)). intro H4. elim H4. + intros y' H5. apply (H (ad_double a)). + rewrite (MapGet_M2_bit_0_0 _ (ad_double a) (ad_double_bit_0 a) m0 m1). + rewrite (ad_double_div_2 a). rewrite H3. reflexivity. + rewrite (MapGet_M2_bit_0_0 _ (ad_double a) (ad_double_bit_0 a) m2 m3). + rewrite (ad_double_div_2 a). rewrite H5. reflexivity. + intro H4. rewrite H4 in H1. discriminate H1. + intro H2. rewrite H2 in H0. discriminate H0. + Qed. + + Lemma MapDisjoint_M2_r : + forall (m0 m1:Map A) (m2 m3:Map B), + MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3) -> MapDisjoint A B m1 m3. + Proof. + unfold MapDisjoint, in_dom in |- *. intros. elim (option_sum _ (MapGet A m1 a)). intro H2. + elim H2. intros y H3. elim (option_sum _ (MapGet B m3 a)). intro H4. elim H4. + intros y' H5. apply (H (ad_double_plus_un a)). + rewrite + (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a) + m0 m1). + rewrite (ad_double_plus_un_div_2 a). rewrite H3. reflexivity. + rewrite + (MapGet_M2_bit_0_1 _ (ad_double_plus_un a) (ad_double_plus_un_bit_0 a) + m2 m3). + rewrite (ad_double_plus_un_div_2 a). rewrite H5. reflexivity. + intro H4. rewrite H4 in H1. discriminate H1. + intro H2. rewrite H2 in H0. discriminate H0. + Qed. + + Lemma MapDisjoint_M2 : + forall (m0 m1:Map A) (m2 m3:Map B), + MapDisjoint A B m0 m2 -> + MapDisjoint A B m1 m3 -> MapDisjoint A B (M2 A m0 m1) (M2 B m2 m3). + Proof. + unfold MapDisjoint, in_dom in |- *. intros. elim (sumbool_of_bool (ad_bit_0 a)). intro H3. + rewrite (MapGet_M2_bit_0_1 A a H3 m0 m1) in H1. + rewrite (MapGet_M2_bit_0_1 B a H3 m2 m3) in H2. exact (H0 (ad_div_2 a) H1 H2). + intro H3. rewrite (MapGet_M2_bit_0_0 A a H3 m0 m1) in H1. + rewrite (MapGet_M2_bit_0_0 B a H3 m2 m3) in H2. exact (H (ad_div_2 a) H1 H2). + Qed. + + Lemma MapDisjoint_M1_l : + forall (m:Map A) (a:ad) (y:B), + MapDisjoint B A (M1 B a y) m -> in_dom A a m = false. + Proof. + unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (in_dom A a m)). intro H0. + elim (H a (in_dom_M1_1 B a y) H0). + trivial. + Qed. + + Lemma MapDisjoint_M1_r : + forall (m:Map A) (a:ad) (y:B), + MapDisjoint A B m (M1 B a y) -> in_dom A a m = false. + Proof. + unfold MapDisjoint in |- *. intros. elim (sumbool_of_bool (in_dom A a m)). intro H0. + elim (H a H0 (in_dom_M1_1 B a y)). + trivial. + Qed. + + Lemma MapDisjoint_M1_conv_l : + forall (m:Map A) (a:ad) (y:B), + in_dom A a m = false -> MapDisjoint B A (M1 B a y) m. + Proof. + unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H0) in H. rewrite H1 in H. + discriminate H. + Qed. + + Lemma MapDisjoint_M1_conv_r : + forall (m:Map A) (a:ad) (y:B), + in_dom A a m = false -> MapDisjoint A B m (M1 B a y). + Proof. + unfold MapDisjoint in |- *. intros. rewrite (in_dom_M1_2 B a a0 y H1) in H. rewrite H0 in H. + discriminate H. + Qed. + + Lemma MapDisjoint_sym : + forall (m:Map A) (m':Map B), MapDisjoint A B m m' -> MapDisjoint B A m' m. + Proof. + unfold MapDisjoint in |- *. intros. exact (H _ H1 H0). + Qed. + + Lemma MapDisjoint_empty : + forall m:Map A, MapDisjoint A A m m -> eqmap A m (M0 A). + Proof. + unfold eqmap, eqm in |- *. intros. rewrite <- (MapDomRestrTo_idempotent A m a). + exact (MapDisjoint_imp_2 A A m m H a). + Qed. + + Lemma MapDelta_disjoint : + forall m m':Map A, + MapDisjoint A A m m' -> eqmap A (MapDelta A m m') (MapMerge A m m'). + Proof. + intros. + apply eqmap_trans with + (m' := MapDomRestrBy A A (MapMerge A m m') (MapDomRestrTo A A m m')). + apply MapDelta_as_DomRestrBy. + apply eqmap_trans with (m' := MapDomRestrBy A A (MapMerge A m m') (M0 A)). + apply MapDomRestrBy_ext. apply eqmap_refl. + exact (MapDisjoint_imp_2 A A m m' H). + apply MapDomRestrBy_m_empty. + Qed. + + Variable C : Set. + + Lemma MapDomRestr_disjoint : + forall (m:Map A) (m':Map B) (m'':Map C), + MapDisjoint A B (MapDomRestrTo A C m m'') (MapDomRestrBy B C m' m''). + Proof. + unfold MapDisjoint in |- *. intros m m' m'' a. rewrite in_dom_restrto. rewrite in_dom_restrby. + intros. elim (andb_prop _ _ H). elim (andb_prop _ _ H0). intros. rewrite H4 in H2. + discriminate H2. + Qed. + + Lemma MapDelta_RestrTo_disjoint : + forall m m':Map A, + MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m m'). + Proof. + unfold MapDisjoint in |- *. intros m m' a. rewrite in_dom_delta. rewrite in_dom_restrto. + intros. elim (andb_prop _ _ H0). intros. rewrite H1 in H. rewrite H2 in H. discriminate H. + Qed. + + Lemma MapDelta_RestrTo_disjoint_2 : + forall m m':Map A, + MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m' m). + Proof. + unfold MapDisjoint in |- *. intros m m' a. rewrite in_dom_delta. rewrite in_dom_restrto. + intros. elim (andb_prop _ _ H0). intros. rewrite H1 in H. rewrite H2 in H. discriminate H. + Qed. + + Variable D : Set. + + Lemma MapSubset_Disjoint : + forall (m:Map A) (m':Map B) (m'':Map C) (m''':Map D), + MapSubset _ _ m m' -> + MapSubset _ _ m'' m''' -> + MapDisjoint _ _ m' m''' -> MapDisjoint _ _ m m''. + Proof. + unfold MapSubset, MapDisjoint in |- *. intros. exact (H1 _ (H _ H2) (H0 _ H3)). + Qed. + + Lemma MapSubset_Disjoint_l : + forall (m:Map A) (m':Map B) (m'':Map C), + MapSubset _ _ m m' -> MapDisjoint _ _ m' m'' -> MapDisjoint _ _ m m''. + Proof. + unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ (H _ H1) H2). + Qed. + + Lemma MapSubset_Disjoint_r : + forall (m:Map A) (m'':Map C) (m''':Map D), + MapSubset _ _ m'' m''' -> + MapDisjoint _ _ m m''' -> MapDisjoint _ _ m m''. + Proof. + unfold MapSubset, MapDisjoint in |- *. intros. exact (H0 _ H1 (H _ H2)). + Qed. + +End MapDisjointExtra.
\ No newline at end of file diff --git a/theories/IntMap/intro.tex b/theories/IntMap/intro.tex new file mode 100644 index 00000000..9ad93050 --- /dev/null +++ b/theories/IntMap/intro.tex @@ -0,0 +1,6 @@ +\section{Maps indexed by binary integers : IntMap}\label{IntMap} + +This library contains a data structure for finite sets implemented by +an efficient structure of map (trees indexed by binary integers). +It was initially developed by Jean Goubault. + |