diff options
Diffstat (limited to 'theories7/IntMap')
| -rw-r--r-- | theories7/IntMap/Adalloc.v | 339 | ||||
| -rw-r--r-- | theories7/IntMap/Addec.v | 179 | ||||
| -rw-r--r-- | theories7/IntMap/Addr.v | 456 | ||||
| -rw-r--r-- | theories7/IntMap/Adist.v | 321 | ||||
| -rw-r--r-- | theories7/IntMap/Allmaps.v | 26 | ||||
| -rw-r--r-- | theories7/IntMap/Fset.v | 338 | ||||
| -rw-r--r-- | theories7/IntMap/Lsort.v | 537 | ||||
| -rw-r--r-- | theories7/IntMap/Map.v | 786 | ||||
| -rw-r--r-- | theories7/IntMap/Mapaxioms.v | 670 | ||||
| -rw-r--r-- | theories7/IntMap/Mapc.v | 457 | ||||
| -rw-r--r-- | theories7/IntMap/Mapcanon.v | 376 | ||||
| -rw-r--r-- | theories7/IntMap/Mapcard.v | 670 | ||||
| -rw-r--r-- | theories7/IntMap/Mapfold.v | 381 | ||||
| -rw-r--r-- | theories7/IntMap/Mapiter.v | 527 | ||||
| -rw-r--r-- | theories7/IntMap/Maplists.v | 399 | ||||
| -rw-r--r-- | theories7/IntMap/Mapsubset.v | 554 |
16 files changed, 7016 insertions, 0 deletions
diff --git a/theories7/IntMap/Adalloc.v b/theories7/IntMap/Adalloc.v new file mode 100644 index 00000000..9e8dd1b3 --- /dev/null +++ b/theories7/IntMap/Adalloc.v @@ -0,0 +1,339 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:26 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Arith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Fset. + +Section AdAlloc. + + Variable A : Set. + + Definition nat_of_ad := [a:ad] Cases a of + ad_z => O + | (ad_x p) => (convert p) + end. + + Fixpoint nat_le [m:nat] : nat -> bool := + Cases m of + O => [_:nat] true + | (S m') => [n:nat] Cases n of + O => false + | (S n') => (nat_le m' n') + end + end. + + Lemma nat_le_correct : (m,n:nat) (le m n) -> (nat_le m n)=true. + Proof. + NewInduction m as [|m IHm]. Trivial. + NewDestruct n. Intro H. Elim (le_Sn_O ? H). + Intros. Simpl. Apply IHm. Apply le_S_n. Assumption. + Qed. + + Lemma nat_le_complete : (m,n:nat) (nat_le m n)=true -> (le m n). + Proof. + NewInduction m. Trivial with arith. + NewDestruct n. Intro H. Discriminate H. + Auto with arith. + Qed. + + Lemma nat_le_correct_conv : (m,n:nat) (lt m n) -> (nat_le n m)=false. + Proof. + Intros. Elim (sumbool_of_bool (nat_le n m)). Intro H0. + Elim (lt_n_n ? (lt_le_trans ? ? ? H (nat_le_complete ? ? H0))). + Trivial. + Qed. + + Lemma nat_le_complete_conv : (m,n:nat) (nat_le n m)=false -> (lt 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] Cases n of + O => ad_z + | (S n') => (ad_x (anti_convert n')) + end. + + Lemma ad_of_nat_of_ad : (a:ad) (ad_of_nat (nat_of_ad a))=a. + Proof. + NewDestruct a as [|p]. Reflexivity. + Simpl. Elim (ZL4 p). Intros n H. Rewrite H. Simpl. Rewrite <- bij1 in H. + Rewrite convert_intro with 1:=H. Reflexivity. + Qed. + + Lemma nat_of_ad_of_nat : (n:nat) (nat_of_ad (ad_of_nat n))=n. + Proof. + NewInduction n. Trivial. + Intros. Simpl. Apply bij1. + Qed. + + Definition ad_le := [a,b:ad] (nat_le (nat_of_ad a) (nat_of_ad b)). + + Lemma ad_le_refl : (a:ad) (ad_le a a)=true. + Proof. + Intro. Unfold ad_le. Apply nat_le_correct. Apply le_n. + Qed. + + Lemma ad_le_antisym : (a,b:ad) (ad_le a b)=true -> (ad_le b a)=true -> a=b. + Proof. + Unfold ad_le. 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 : (a,b,c:ad) (ad_le a b)=true -> (ad_le b c)=true -> + (ad_le a c)=true. + Proof. + Unfold ad_le. 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 : (a,b,c:ad) (ad_le a b)=true -> (ad_le c b)=false -> + (ad_le c a)=false. + Proof. + Unfold ad_le. 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 : (a,b,c:ad) (ad_le b a)=false -> (ad_le b c)=true -> + (ad_le c a)=false. + Proof. + Unfold ad_le. 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 : (a,b,c:ad) (ad_le b a)=false -> (ad_le c b)=false -> + (ad_le c a)=false. + Proof. + Unfold ad_le. 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 : (a,b:ad) (ad_le b a)=false -> (ad_le a b)=true. + Proof. + Unfold ad_le. 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 : (a,b:ad) {(ad_min a b)=a}+{(ad_min a b)=b}. + Proof. + Unfold ad_min. 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 : (a,b:ad) (ad_le (ad_min a b) a)=true. + Proof. + Unfold ad_min. 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 : (a,b:ad) (ad_le (ad_min a b) b)=true. + Proof. + Unfold ad_min. 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 : (a,b,c:ad) (ad_le a (ad_min b c))=true -> (ad_le a b)=true. + Proof. + Unfold ad_min. 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 : (a,b,c:ad) (ad_le a (ad_min b c))=true -> (ad_le a c)=true. + Proof. + Unfold ad_min. 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 : (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 : (a,b,c:ad) (ad_le (ad_min b c) a)=false -> (ad_le b a)=false. + Proof. + Unfold ad_min. 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 : (a,b,c:ad) (ad_le (ad_min b c) a)=false -> (ad_le c a)=false. + Proof. + Unfold ad_min. 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 := + Cases m of + M0 => ad_z + | (M1 a _) => if (ad_eq a ad_z) + then (ad_x xH) + 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 : (m:(Map A)) (MapGet A m (ad_alloc_opt m))=(NONE A). + Proof. + NewInduction m as [|a|m0 H m1 H0]. Reflexivity. + Simpl. 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))). + 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 : (m:(Map A)) (in_dom A (ad_alloc_opt m) m)=false. + Proof. + Unfold in_dom. 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 : (a:ad) (nat_of_ad (ad_double a))=(mult (2) (nat_of_ad a)). + Proof. + NewDestruct a as [|p]. Trivial. + Exact (convert_xO p). + Qed. + + Lemma nat_of_ad_double_plus_un : (a:ad) + (nat_of_ad (ad_double_plus_un a))=(S (mult (2) (nat_of_ad a))). + Proof. + NewDestruct a as [|p]. Trivial. + Exact (convert_xI p). + Qed. + + Lemma ad_le_double_mono : (a,b:ad) (ad_le a b)=true -> + (ad_le (ad_double a) (ad_double b))=true. + Proof. + Unfold ad_le. Intros. Rewrite nat_of_ad_double. Rewrite nat_of_ad_double. Apply nat_le_correct. + Simpl. Apply le_plus_plus. Apply nat_le_complete. Assumption. + Apply le_plus_plus. Apply nat_le_complete. Assumption. + Apply le_n. + Qed. + + Lemma ad_le_double_plus_un_mono : (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. Intros. Rewrite nat_of_ad_double_plus_un. Rewrite nat_of_ad_double_plus_un. + Apply nat_le_correct. Apply le_n_S. Simpl. Apply le_plus_plus. Apply nat_le_complete. + Assumption. + Apply le_plus_plus. Apply nat_le_complete. Assumption. + Apply le_n. + Qed. + + Lemma ad_le_double_mono_conv : (a,b:ad) (ad_le (ad_double a) (ad_double b))=true -> + (ad_le a b)=true. + Proof. + Unfold ad_le. Intros a b. Rewrite nat_of_ad_double. Rewrite nat_of_ad_double. Intro. + Apply nat_le_correct. Apply (mult_le_conv_1 (1)). Apply nat_le_complete. Assumption. + Qed. + + Lemma ad_le_double_plus_un_mono_conv : (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. Intros a b. Rewrite nat_of_ad_double_plus_un. Rewrite nat_of_ad_double_plus_un. + Intro. Apply nat_le_correct. Apply (mult_le_conv_1 (1)). Apply le_S_n. Apply nat_le_complete. + Assumption. + Qed. + + Lemma ad_lt_double_mono : (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 : (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 : (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 : (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 : (m:(Map A)) (a:ad) (ad_le (ad_alloc_opt m) a)=false -> + {y:A | (MapGet A m a)=(SOME A y)}. + Proof. + NewInduction m as [|a y|m0 H m1 H0]. Simpl. Unfold ad_le. Simpl. Intros. Discriminate H. + Simpl. 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 : (m:(Map A)) (a:ad) (ad_le (ad_alloc_opt m) a)=false -> + (in_dom A a m)=true. + Proof. + Intros. Unfold in_dom. Elim (ad_alloc_opt_optimal_1 m a H). Intros y H0. Rewrite H0. + Reflexivity. + Qed. + +End AdAlloc. + +V7only [ +(* Moved to NArith *) +Notation positive_to_nat_2 := positive_to_nat_2. +Notation positive_to_nat_4 := positive_to_nat_4. +]. diff --git a/theories7/IntMap/Addec.v b/theories7/IntMap/Addec.v new file mode 100644 index 00000000..50dc1480 --- /dev/null +++ b/theories7/IntMap/Addec.v @@ -0,0 +1,179 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:26 herbelin Exp $ i*) + +(** Equality on adresses *) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Addr. + +Fixpoint ad_eq_1 [p1,p2:positive] : bool := + Cases p1 p2 of + 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] + Cases a a' of + ad_z ad_z => true + | (ad_x p) (ad_x p') => (ad_eq_1 p p') + | _ _ => false + end. + +Lemma ad_eq_correct : (a:ad) (ad_eq a a)=true. +Proof. + NewDestruct a; Trivial. + NewInduction p; Trivial. +Qed. + +Lemma ad_eq_complete : (a,a':ad) (ad_eq a a')=true -> a=a'. +Proof. + NewDestruct a. NewDestruct a'; Trivial. NewDestruct p. + Discriminate 1. + Discriminate 1. + Discriminate 1. + NewDestruct a'. Intros. Discriminate H. + Unfold ad_eq. Intros. Cut p=p0. Intros. Rewrite H0. Reflexivity. + Generalize Dependent p0. + NewInduction p as [p IHp|p IHp|]. NewDestruct p0; Intro H. + Rewrite (IHp p0). Reflexivity. + Exact H. + Discriminate H. + Discriminate H. + NewDestruct p0; Intro H. Discriminate H. + Rewrite (IHp p0 H). Reflexivity. + Discriminate H. + NewDestruct p0; Intro H. Discriminate H. + Discriminate H. + Trivial. +Qed. + +Lemma ad_eq_comm : (a,a':ad) (ad_eq a a')=(ad_eq a' a). +Proof. + Intros. Cut (b,b':bool)(ad_eq a a')=b->(ad_eq a' a)=b'->b=b'. + Intros. Apply H. Reflexivity. + Reflexivity. + NewDestruct 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. + NewDestruct 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 : (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 : + (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 : (a:ad) (ad_bit_0 a)=true -> + (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 : (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 : (a:ad) (ad_bit_0 a)=false -> + (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 : (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 : + (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 : + (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 : (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 : (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. NewDestruct 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 : (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 : (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 : (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. diff --git a/theories7/IntMap/Addr.v b/theories7/IntMap/Addr.v new file mode 100644 index 00000000..9f362772 --- /dev/null +++ b/theories7/IntMap/Addr.v @@ -0,0 +1,456 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:27 herbelin Exp $ i*) + +(** Representation of adresses by the [positive] type of binary numbers *) + +Require Bool. +Require ZArith. + +Inductive ad : Set := + ad_z : ad + | ad_x : positive -> ad. + +Lemma ad_sum : (a:ad) {p:positive | a=(ad_x p)}+{a=ad_z}. +Proof. + NewDestruct a; Auto. + Left; Exists p; Trivial. +Qed. + +Fixpoint p_xor [p:positive] : positive -> ad := + [p2] Cases p of + xH => Cases p2 of + xH => ad_z + | (xO p'2) => (ad_x (xI p'2)) + | (xI p'2) => (ad_x (xO p'2)) + end + | (xO p') => Cases p2 of + xH => (ad_x (xI p')) + | (xO p'2) => Cases (p_xor p' p'2) of + ad_z => ad_z + | (ad_x p'') => (ad_x (xO p'')) + end + | (xI p'2) => Cases (p_xor p' p'2) of + ad_z => (ad_x xH) + | (ad_x p'') => (ad_x (xI p'')) + end + end + | (xI p') => Cases p2 of + xH => (ad_x (xO p')) + | (xO p'2) => Cases (p_xor p' p'2) of + ad_z => (ad_x xH) + | (ad_x p'') => (ad_x (xI p'')) + end + | (xI p'2) => Cases (p_xor p' p'2) of + ad_z => ad_z + | (ad_x p'') => (ad_x (xO p'')) + end + end + end. + +Definition ad_xor := [a,a':ad] + Cases a of + ad_z => a' + | (ad_x p) => Cases a' of + ad_z => a + | (ad_x p') => (p_xor p p') + end + end. + +Lemma ad_xor_neutral_left : (a:ad) (ad_xor ad_z a)=a. +Proof. + Trivial. +Qed. + +Lemma ad_xor_neutral_right : (a:ad) (ad_xor a ad_z)=a. +Proof. + NewDestruct a; Trivial. +Qed. + +Lemma ad_xor_comm : (a,a':ad) (ad_xor a a')=(ad_xor a' a). +Proof. + NewDestruct a; NewDestruct a'; Simpl; Auto. + Generalize p0; Clear p0; NewInduction p as [p Hrecp|p Hrecp|]; Simpl; Auto. + NewDestruct p0; Simpl; Trivial; Intros. + Rewrite Hrecp; Trivial. + Rewrite Hrecp; Trivial. + NewDestruct p0; Simpl; Trivial; Intros. + Rewrite Hrecp; Trivial. + Rewrite Hrecp; Trivial. + NewDestruct p0; Simpl; Auto. +Qed. + +Lemma ad_xor_nilpotent : (a:ad) (ad_xor a a)=ad_z. +Proof. + NewDestruct a; Trivial. + Simpl. NewInduction p as [p IHp|p IHp|]; Trivial. + Simpl. Rewrite IHp; Reflexivity. + Simpl. Rewrite IHp; Reflexivity. +Qed. + +Fixpoint ad_bit_1 [p:positive] : nat -> bool := + Cases p of + xH => [n:nat] Cases n of + O => true + | (S _) => false + end + | (xO p) => [n:nat] Cases n of + O => false + | (S n') => (ad_bit_1 p n') + end + | (xI p) => [n:nat] Cases n of + O => true + | (S n') => (ad_bit_1 p n') + end + end. + +Definition ad_bit := [a:ad] + Cases a of + ad_z => [_:nat] false + | (ad_x p) => (ad_bit_1 p) + end. + +Definition eqf := [f,g:nat->bool] (n:nat) (f n)=(g n). + +Lemma ad_faithful_1 : (a:ad) (eqf (ad_bit ad_z) (ad_bit a)) -> ad_z=a. +Proof. + NewDestruct a. Trivial. + NewInduction p as [p IHp|p IHp|];Intro H. Absurd ad_z=(ad_x p). Discriminate. + Exact (IHp [n:nat](H (S n))). + Absurd ad_z=(ad_x p). Discriminate. + Exact (IHp [n:nat](H (S n))). + Absurd false=true. Discriminate. + Exact (H O). +Qed. + +Lemma ad_faithful_2 : (a:ad) (eqf (ad_bit (ad_x xH)) (ad_bit a)) -> (ad_x xH)=a. +Proof. + NewDestruct a. Intros. Absurd true=false. Discriminate. + Exact (H O). + NewDestruct p. Intro H. Absurd ad_z=(ad_x p). Discriminate. + Exact (ad_faithful_1 (ad_x p) [n:nat](H (S n))). + Intros. Absurd true=false. Discriminate. + Exact (H O). + Trivial. +Qed. + +Lemma ad_faithful_3 : + (a:ad) (p:positive) + ((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. + NewDestruct 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. Intro. Unfold eqf in H0. Rewrite H0. Reflexivity. + Case p. Intros. Absurd false=true. Discriminate. + Exact (H0 O). + Intros. Rewrite (H p0 [n:nat](H0 (S n))). Reflexivity. + Intros. Absurd false=true. Discriminate. + Exact (H0 O). +Qed. + +Lemma ad_faithful_4 : + (a:ad) (p:positive) + ((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. + NewDestruct 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. Intro. Unfold eqf in H0. Rewrite H0. Reflexivity. + Case p. Intros. Rewrite (H p0 [n:nat](H0 (S n))). Reflexivity. + Intros. Absurd true=false. Discriminate. + Exact (H0 O). + Intros. Absurd ad_z=(ad_x p0). Discriminate. + Cut (eqf (ad_bit (ad_x xH)) (ad_bit (ad_x (xI p0)))). + Intro. Exact (ad_faithful_1 (ad_x p0) [n:nat](H1 (S n))). + Unfold eqf. Unfold eqf in H0. Intro. Rewrite H0. Reflexivity. +Qed. + +Lemma ad_faithful : (a,a':ad) (eqf (ad_bit a) (ad_bit a')) -> a=a'. +Proof. + NewDestruct a. Exact ad_faithful_1. + NewInduction 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 : (a':ad) (ad_bit (ad_xor ad_z a') O)=(ad_bit a' O). +Proof. + Trivial. +Qed. + +Lemma ad_xor_sem_2 : (a':ad) (ad_bit (ad_xor (ad_x xH) a') O)=(negb (ad_bit a' O)). +Proof. + Intro. Case a'. Trivial. + Simpl. Intro. + Case p; Trivial. +Qed. + +Lemma ad_xor_sem_3 : + (p:positive) (a':ad) (ad_bit (ad_xor (ad_x (xO p)) a') O)=(ad_bit a' O). +Proof. + Intros. Case a'. Trivial. + Simpl. Intro. + Case p0; Trivial. Intro. + Case (p_xor p p1); Trivial. + Intro. Case (p_xor p p1); Trivial. +Qed. + +Lemma ad_xor_sem_4 : (p:positive) (a':ad) + (ad_bit (ad_xor (ad_x (xI p)) a') O)=(negb (ad_bit a' O)). +Proof. + Intros. Case a'. Trivial. + Simpl. Intro. Case p0; Trivial. Intro. + Case (p_xor p p1); Trivial. + Intro. + Case (p_xor p p1); Trivial. +Qed. + +Lemma ad_xor_sem_5 : + (a,a':ad) (ad_bit (ad_xor a a') O)=(adf_xor (ad_bit a) (ad_bit a') O). +Proof. + NewDestruct a. Intro. Change (ad_bit a' O)=(xorb false (ad_bit a' O)). Rewrite false_xorb. Trivial. + Case p. Exact ad_xor_sem_4. + Intros. Change (ad_bit (ad_xor (ad_x (xO p0)) a') O)=(xorb false (ad_bit a' O)). + Rewrite false_xorb. Apply ad_xor_sem_3. Exact ad_xor_sem_2. +Qed. + +Lemma ad_xor_sem_6 : (n:nat) + ((a,a':ad) (ad_bit (ad_xor a a') n)=(adf_xor (ad_bit a) (ad_bit a') n)) -> + (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. Unfold 2 ad_bit. Rewrite false_xorb. Reflexivity. + Case a'. Unfold adf_xor. Unfold 3 ad_bit. 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). + Rewrite <- H. Simpl. + 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). + Rewrite <- H. Simpl. + Case (p_xor p2 p1); Trivial. + Intro. Unfold adf_xor. Unfold 3 ad_bit. Unfold ad_bit_1. 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). + Rewrite <- H. Simpl. + 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). + Rewrite <- H. Simpl. + Case (p_xor p2 p1); Trivial. + Intro. Unfold adf_xor. Unfold 3 ad_bit. Unfold ad_bit_1. Rewrite xorb_false. Reflexivity. + Unfold adf_xor. Unfold 2 ad_bit. Unfold ad_bit_1. Rewrite false_xorb. Simpl. Case p; Trivial. +Qed. + +Lemma ad_xor_semantics : + (a,a':ad) (eqf (ad_bit (ad_xor a a')) (adf_xor (ad_bit a) (ad_bit a'))). +Proof. + Unfold eqf. Intros. Generalize a a'. Elim n. Exact ad_xor_sem_5. + Exact ad_xor_sem_6. +Qed. + +Lemma eqf_sym : (f,f':nat->bool) (eqf f f') -> (eqf f' f). +Proof. + Unfold eqf. Intros. Rewrite H. Reflexivity. +Qed. + +Lemma eqf_refl : (f:nat->bool) (eqf f f). +Proof. + Unfold eqf. Trivial. +Qed. + +Lemma eqf_trans : (f,f',f'':nat->bool) (eqf f f') -> (eqf f' f'') -> (eqf f f''). +Proof. + Unfold eqf. Intros. Rewrite H. Exact (H0 n). +Qed. + +Lemma adf_xor_eq : (f,f':nat->bool) (eqf (adf_xor f f') [n:nat] false) -> (eqf f f'). +Proof. + Unfold eqf. Unfold adf_xor. Intros. Apply xorb_eq. Apply H. +Qed. + +Lemma ad_xor_eq : (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. Trivial. +Qed. + +Lemma adf_xor_assoc : (f,f',f'':nat->bool) + (eqf (adf_xor (adf_xor f f') f'') (adf_xor f (adf_xor f' f''))). +Proof. + Unfold eqf. Unfold adf_xor. Intros. Apply xorb_assoc. +Qed. + +Lemma eqf_xor_1 : (f,f',f'',f''':nat->bool) (eqf f f') -> (eqf f'' f''') -> + (eqf (adf_xor f f'') (adf_xor f' f''')). +Proof. + Unfold eqf. Intros. Unfold adf_xor. Rewrite H. Rewrite H0. Reflexivity. +Qed. + +Lemma ad_xor_assoc : + (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] + Cases a of + ad_z => ad_z + | (ad_x p) => (ad_x (xO p)) + end. + +Definition ad_double_plus_un := [a:ad] + Cases a of + ad_z => (ad_x xH) + | (ad_x p) => (ad_x (xI p)) + end. + +Definition ad_div_2 := [a:ad] + Cases a of + 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 : (a:ad) (ad_div_2 (ad_double a))=a. +Proof. + NewDestruct a; Trivial. +Qed. + +Lemma ad_double_plus_un_div_2 : (a:ad) (ad_div_2 (ad_double_plus_un a))=a. +Proof. + NewDestruct a; Trivial. +Qed. + +Lemma ad_double_inj : (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 : + (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] + Cases a of + ad_z => false + | (ad_x (xO _)) => false + | _ => true + end. + +Lemma ad_double_bit_0 : (a:ad) (ad_bit_0 (ad_double a))=false. +Proof. + NewDestruct a; Trivial. +Qed. + +Lemma ad_double_plus_un_bit_0 : (a:ad) (ad_bit_0 (ad_double_plus_un a))=true. +Proof. + NewDestruct a; Trivial. +Qed. + +Lemma ad_div_2_double : (a:ad) (ad_bit_0 a)=false -> (ad_double (ad_div_2 a))=a. +Proof. + NewDestruct a. Trivial. NewDestruct p. Intro H. Discriminate H. + Intros. Reflexivity. + Intro H. Discriminate H. +Qed. + +Lemma ad_div_2_double_plus_un : + (a:ad) (ad_bit_0 a)=true -> (ad_double_plus_un (ad_div_2 a))=a. +Proof. + NewDestruct a. Intro. Discriminate H. + NewDestruct p. Intros. Reflexivity. + Intro H. Discriminate H. + Intro. Reflexivity. +Qed. + +Lemma ad_bit_0_correct : (a:ad) (ad_bit a O)=(ad_bit_0 a). +Proof. + NewDestruct a; Trivial. + NewDestruct p; Trivial. +Qed. + +Lemma ad_div_2_correct : (a:ad) (n:nat) (ad_bit (ad_div_2 a) n)=(ad_bit a (S n)). +Proof. + NewDestruct a; Trivial. + NewDestruct p; Trivial. +Qed. + +Lemma ad_xor_bit_0 : + (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' O). + Unfold adf_xor. Rewrite ad_bit_0_correct. Rewrite ad_bit_0_correct. Reflexivity. +Qed. + +Lemma ad_xor_div_2 : + (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. 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. Rewrite ad_div_2_correct. Rewrite ad_div_2_correct. + Reflexivity. +Qed. + +Lemma ad_neg_bit_0 : (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 : + (a,a':ad) (ad_xor a a')=(ad_x xH) -> (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 : (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 : (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. diff --git a/theories7/IntMap/Adist.v b/theories7/IntMap/Adist.v new file mode 100644 index 00000000..a7948c72 --- /dev/null +++ b/theories7/IntMap/Adist.v @@ -0,0 +1,321 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:27 herbelin Exp $ i*) + +Require Bool. +Require ZArith. +Require Arith. +Require Min. +Require Addr. + +Fixpoint ad_plength_1 [p:positive] : nat := + Cases p of + xH => O + | (xI _) => O + | (xO p') => (S (ad_plength_1 p')) + end. + +Inductive natinf : Set := + infty : natinf + | ni : nat -> natinf. + +Definition ad_plength := [a:ad] + Cases a of + ad_z => infty + | (ad_x p) => (ni (ad_plength_1 p)) + end. + +Lemma ad_plength_infty : (a:ad) (ad_plength a)=infty -> a=ad_z. +Proof. + Induction a; Trivial. + Unfold ad_plength; Intros; Discriminate H. +Qed. + +Lemma ad_plength_zeros : (a:ad) (n:nat) (ad_plength a)=(ni n) -> + (k:nat) (lt k n) -> (ad_bit a k)=false. +Proof. + Induction a; Trivial. + Induction p. Induction n. Intros. Inversion H1. + Induction k. Simpl in H1. Discriminate H1. + Intros. Simpl in H1. Discriminate H1. + Induction k. Trivial. + Generalize H0. Case n. Intros. Inversion H3. + Intros. Simpl. Unfold ad_bit in H. Apply (H n0). Simpl in H1. Inversion H1. Reflexivity. + Exact (lt_S_n n1 n0 H3). + Simpl. Intros n H. Inversion H. Intros. Inversion H0. +Qed. + +Lemma ad_plength_one : (a:ad) (n:nat) (ad_plength a)=(ni n) -> (ad_bit a n)=true. +Proof. + Induction a. Intros. Inversion H. + Induction p. Intros. Simpl in H0. Inversion H0. Reflexivity. + Intros. Simpl in H0. Inversion H0. Simpl. Unfold ad_bit in H. Apply H. Reflexivity. + Intros. Simpl in H. Inversion H. Reflexivity. +Qed. + +Lemma ad_plength_first_one : (a:ad) (n:nat) + ((k:nat) (lt k n) -> (ad_bit a k)=false) -> (ad_bit a n)=true -> + (ad_plength a)=(ni n). +Proof. + Induction a. Intros. Simpl in H0. Discriminate H0. + Induction p. Intros. Generalize H0. Case n. Intros. Reflexivity. + Intros. Absurd (ad_bit (ad_x (xI p0)) O)=false. Trivial with bool. + Auto with bool arith. + Intros. Generalize H0 H1. Case n. Intros. Simpl in H3. Discriminate H3. + Intros. Simpl. 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. 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] + Cases d of + infty => d' + | (ni n) => Cases d' of + infty => d + | (ni n') => (ni (min n n')) + end + end. + +Lemma ni_min_idemp : (d:natinf) (ni_min d d)=d. +Proof. + Induction d; Trivial. + Unfold ni_min. + Induction n; Trivial. + Intros. + Simpl. + Inversion H. + Rewrite H1. + Rewrite H1. + Reflexivity. +Qed. + +Lemma ni_min_comm : (d,d':natinf) (ni_min d d')=(ni_min d' d). +Proof. + Induction d. Induction d'; Trivial. + Induction d'; Trivial. Elim n. Induction n0; Trivial. + Intros. Elim n1; Trivial. Intros. Unfold ni_min in H. Cut (min n0 n2)=(min n2 n0). + Intro. Unfold ni_min. Simpl. Rewrite H1. Reflexivity. + Cut (ni (min n0 n2))=(ni (min n2 n0)). Intros. + Inversion H1; Trivial. + Exact (H n2). +Qed. + +Lemma ni_min_assoc : (d,d',d'':natinf) (ni_min (ni_min d d') d'')=(ni_min d (ni_min d' d'')). +Proof. + Induction d; Trivial. Induction d'; Trivial. + Induction d''; Trivial. + Unfold ni_min. Intro. Cut (min (min n n0) n1)=(min n (min n0 n1)). + Intro. Rewrite H. Reflexivity. + Generalize n0 n1. Elim n; Trivial. + Induction n3; Trivial. Induction n5; Trivial. + Intros. Simpl. Auto. +Qed. + +Lemma ni_min_O_l : (d:natinf) (ni_min (ni O) d)=(ni O). +Proof. + Induction d; Trivial. +Qed. + +Lemma ni_min_O_r : (d:natinf) (ni_min d (ni O))=(ni O). +Proof. + Intros. Rewrite ni_min_comm. Apply ni_min_O_l. +Qed. + +Lemma ni_min_inf_l : (d:natinf) (ni_min infty d)=d. +Proof. + Trivial. +Qed. + +Lemma ni_min_inf_r : (d:natinf) (ni_min d infty)=d. +Proof. + Induction d; Trivial. +Qed. + +Definition ni_le := [d,d':natinf] (ni_min d d')=d. + +Lemma ni_le_refl : (d:natinf) (ni_le d d). +Proof. + Exact ni_min_idemp. +Qed. + +Lemma ni_le_antisym : (d,d':natinf) (ni_le d d') -> (ni_le d' d) -> d=d'. +Proof. + Unfold ni_le. Intros d d'. Rewrite ni_min_comm. Intro H. Rewrite H. Trivial. +Qed. + +Lemma ni_le_trans : (d,d',d'':natinf) (ni_le d d') -> (ni_le d' d'') -> (ni_le d d''). +Proof. + Unfold ni_le. Intros. Rewrite <- H. Rewrite ni_min_assoc. Rewrite H0. Reflexivity. +Qed. + +Lemma ni_le_min_1 : (d,d':natinf) (ni_le (ni_min d d') d). +Proof. + Unfold ni_le. Intros. Rewrite (ni_min_comm d d'). Rewrite ni_min_assoc. + Rewrite ni_min_idemp. Reflexivity. +Qed. + +Lemma ni_le_min_2 : (d,d':natinf) (ni_le (ni_min d d') d'). +Proof. + Unfold ni_le. Intros. Rewrite ni_min_assoc. Rewrite ni_min_idemp. Reflexivity. +Qed. + +Lemma ni_min_case : (d,d':natinf) (ni_min d d')=d \/ (ni_min d d')=d'. +Proof. + Induction d. Intro. Right . Exact (ni_min_inf_l d'). + Induction d'. Left . Exact (ni_min_inf_r (ni n)). + Unfold ni_min. Cut (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. + Induction n1. Right . Reflexivity. + Intros. Case (H n2). Intro. Left . Simpl. Rewrite H1. Reflexivity. + Intro. Right . Simpl. Rewrite H1. Reflexivity. +Qed. + +Lemma ni_le_total : (d,d':natinf) (ni_le d d') \/ (ni_le d' d). +Proof. + Unfold ni_le. Intros. Rewrite (ni_min_comm d' d). Apply ni_min_case. +Qed. + +Lemma ni_le_min_induc : (d,d',dm:natinf) (ni_le dm d) -> (ni_le dm d') -> + ((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. Rewrite ni_min_comm. Exact H2. + Apply ni_le_refl. + Exact H0. +Qed. + +Lemma le_ni_le : (m,n:nat) (le m n) -> (ni_le (ni m) (ni n)). +Proof. + Cut (m,n:nat)(le m n)->(min m n)=m. + Intros. Unfold ni_le ni_min. Rewrite (H m n H0). Reflexivity. + Induction m. Trivial. + Induction n0. Intro. Inversion H0. + Intros. Simpl. Rewrite (H n1 (le_S_n n n1 H1)). Reflexivity. +Qed. + +Lemma ni_le_le : (m,n:nat) (ni_le (ni m) (ni n)) -> (le m n). +Proof. + Unfold ni_le. Unfold ni_min. Intros. Inversion H. Apply le_min_r. +Qed. + +Lemma ad_plength_lb : (a:ad) (n:nat) ((k:nat) (lt k n) -> (ad_bit a k)=false) -> + (ni_le (ni n) (ad_plength a)). +Proof. + Induction a. Intros. Exact (ni_min_inf_r (ni n)). + Intros. Unfold ad_plength. 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 natinf (ad_plength (ad_x p)))). + Discriminate. + Apply H. Exact H0. +Qed. + +Lemma ad_plength_ub : (a:ad) (n:nat) (ad_bit a n)=true -> + (ni_le (ad_plength a) (ni n)). +Proof. + Induction a. Intros. Discriminate H. + Intros. Unfold ad_plength. 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 natinf (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 : (a:ad) (ad_pdist a a)=infty. +Proof. + Intros. Unfold ad_pdist. Rewrite ad_xor_nilpotent. Reflexivity. +Qed. + +Lemma ad_pdist_eq_2 : (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 : (a,a':ad) (ad_pdist a a')=(ad_pdist a' a). +Proof. + Unfold ad_pdist. 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 : (a,a':ad) + (ni_le (ad_plength a) (ad_plength a')) -> + (ni_le (ad_plength a) (ad_plength (ad_xor a a'))). +Proof. + Induction a. Intros. Unfold ni_le in H. Unfold 1 3 ad_plength in H. + Rewrite (ni_min_inf_l (ad_plength a')) in H. + Rewrite (ad_plength_infty a' H). Simpl. Apply ni_le_refl. + Intros. Unfold 1 ad_plength. Apply ad_plength_lb. Intros. + Cut (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. + Rewrite (ad_plength_zeros (ad_x p) (ad_plength_1 p) + (refl_equal natinf (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 : (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 : (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. 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. diff --git a/theories7/IntMap/Allmaps.v b/theories7/IntMap/Allmaps.v new file mode 100644 index 00000000..e76e210f --- /dev/null +++ b/theories7/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.1.2.1 2004/07/16 19:31:27 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. diff --git a/theories7/IntMap/Fset.v b/theories7/IntMap/Fset.v new file mode 100644 index 00000000..545c1716 --- /dev/null +++ b/theories7/IntMap/Fset.v @@ -0,0 +1,338 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:27 herbelin Exp $ i*) + +(*s Sets operations on maps *) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. + +Section Dom. + + Variable A, B : Set. + + Fixpoint MapDomRestrTo [m:(Map A)] : (Map B) -> (Map A) := + Cases m of + M0 => [_:(Map B)] (M0 A) + | (M1 a y) => [m':(Map B)] Cases (MapGet B m' a) of + NONE => (M0 A) + | _ => m + end + | (M2 m1 m2) => [m':(Map B)] Cases m' of + M0 => (M0 A) + | (M1 a' y') => Cases (MapGet A m a') of + 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 : (m:(Map A)) (m':(Map B)) + (eqm A (MapGet A (MapDomRestrTo m m')) + [a0:ad] Cases (MapGet B m' a0) of + NONE => (NONE A) + | _ => (MapGet A m a0) + end). + Proof. + Unfold eqm. Induction m. Simpl. Intros. Case (MapGet B m' a); Trivial. + Intros. Simpl. 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). + Induction m'. Trivial. + Unfold MapDomRestrTo. 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) + =(Cases (MapGet B (M2 B m2 m3) a) of + NONE => (NONE A) + | (SOME _) => (MapGet A (M2 A m0 m1) a) + end). + 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) := + Cases m of + M0 => [_:(Map B)] (M0 A) + | (M1 a y) => [m':(Map B)] Cases (MapGet B m' a) of + NONE => m + | _ => (M0 A) + end + | (M2 m1 m2) => [m':(Map B)] Cases m' of + 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 : (m:(Map A)) (m':(Map B)) + (eqm A (MapGet A (MapDomRestrBy m m')) + [a0:ad] Cases (MapGet B m' a0) of + NONE => (MapGet A m a0) + | _ => (NONE A) + end). + Proof. + Unfold eqm. Induction m. Simpl. Intros. Case (MapGet B m' a); Trivial. + Intros. Simpl. 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. + Induction m'. Trivial. + Unfold MapDomRestrBy. 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) + =(Cases (MapGet B (M2 B m2 m3) a) of + NONE => (MapGet A (M2 A m0 m1) a) + | (SOME _) => (NONE A) + end). + 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)] + Cases (MapGet A m a) of + NONE => false + | _ => true + end. + + Lemma in_dom_M0 : (a:ad) (in_dom a (M0 A))=false. + Proof. + Trivial. + Qed. + + Lemma in_dom_M1 : (a,a0:ad) (y:A) (in_dom a0 (M1 A a y))=(ad_eq a a0). + Proof. + Unfold in_dom. Intros. Simpl. Case (ad_eq a a0); Reflexivity. + Qed. + + Lemma in_dom_M1_1 : (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 : (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 : (m:(Map A)) (a:ad) (in_dom a m)=true -> + {y:A | (MapGet A m a)=(SOME A y)}. + Proof. + Unfold in_dom. Intros. Elim (option_sum ? (MapGet A m a)). Trivial. + Intro H0. Rewrite H0 in H. Discriminate H. + Qed. + + Lemma in_dom_none : (m:(Map A)) (a:ad) (in_dom a m)=false -> + (MapGet A m a)=(NONE A). + Proof. + Unfold in_dom. 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 : (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. 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 : (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. 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 : (m:(Map A)) (a0:ad) (a:ad) + (in_dom a (MapRemove A m a0))=(andb (negb (ad_eq a a0)) (in_dom a m)). + Proof. + Unfold in_dom. 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 : (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. 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 : (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. 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. + + Variable A, B : Set. + + Lemma in_dom_restrto : (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. 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 : (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. 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. Rewrite andb_b_false. Reflexivity. + Intro H. Rewrite H. Unfold negb. 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 := + Cases m of + M0 => (M0 unit) + | (M1 a _) => (M1 unit a tt) + | (M2 m m') => (M2 unit (MapDom m) (MapDom m')) + end. + + Lemma MapDom_semantics_1 : (m:(Map A)) (a:ad) + (y:A) (MapGet A m a)=(SOME A y) -> (in_FSet a (MapDom m))=true. + Proof. + Induction m. Intros. Discriminate H. + Unfold MapDom. Unfold in_FSet. Unfold in_dom. Unfold MapGet. 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. Unfold in_FSet. + Unfold in_dom. 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 : (m:(Map A)) (a:ad) + (in_FSet a (MapDom m))=true -> {y:A | (MapGet A m a)=(SOME A y)}. + Proof. + Induction m. Intros. Discriminate H. + Unfold MapDom. Unfold in_FSet. Unfold in_dom. Unfold MapGet. 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. Unfold in_FSet. + Unfold in_dom. 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 : (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 : (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 : (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. Rewrite H0. + Reflexivity. + Intro H. Rewrite H. Unfold in_dom. Rewrite (MapDom_semantics_4 m a H). Reflexivity. + Qed. + + Definition FSetUnion : FSet -> FSet -> FSet := [s,s':FSet] (MapMerge unit s s'). + + Lemma in_FSet_union : (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 : FSet -> FSet -> FSet := [s,s':FSet] (MapDomRestrTo unit unit s s'). + + Lemma in_FSet_inter : (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 : FSet -> FSet -> FSet := [s,s':FSet] (MapDomRestrBy unit unit s s'). + + Lemma in_FSet_diff : (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 : FSet -> FSet -> FSet := [s,s':FSet] (MapDelta unit s s'). + + Lemma in_FSet_delta : (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 : (s:FSet) (MapDom unit s)=s. +Proof. + Induction s. Trivial. + Simpl. Intros a t. Elim t. Reflexivity. + Intros. Simpl. Rewrite H. Rewrite H0. Reflexivity. +Qed. diff --git a/theories7/IntMap/Lsort.v b/theories7/IntMap/Lsort.v new file mode 100644 index 00000000..31b71c62 --- /dev/null +++ b/theories7/IntMap/Lsort.v @@ -0,0 +1,537 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:27 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require Arith. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require PolyList. +Require Mapiter. + +Section LSort. + + Variable A : Set. + + Fixpoint ad_less_1 [a,a':ad; p:positive] : bool := + Cases p of + (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] Cases (ad_xor a a') of + ad_z => false + | (ad_x p) => (ad_less_1 a a' p) + end. + + Lemma ad_bit_0_less : (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. + Rewrite H2. Generalize H2. Elim p. Intros. Simpl. 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. 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 : (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. + Rewrite H2. Generalize H2. Elim p. Intros. Simpl. 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. Rewrite H. Rewrite H0. Reflexivity. + Intro H1. Unfold ad_less. Rewrite H1. Reflexivity. + Qed. + + Lemma ad_less_not_refl : (a:ad) (ad_less a a)=false. + Proof. + Intro. Unfold ad_less. Rewrite (ad_xor_nilpotent a). Reflexivity. + Qed. + + Lemma ad_ind_double : + (a:ad)(P:ad->Prop) (P ad_z) -> + ((a:ad) (P a) -> (P (ad_double a))) -> + ((a:ad) (P a) -> (P (ad_double_plus_un a))) -> (P a). + Proof. + Intros; Elim a. Trivial. + 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 : + (a:ad)(P:ad->Set) (P ad_z) -> + ((a:ad) (P a) -> (P (ad_double a))) -> + ((a:ad) (P a) -> (P (ad_double_plus_un a))) -> (P a). + Proof. + Intros; Elim a. Trivial. + 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 : (a,a':ad) (ad_less (ad_double a) (ad_double a'))=(ad_less a a'). + Proof. + Induction a. Induction a'. Reflexivity. + Trivial. + Induction a'. Unfold ad_less. Simpl. (Elim p; Trivial). + Unfold ad_less. Simpl. Intro. Case (p_xor p p0). Reflexivity. + Trivial. + Qed. + + Lemma ad_less_def_2 : (a,a':ad) + (ad_less (ad_double_plus_un a) (ad_double_plus_un a'))=(ad_less a a'). + Proof. + Induction a. Induction a'. Reflexivity. + Trivial. + Induction a'. Unfold ad_less. Simpl. (Elim p; Trivial). + Unfold ad_less. Simpl. Intro. Case (p_xor p p0). Reflexivity. + Trivial. + Qed. + + Lemma ad_less_def_3 : (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 : (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 : (a:ad) (ad_less a ad_z)=false. + Proof. + Induction a. Reflexivity. + Unfold ad_less. Intro. Rewrite (ad_xor_neutral_right (ad_x p)). (Elim p; Trivial). + Qed. + + Lemma ad_z_less_1 : (a:ad) (ad_less ad_z a)=true -> {p:positive | a=(ad_x p)}. + Proof. + Induction a. Intro. Discriminate H. + Intros. Split with p. Reflexivity. + Qed. + + Lemma ad_z_less_2 : (a:ad) (ad_less ad_z a)=false -> a=ad_z. + Proof. + Induction a. Trivial. + Unfold ad_less. Simpl. Cut (p:positive)(ad_less_1 ad_z (ad_x p) p)=false->False. + Intros. Elim (H p H0). + Induction p. Intros. Discriminate H0. + Intros. Exact (H H0). + Intro. Discriminate H. + Qed. + + Lemma ad_less_trans : (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:=[a:ad] + (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:=[a':ad] + (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:=[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:=[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:=[a':ad] + (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:=[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 := + Cases l of + nil => true + | (cons (a, _) l') => Cases l' of + nil => true + | (cons (a', y') l'') => (andb (ad_less a a') + (alist_sorted l')) + end + end. + + Fixpoint alist_nth_ad [n:nat; l:(alist A)] : ad := + Cases l of + nil => ad_z (* dummy *) + | (cons (a, y) l') => Cases n of + O => a + | (S n') => (alist_nth_ad n' l') + end + end. + + Definition alist_sorted_1 := [l:(alist A)] + (n:nat) (le (S (S n)) (length l)) -> + (ad_less (alist_nth_ad n l) (alist_nth_ad (S n) l))=true. + + Lemma alist_sorted_imp_1 : (l:(alist A)) (alist_sorted l)=true -> (alist_sorted_1 l). + Proof. + Unfold alist_sorted_1. Induction l. Intros. Elim (le_Sn_O (S n) H0). + Intro r. Elim r. Intros a y. Induction l0. Intros. Simpl in H1. + Elim (le_Sn_O n (le_S_n (S n) O H1)). + Intro r0. Elim r0. Intros a0 y0. Induction n. Intros. Simpl. Simpl in H1. + Exact (proj1 ? ? (andb_prop ? ? H1)). + Intros. Change (ad_less (alist_nth_ad n0 (cons (a0,y0) l1)) + (alist_nth_ad (S n0) (cons (a0,y0) l1)))=true. + Apply H0. Exact (proj2 ? ? (andb_prop ? ? H1)). + Apply le_S_n. Exact H3. + Qed. + + Definition alist_sorted_2 := [l:(alist A)] + (m,n:nat) (lt m n) -> (le (S n) (length l)) -> + (ad_less (alist_nth_ad m l) (alist_nth_ad n l))=true. + + Lemma alist_sorted_1_imp_2 : (l:(alist A)) (alist_sorted_1 l) -> (alist_sorted_2 l). + Proof. + Unfold alist_sorted_1 alist_sorted_2 lt. 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_trans_S. + Assumption. + Apply H. Assumption. + Qed. + + Lemma alist_sorted_2_imp : (l:(alist A)) (alist_sorted_2 l) -> (alist_sorted l)=true. + Proof. + Unfold alist_sorted_2 lt. Induction l. Trivial. + Intro r. Elim r. Intros a y. Induction l0. Trivial. + Intro r0. Elim r0. Intros a0 y0. Intros. + Change (andb (ad_less a a0) (alist_sorted (cons (a0,y0) l1)))=true. + Apply andb_true_intro. Split. Apply (H1 (0) (1)). Apply le_n. + Simpl. 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 : (C:Set) (l,l':(list C)) (length (app l l'))=(plus (length l) (length l')). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite (H l'). Reflexivity. + Qed. + + Lemma aapp_length : (l,l':(alist A)) (length (aapp A l l'))=(plus (length l) (length l')). + Proof. + Exact (app_length ad*A). + Qed. + + Lemma alist_nth_ad_aapp_1 : (l,l':(alist A)) (n:nat) + (le (S n) (length l)) -> (alist_nth_ad n (aapp A l l'))=(alist_nth_ad n l). + Proof. + Induction l. Intros. Elim (le_Sn_O n H). + Intro r. Elim r. Intros a y l' H l''. Induction n. Trivial. + Intros. Simpl. Apply H. Apply le_S_n. Exact H1. + Qed. + + Lemma alist_nth_ad_aapp_2 : (l,l':(alist A)) (n:nat) + (le (S n) (length l')) -> + (alist_nth_ad (plus (length l) n) (aapp A l l'))=(alist_nth_ad n l'). + Proof. + Induction l. Trivial. + Intro r. Elim r. Intros a y l' H l'' n H0. Simpl. Apply H. Exact H0. + Qed. + + Lemma interval_split : (p,q,n:nat) (le (S n) (plus p q)) -> + {n' : nat | (le (S n') q) /\ n=(plus p n')}+{(le (S n) p)}. + Proof. + Induction p. Simpl. Intros. Left . Split with n. (Split; [ Assumption | Reflexivity ]). + Intros p' H q. 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 : (l,l':(alist A)) (alist_sorted_2 l) -> (alist_sorted_2 l') -> + ((n,n':nat) (le (S n) (length l)) -> (le (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. 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 (le (plus (S (length l)) m') (plus (length l) n')) in H2. + Rewrite (plus_Snm_nSm (length l) m') in H2. Exact (simpl_le_plus_l (length l) (S m') n' H2). + Exact H10. + Intro H8. Rewrite H7 in H2. Cut (le (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 (plus (length l) m')). + Apply le_trans with m:=(plus (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 : (l:(alist A)) (n:nat) (le (S n) (length l)) -> + {y:A | (alist_semantics A l (alist_nth_ad n l))=(SOME A y)}. + Proof. + Induction l. Intros. Elim (le_Sn_O ? H). + Intro r. Elim r. Intros a y l0 H. Induction n. Simpl. 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. Rewrite (ad_eq_correct (alist_nth_ad n0 l0)). + Reflexivity. + Intro H3. Split with y0. Simpl. Rewrite H3. Assumption. + Qed. + + Lemma alist_of_Map_nth_ad : (m:(Map A)) (pf:ad->ad) + (l:(alist A)) l=(MapFold1 A (alist A) (anil A) (aapp A) + [a0:ad][y:A](acons A (a0,y) (anil A)) pf m) -> + (n:nat) (le (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] (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. Intros. Rewrite ad_less_def_1. Assumption. + Qed. + + Lemma ad_double_plus_un_monotonic : (ad_monotonic ad_double_plus_un). + Proof. + Unfold ad_monotonic. Intros. Rewrite ad_less_def_2. Assumption. + Qed. + + Lemma ad_comp_monotonic : (pf,pf':ad->ad) (ad_monotonic pf) -> (ad_monotonic pf') -> + (ad_monotonic [a0:ad] (pf (pf' a0))). + Proof. + Unfold ad_monotonic. Intros. Apply H. Apply H0. Exact H1. + Qed. + + Lemma ad_comp_double_monotonic : (pf:ad->ad) (ad_monotonic pf) -> + (ad_monotonic [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 : (pf:ad->ad) (ad_monotonic pf) -> + (ad_monotonic [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 : (m:(Map A)) (pf:ad->ad) (ad_monotonic pf) -> + (alist_sorted_2 (MapFold1 A (alist A) (anil A) (aapp A) + [a:ad][y:A](acons A (a,y) (anil A)) pf m)). + Proof. + Induction m. Simpl. Intros. Apply alist_sorted_1_imp_2. Apply alist_sorted_imp_1. Reflexivity. + Intros. Simpl. Apply alist_sorted_1_imp_2. Apply alist_sorted_imp_1. Reflexivity. + Intros. Simpl. Apply alist_conc_sorted. + Exact (H [a0:ad](pf (ad_double a0)) (ad_comp_double_monotonic pf H1)). + Exact (H0 [a0:ad](pf (ad_double_plus_un a0)) (ad_comp_double_plus_un_monotonic pf H1)). + Intros. Elim (alist_of_Map_nth_ad m0 [a0:ad](pf (ad_double a0)) + (MapFold1 A (alist A) (anil A) (aapp A) + [a0:ad][y:A](acons A (a0,y) (anil A)) + [a0:ad](pf (ad_double a0)) m0) (refl_equal ? ?) n H2). + Intros a H4. Rewrite H4. Elim (alist_of_Map_nth_ad m1 [a0:ad](pf (ad_double_plus_un a0)) + (MapFold1 A (alist A) (anil A) (aapp A) + [a0:ad][y:A](acons A (a0,y) (anil A)) + [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 : (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 [a0:ad]a0 [a,a':ad][p:(ad_less a a')=true]p). + Qed. + + Lemma alist_of_Map_sorts1 : (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 : (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 : (a,a':ad) {(ad_less a a')=true}+{(ad_less a' a)=true}+{a=a'}. + Proof. + Intro a. Refine (ad_rec_double a [a:ad] (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' [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' [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 : (l:(alist A)) (a,a':ad) (y:A) + (ad_less a a')=true -> (alist_sorted_2 (cons (a',y) l)) -> + (alist_semantics A (cons (a',y) l) a)=(NONE A). + Proof. + Induction l. Intros. Simpl. 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 (Case (ad_eq a1 a0) of + (SOME A y0) + (alist_semantics A (cons (a,y) l0) a0) + end)=(NONE A). + 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. 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 (cons (a1,y0) (cons (a,y) l0)))=true. Intro H3. + Exact (proj2 ? ? (andb_prop ? ? H3)). + Apply alist_sorted_2_imp. Assumption. + Qed. + + Lemma alist_semantics_nth_ad : (l:(alist A)) (a:ad) (y:A) + (alist_semantics A l a)=(SOME A y) -> + {n:nat | (le (S n) (length l)) /\ (alist_nth_ad n l)=a}. + Proof. + 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 O. Split. Simpl. Apply le_n_S. Apply le_O_n. + Simpl. 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. Apply le_n_S. Exact (proj1 ? ? H2). + Exact (proj2 ? ? H2). + Qed. + + Lemma alist_semantics_tail : (l:(alist A)) (a:ad) (y:A) + (alist_sorted_2 (cons (a,y) l)) -> + (eqm A (alist_semantics A l) [a0:ad] if (ad_eq a a0) + then (NONE A) + else (alist_semantics A (cons (a,y) l) a0)). + Proof. + Unfold eqm. 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) (cons (a,y) l)) (alist_nth_ad (S n) (cons (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. Apply le_n_S. Assumption. + Trivial. + Intro H0. Simpl. Rewrite H0. Reflexivity. + Qed. + + Lemma alist_semantics_same_tail : (l,l':(alist A)) (a:ad) (y:A) + (alist_sorted_2 (cons (a,y) l)) -> (alist_sorted_2 (cons (a,y) l')) -> + (eqm A (alist_semantics A (cons (a,y) l)) (alist_semantics A (cons (a,y) l'))) -> + (eqm A (alist_semantics A l) (alist_semantics A l')). + Proof. + Unfold eqm. 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 : (l:(alist A)) (a:ad) (y:A) + (alist_sorted_2 (cons (a,y) l)) -> (alist_sorted_2 l). + Proof. + Unfold alist_sorted_2. Intros. Apply (H (S m) (S n)). Apply lt_n_S. Assumption. + Simpl. Apply le_n_S. Assumption. + Qed. + + Lemma alist_canonical : (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. Induction l. Induction l'. Trivial. + Intro r. Elim r. Intros a y l0 H H0 H1 H2. Simpl in H0. + Cut (NONE A)=(Case (ad_eq a a) of (SOME A y) + (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. Induction l'. Intros. Simpl in H0. + Cut (Case (ad_eq a a) of (SOME A y) + (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 (cons (a,y) l0) a)=(alist_semantics A (cons (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 (cons (a,y) l0) a')=(alist_semantics A (cons (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 (cons (a,y) l0) a)=(alist_semantics A (cons (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. diff --git a/theories7/IntMap/Map.v b/theories7/IntMap/Map.v new file mode 100644 index 00000000..00ba3f8a --- /dev/null +++ b/theories7/IntMap/Map.v @@ -0,0 +1,786 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:27 herbelin Exp $ i*) + +(** Definition of finite sets as trees indexed by adresses *) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Addr. +Require Adist. +Require 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 : (o:option) {y:A | o=(SOME y)}+{o=NONE}. + Proof. + 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 := + Cases m of + M0 => [a:ad] NONE + | (M1 x y) => [a:ad] + if (ad_eq x a) + then (SOME y) + else NONE + | (M2 m1 m2) => [a:ad] + Cases a of + 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] (a:ad) (g a)=(g' a). + + Lemma newMap_semantics : (eqm (MapGet newMap) [a:ad] NONE). + Proof. + Simpl. Unfold eqm. Trivial. + Qed. + + Lemma MapSingleton_semantics : (a:ad) (y:A) + (eqm (MapGet (MapSingleton a y)) [a':ad] if (ad_eq a a') then (SOME y) else NONE). + Proof. + Simpl. Unfold eqm. Trivial. + Qed. + + Lemma M1_semantics_1 : (a:ad) (y:A) (MapGet (M1 a y) a)=(SOME y). + Proof. + Unfold MapGet. Intros. Rewrite (ad_eq_correct a). Reflexivity. + Qed. + + Lemma M1_semantics_2 : + (a,a':ad) (y:A) (ad_eq a a')=false -> (MapGet (M1 a y) a')=NONE. + Proof. + Intros. Simpl. Rewrite H. Reflexivity. + Qed. + + Lemma Map2_semantics_1 : + (m,m':Map) (eqm (MapGet m) [a:ad] (MapGet (M2 m m') (ad_double a))). + Proof. + Unfold eqm. Induction a; Trivial. + Qed. + + Lemma Map2_semantics_1_eq : (m,m':Map) (f:ad->option) (eqm (MapGet (M2 m m')) f) + -> (eqm (MapGet m) [a:ad] (f (ad_double a))). + Proof. + Unfold eqm. + Intros. + Rewrite <- (H (ad_double a)). + Exact (Map2_semantics_1 m m' a). + Qed. + + Lemma Map2_semantics_2 : + (m,m':Map) (eqm (MapGet m') [a:ad] (MapGet (M2 m m') (ad_double_plus_un a))). + Proof. + Unfold eqm. Induction a; Trivial. + Qed. + + Lemma Map2_semantics_2_eq : (m,m':Map) (f:ad->option) (eqm (MapGet (M2 m m')) f) + -> (eqm (MapGet m') [a:ad] (f (ad_double_plus_un a))). + Proof. + Unfold eqm. + Intros. + Rewrite <- (H (ad_double_plus_un a)). + Exact (Map2_semantics_2 m m' a). + Qed. + + Lemma MapGet_M2_bit_0_0 : (a:ad) (ad_bit_0 a)=false + -> (m,m':Map) (MapGet (M2 m m') a)=(MapGet m (ad_div_2 a)). + Proof. + Induction a; Trivial. Induction p. Intros. Discriminate H0. + Trivial. + Intros. Discriminate H. + Qed. + + Lemma MapGet_M2_bit_0_1 : (a:ad) (ad_bit_0 a)=true + -> (m,m':Map) (MapGet (M2 m m') a)=(MapGet m' (ad_div_2 a)). + Proof. + Induction a. Intros. Discriminate H. + Induction p. Trivial. + Intros. Discriminate H0. + Trivial. + Qed. + + Lemma MapGet_M2_bit_0_if : (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 : (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 : (m,m':Map) (eqm (MapGet (M2 m m')) + [a:ad] Cases (ad_bit_0 a) of + false => (MapGet m (ad_div_2 a)) + | true => (MapGet m' (ad_div_2 a)) + end). + Proof. + Unfold eqm. + Induction a; Trivial. + Induction p; Trivial. + Qed. + + Lemma Map2_semantics_3_eq : (m,m':Map) (f,f':ad->option) + (eqm (MapGet m) f) -> (eqm (MapGet m') f') -> (eqm (MapGet (M2 m m')) + [a:ad] Cases (ad_bit_0 a) of + false => (f (ad_div_2 a)) + | true => (f' (ad_div_2 a)) + end). + Proof. + Unfold eqm. + 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] : Map := + Cases p of + (xO p') => let m = (MapPut1 (ad_div_2 a) y (ad_div_2 a') y' p') in + Cases (ad_bit_0 a) of + false => (M2 m M0) + | true => (M2 M0 m) + end + | _ => Cases (ad_bit_0 a) of + 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 : (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 : (m:Map) (b:bool) (a:ad) + (MapGet (if b then m else m) a)=(MapGet m a). + Proof. + Induction b;Trivial. + Qed. + + Lemma MapGet_M2_bit_0_2 : (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 : (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. + Induction p. Intros. Unfold MapPut1. Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_1. + Intros. Simpl. Rewrite MapGet_M2_bit_0_2. Apply H. Rewrite <- ad_xor_div_2. Rewrite H0. + Reflexivity. + Intros. Unfold MapPut1. Rewrite MapGet_M2_bit_0_2. Apply M1_semantics_1. + Qed. + + Lemma MapPut1_semantics_2 : (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. + Induction p. Intros. Unfold MapPut1. 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. 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. 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 : (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 : (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. + Induction p. Intros. Unfold MapPut1. 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. 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. 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 : (p:positive) (a,a':ad) (y,y':A) + (ad_xor a a')=(ad_x p) + -> (eqm (MapGet (MapPut1 a y a' y' p)) + [a0:ad] if (ad_eq a a0) then (SOME y) + else if (ad_eq a' a0) then (SOME y') else NONE). + Proof. + Unfold eqm. 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' : (p:positive) (a,a':ad) (y,y':A) + (ad_xor a a')=(ad_x p) + -> (eqm (MapGet (MapPut1 a y a' y' p)) + [a0:ad] if (ad_eq a' a0) then (SOME y') + else if (ad_eq a a0) then (SOME y) else NONE). + Proof. + Unfold eqm. 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 := + Cases m of + M0 => M1 + | (M1 a y) => [a':ad; y':A] + Cases (ad_xor a a') of + ad_z => (M1 a' y') + | (ad_x p) => (MapPut1 a y a' y' p) + end + | (M2 m1 m2) => [a:ad; y:A] + Cases a of + 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 : (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 : (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. Intros. Rewrite (ad_xor_nilpotent a). Trivial. + Qed. + + Lemma MapPut_semantics_2_2 : (a,a':ad) (y,y':A) (a0:ad) (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. + Induction a''. Intro. Rewrite (ad_xor_eq ? ? H). Rewrite MapPut_semantics_2_1. + Case (ad_eq a' a0); Trivial. + Intros. Simpl. 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 : (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 : (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. + Induction a. Trivial. + Induction p; Trivial. + Qed. + + Lemma MapPut_semantics : (m:Map) (a:ad) (y:A) + (eqm (MapGet (MapPut m a y)) [a':ad] if (ad_eq a a') then (SOME y) else (MapGet m a')). + Proof. + Unfold eqm. Induction m. Exact MapPut_semantics_1. + Intros. Unfold 2 MapGet. 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 := + Cases m of + M0 => M1 + | (M1 a y) => [a':ad; y':A] + Cases (ad_xor a a') of + ad_z => m + | (ad_x p) => (MapPut1 a y a' y' p) + end + | (M2 m1 m2) => [a:ad; y:A] + Cases a of + 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 : (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. + Induction a. Trivial. + Induction p; Trivial. + Qed. + + Lemma MapPut_behind_as_before_1 : (a,a',a0:ad) (ad_eq a' a0)=false -> + (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. 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 : (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. + 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 : (m:Map) (a:ad) (y:A) + (MapGet (MapPut_behind m a y) a)=(Cases (MapGet m a) of + (SOME y') => (SOME y') + | _ => (SOME y) + end). + Proof. + Induction m. Simpl. Intros. Rewrite (ad_eq_correct a). Reflexivity. + Intros. Elim (ad_sum (ad_xor a a1)). Intro H. Elim H. Intros p H0. Simpl. + Rewrite H0. Rewrite (ad_xor_eq_false a a1 p). Exact (MapPut1_semantics_2 p a a1 a0 y H0). + Assumption. + Intro H. Simpl. 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 : (m:Map) (a:ad) (y:A) + (eqm (MapGet (MapPut_behind m a y)) + [a':ad] Cases (MapGet m a') of + (SOME y') => (SOME y') + | _ => if (ad_eq a a') then (SOME y) else NONE + end). + Proof. + Unfold eqm. 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] Cases m m' of + 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 : (m,m':Map) (eqm (MapGet (makeM2 m m')) (MapGet (M2 m m'))). + Proof. + Unfold eqm. 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. Rewrite (ad_bit_0_1_not_double a H a0). Reflexivity. + Intros m1 m2. Unfold makeM2. Rewrite MapGet_M2_bit_0_1. Reflexivity. + Assumption. + Case m. Intros a0 y. Simpl. 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. Rewrite MapGet_M2_bit_0_1. Reflexivity. + Assumption. + Intros m1 m2 a0 y. Unfold makeM2. Rewrite MapGet_M2_bit_0_1. Reflexivity. + Assumption. + Intros m1 m2. Unfold makeM2. + 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. Rewrite (ad_bit_0_0_not_double_plus_un a H a0). Reflexivity. + Intros m1 m2. Unfold makeM2. Rewrite MapGet_M2_bit_0_0. Reflexivity. + Assumption. + Case m'. Intros a0 y. Simpl. 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. Rewrite MapGet_M2_bit_0_0. Reflexivity. + Assumption. + Intros m1 m2 a0 y. Unfold makeM2. Rewrite MapGet_M2_bit_0_0. Reflexivity. + Assumption. + Intros m1 m2. Unfold makeM2. Exact (MapGet_M2_bit_0_0 a H (M2 m1 m2) m'). + Qed. + + Fixpoint MapRemove [m:Map] : ad -> Map := + Cases m of + M0 => [_:ad] M0 + | (M1 a y) => [a':ad] + Cases (ad_eq a a') of + true => M0 + | false => m + end + | (M2 m1 m2) => [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 : (m:Map) (a:ad) + (eqm (MapGet (MapRemove m a)) [a':ad] if (ad_eq a a') then NONE else (MapGet m a')). + Proof. + Unfold eqm. Induction m. Simpl. Intros. Case (ad_eq a a0); Trivial. + Intros. Simpl. 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)). + 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 := + Cases m of + M0 => O + | (M1 _ _) => (S O) + | (M2 m m') => (plus (MapCard m) (MapCard m')) + end. + + Fixpoint MapMerge [m:Map] : Map -> Map := + Cases m of + M0 => [m':Map] m' + | (M1 a y) => [m':Map] (MapPut_behind m' a y) + | (M2 m1 m2) => [m':Map] Cases m' of + 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 : (m,m':Map) + (eqm (MapGet (MapMerge m m')) + [a0:ad] Cases (MapGet m' a0) of + (SOME y') => (SOME y') + | NONE => (MapGet m a0) + end). + Proof. + Unfold eqm. Induction m. Intros. Simpl. Case (MapGet m' a); Trivial. + Intros. Simpl. Rewrite (MapPut_behind_semantics m' a a0 a1). Reflexivity. + Induction m'. Trivial. + Intros. Unfold MapMerge. 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 := + Cases m of + M0 => [m':Map] m' + | (M1 a y) => [m':Map] Cases (MapGet m' a) of + NONE => (MapPut m' a y) + | _ => (MapRemove m' a) + end + | (M2 m1 m2) => [m':Map] Cases m' of + M0 => m + | (M1 a' y') => Cases (MapGet m a') of + 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 : (m,m':Map) + (eqm (MapGet (MapDelta m m')) (MapGet (MapDelta m' m))). + Proof. + Unfold eqm. Induction m. Induction m'; Reflexivity. + Induction m'. Reflexivity. + Unfold MapDelta. 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. 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. + Induction m'. Reflexivity. + Reflexivity. + Intros. Simpl. 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 : (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. 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 : (m,m':Map) (a:ad) + (MapGet m a)=NONE -> (MapGet m' a)=NONE -> + (MapGet (MapDelta m m') a)=NONE. + Proof. + Induction m. Trivial. + Exact MapDelta_semantics_1_1. + Induction m'. Trivial. + Intros. Rewrite (MapDelta_semantics_comm (M2 m0 m1) (M1 a a0) a1). + Apply MapDelta_semantics_1_1; Trivial. + Intros. Simpl. 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 : (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. 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 : (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. 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 : (m,m':Map) (a:ad) (y:A) + (MapGet m a)=NONE -> (MapGet m' a)=(SOME y) -> + (MapGet (MapDelta m m') a)=(SOME y). + Proof. + Induction m. Trivial. + Exact MapDelta_semantics_2_1. + 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. 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 : (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. 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 : (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. + Induction m. Intros. Discriminate H. + Exact MapDelta_semantics_3_1. + 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. 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 : (m,m':Map) + (eqm (MapGet (MapDelta m m')) + [a0:ad] Cases (MapGet m a0) (MapGet m' a0) of + NONE (SOME y') => (SOME y') + | (SOME y) NONE => (SOME y) + | _ _ => NONE + end). + Proof. + Unfold eqm. 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] + Cases m of + M0 => true + | _ => false + end. + + Lemma MapEmptyp_correct : (MapEmptyp M0)=true. + Proof. + Reflexivity. + Qed. + + Lemma MapEmptyp_complete : (m:Map) (MapEmptyp m)=true -> m=M0. + Proof. + 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. diff --git a/theories7/IntMap/Mapaxioms.v b/theories7/IntMap/Mapaxioms.v new file mode 100644 index 00000000..085afd69 --- /dev/null +++ b/theories7/IntMap/Mapaxioms.v @@ -0,0 +1,670 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Fset. + +Section MapAxioms. + + Variable A, B, C : Set. + + Lemma eqm_sym : (f,f':ad->(option A)) (eqm A f f') -> (eqm A f' f). + Proof. + Unfold eqm. Intros. Rewrite H. Reflexivity. + Qed. + + Lemma eqm_refl : (f:ad->(option A)) (eqm A f f). + Proof. + Unfold eqm. Trivial. + Qed. + + Lemma eqm_trans : (f,f',f'':ad->(option A)) (eqm A f f') -> (eqm A f' f'') -> (eqm A f f''). + Proof. + Unfold eqm. Intros. Rewrite H. Exact (H0 a). + Qed. + + Definition eqmap := [m,m':(Map A)] (eqm A (MapGet A m) (MapGet A m')). + + Lemma eqmap_sym : (m,m':(Map A)) (eqmap m m') -> (eqmap m' m). + Proof. + Intros. Unfold eqmap. Apply eqm_sym. Assumption. + Qed. + + Lemma eqmap_refl : (m:(Map A)) (eqmap m m). + Proof. + Intros. Unfold eqmap. Apply eqm_refl. + Qed. + + Lemma eqmap_trans : (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 : (m:(Map A)) (a:ad) (y:A) + (eqmap (MapPut A m a y) (MapMerge A m (M1 A a y))). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapPut_semantics A m a y a0). + Rewrite (MapMerge_semantics A m (M1 A a y) a0). Unfold 2 MapGet. + Elim (sumbool_of_bool (ad_eq a a0)); Intro H; Rewrite H; Reflexivity. + Qed. + + Lemma MapPut_ext : (m,m':(Map A)) (eqmap m m') -> + (a:ad) (y:A) (eqmap (MapPut A m a y) (MapPut A m' a y)). + Proof. + Unfold eqmap eqm. 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 : (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. 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 : (m,m':(Map A)) (eqmap m m') -> + (a:ad) (y:A) (eqmap (MapPut_behind A m a y) (MapPut_behind A m' a y)). + Proof. + Unfold eqmap eqm. 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 : (m:(Map A)) (MapMerge A (M0 A) m)=m. + Proof. + Trivial. + Qed. + + Lemma MapMerge_empty_m : (m:(Map A)) (eqmap (MapMerge A (M0 A) m) m). + Proof. + Unfold eqmap eqm. Trivial. + Qed. + + Lemma MapMerge_m_empty_1 : (m:(Map A)) (MapMerge A m (M0 A))=m. + Proof. + Induction m;Trivial. + Qed. + + Lemma MapMerge_m_empty : (m:(Map A)) (eqmap (MapMerge A m (M0 A)) m). + Proof. + Unfold eqmap eqm. Intros. Rewrite MapMerge_m_empty_1. Reflexivity. + Qed. + + Lemma MapMerge_empty_l : (m,m':(Map A)) (eqmap (MapMerge A m m') (M0 A)) -> + (eqmap m (M0 A)). + Proof. + Unfold eqmap eqm. 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 : (m,m':(Map A)) (eqmap (MapMerge A m m') (M0 A)) -> + (eqmap m' (M0 A)). + Proof. + Unfold eqmap eqm. 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 : (m,m',m'':(Map A)) (eqmap + (MapMerge A (MapMerge A m m') m'') + (MapMerge A m (MapMerge A m' m''))). + Proof. + Unfold eqmap eqm. 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 : (m:(Map A)) (eqmap (MapMerge A m m) m). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapMerge_semantics A m m a). + Case (MapGet A m a); Trivial. + Qed. + + Lemma MapMerge_ext : (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. 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 : (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 : (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 : (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. 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 : (m:(Map A)) (a:ad) (y:B) + (eqmap (MapRemove A m a) (MapDomRestrBy A B m (M1 B a y))). + Proof. + Unfold eqmap eqm. 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 : (m,m':(Map A)) (eqmap m m') -> + (a:ad) (eqmap (MapRemove A m a) (MapRemove A m' a)). + Proof. + Unfold eqmap eqm. 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 : + (m:(Map B)) (MapDomRestrTo A B (M0 A) m)=(M0 A). + Proof. + Trivial. + Qed. + + Lemma MapDomRestrTo_empty_m : + (m:(Map B)) (eqmap (MapDomRestrTo A B (M0 A) m) (M0 A)). + Proof. + Unfold eqmap eqm. Trivial. + Qed. + + Lemma MapDomRestrTo_m_empty_1 : + (m:(Map A)) (MapDomRestrTo A B m (M0 B))=(M0 A). + Proof. + Induction m;Trivial. + Qed. + + Lemma MapDomRestrTo_m_empty : + (m:(Map A)) (eqmap (MapDomRestrTo A B m (M0 B)) (M0 A)). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapDomRestrTo_m_empty_1 m). Reflexivity. + Qed. + + Lemma MapDomRestrTo_assoc : (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. 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 : (m:(Map A)) (eqmap (MapDomRestrTo A A m m) m). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapDomRestrTo_semantics A A m m a). + Case (MapGet A m a); Trivial. + Qed. + + Lemma MapDomRestrTo_Dom : (m:(Map A)) (m':(Map B)) + (eqmap (MapDomRestrTo A B m m') (MapDomRestrTo A unit m (MapDom B m'))). + Proof. + Unfold eqmap eqm. 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 : + (m:(Map B)) (MapDomRestrBy A B (M0 A) m)=(M0 A). + Proof. + Trivial. + Qed. + + Lemma MapDomRestrBy_empty_m : + (m:(Map B)) (eqmap (MapDomRestrBy A B (M0 A) m) (M0 A)). + Proof. + Unfold eqmap eqm. Trivial. + Qed. + + Lemma MapDomRestrBy_m_empty_1 : (m:(Map A)) (MapDomRestrBy A B m (M0 B))=m. + Proof. + Induction m;Trivial. + Qed. + + Lemma MapDomRestrBy_m_empty : (m:(Map A)) (eqmap (MapDomRestrBy A B m (M0 B)) m). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapDomRestrBy_m_empty_1 m). Reflexivity. + Qed. + + Lemma MapDomRestrBy_Dom : (m:(Map A)) (m':(Map B)) + (eqmap (MapDomRestrBy A B m m') (MapDomRestrBy A unit m (MapDom B m'))). + Proof. + Unfold eqmap eqm. 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 : (m:(Map A)) (eqmap (MapDomRestrBy A A m m) (M0 A)). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapDomRestrBy_semantics A A m m a). + Case (MapGet A m a); Trivial. + Qed. + + Lemma MapDomRestrBy_By : (m:(Map A)) (m':(Map B)) (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. 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 : (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. 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 : (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. 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 : (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. 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 : (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. 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 : (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. 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 : (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. 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 : (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. 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 : (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. 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 : (m:(Map A)) (MapDelta A (M0 A) m)=m. + Proof. + Trivial. + Qed. + + Lemma MapDelta_empty_m : (m:(Map A)) (eqmap (MapDelta A (M0 A) m) m). + Proof. + Unfold eqmap eqm. Trivial. + Qed. + + Lemma MapDelta_m_empty_1 : (m:(Map A)) (MapDelta A m (M0 A))=m. + Proof. + Induction m;Trivial. + Qed. + + Lemma MapDelta_m_empty : (m:(Map A)) (eqmap (MapDelta A m (M0 A)) m). + Proof. + Unfold eqmap eqm. Intros. Rewrite MapDelta_m_empty_1. Reflexivity. + Qed. + + Lemma MapDelta_nilpotent : (m:(Map A)) (eqmap (MapDelta A m m) (M0 A)). + Proof. + Unfold eqmap eqm. Intros. Rewrite (MapDelta_semantics A m m a). + Case (MapGet A m a); Trivial. + Qed. + + Lemma MapDelta_as_Merge : (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. 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 : (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. 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 : (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. 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 : (m,m':(Map A)) (eqmap (MapDelta A m m') (MapDelta A m' m)). + Proof. + Unfold eqmap eqm. 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 : (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. 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 : (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 : (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 : (m:(Map A)) (m':(Map B)) + (eqmap m (MapMerge A (MapDomRestrTo A B m m') (MapDomRestrBy A B m m'))). + Proof. + Unfold eqmap eqm. 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 : (m:(Map A)) (m':(Map B)) + (eqmap m (MapMerge A (MapDomRestrBy A B m m') (MapDomRestrTo A B m m'))). + Proof. + Unfold eqmap eqm. 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 : (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. 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 : (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. 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 : (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 : (A,B:Set) (m1:(Map A)) (m2:(Map B)) (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 : (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. 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 : (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 : (A,B:Set) (m1:(Map A)) (m2:(Map B)) (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 : (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 : (s,s',s'':FSet) + (eqmap unit (MapDelta ? (MapDelta ? s s') s'') (MapDelta ? s (MapDelta ? s' s''))). +Proof. + Unfold eqmap eqm. 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 : (s,s':FSet) ((a:ad) (in_FSet a s)=(in_FSet a s')) -> (eqmap unit s s'). +Proof. + Unfold in_FSet eqmap eqm. 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 : (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_sym. +Qed. + +Lemma FSetUnion_assoc : (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 : (s:FSet) (eqmap unit (FSetUnion (M0 unit) s) s). +Proof. + Exact (MapMerge_empty_m unit). +Qed. + +Lemma FSetUnion_s_M0 : (s:FSet) (eqmap unit (FSetUnion s (M0 unit)) s). +Proof. + Exact (MapMerge_m_empty unit). +Qed. + +Lemma FSetUnion_idempotent : (s:FSet) (eqmap unit (FSetUnion s s) s). +Proof. + Exact (MapMerge_idempotent unit). +Qed. + +Lemma FSetInter_comm : (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_sym. +Qed. + +Lemma FSetInter_assoc : (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 : (s:FSet) (eqmap unit (FSetInter (M0 unit) s) (M0 unit)). +Proof. + Exact (MapDomRestrTo_empty_m unit unit). +Qed. + +Lemma FSetInter_s_M0 : (s:FSet) (eqmap unit (FSetInter s (M0 unit)) (M0 unit)). +Proof. + Exact (MapDomRestrTo_m_empty unit unit). +Qed. + +Lemma FSetInter_idempotent : (s:FSet) (eqmap unit (FSetInter s s) s). +Proof. + Exact (MapDomRestrTo_idempotent unit). +Qed. + +Lemma FSetUnion_Inter_l : (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 : (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 : (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 : (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. diff --git a/theories7/IntMap/Mapc.v b/theories7/IntMap/Mapc.v new file mode 100644 index 00000000..181050b1 --- /dev/null +++ b/theories7/IntMap/Mapc.v @@ -0,0 +1,457 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require Arith. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Mapaxioms. +Require Fset. +Require Mapiter. +Require Mapsubset. +Require PolyList. +Require Lsort. +Require Mapcard. +Require Mapcanon. + +Section MapC. + + Variable A, B, C : Set. + + Lemma MapPut_as_Merge_c : (m:(Map A)) (mapcanon A m) -> + (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 : (m:(Map A)) (mapcanon A m) -> + (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 : (m:(Map A)) (MapMerge A (M0 A) m)=m. + Proof. + Trivial. + Qed. + + Lemma MapMerge_assoc_c : (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 : (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 : (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 : (m:(Map A)) (mapcanon A m) -> + (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 : (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 : (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 : (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 : (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 : (m:(Map A)) (m':(Map B)) (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (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 : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') -> + ((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 : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') -> + (FSetUnion s s')=(FSetUnion s' s). +Proof. + Intros. + Apply (mapcanon_unique unit); Try (Unfold FSetUnion; Apply MapMerge_canon; Assumption). + Apply FSetUnion_comm. +Qed. + +Lemma FSetUnion_assoc_c : (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 : (s:FSet) (FSetUnion (M0 unit) s)=s. +Proof. + Exact (MapMerge_empty_m_c unit). +Qed. + +Lemma FSetUnion_s_M0_c : (s:FSet) (FSetUnion s (M0 unit))=s. +Proof. + Exact (MapMerge_m_empty_1 unit). +Qed. + +Lemma FSetUnion_idempotent : (s:FSet) (mapcanon unit s) -> (FSetUnion s s)=s. +Proof. + Exact (MapMerge_idempotent_c unit). +Qed. + +Lemma FSetInter_comm_c : (s,s':FSet) (mapcanon unit s) -> (mapcanon unit s') -> + (FSetInter s s')=(FSetInter s' s). +Proof. + Intros. + Apply (mapcanon_unique unit); Try (Unfold FSetInter; Apply MapDomRestrTo_canon; Assumption). + Apply FSetInter_comm. +Qed. + +Lemma FSetInter_assoc_c : (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 : (s:FSet) (FSetInter (M0 unit) s)=(M0 unit). +Proof. + Trivial. +Qed. + +Lemma FSetInter_s_M0_c : (s:FSet) (FSetInter s (M0 unit))=(M0 unit). +Proof. + Exact (MapDomRestrTo_m_empty_1 unit unit). +Qed. + +Lemma FSetInter_idempotent : (s:FSet) (mapcanon unit s) -> (FSetInter s s)=s. +Proof. + Exact (MapDomRestrTo_idempotent_c unit). +Qed. + +Lemma FSetUnion_Inter_l_c : (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. (Apply MapMerge_canon; Try Assumption). + Unfold FSetInter. (Apply MapDomRestrTo_canon; Assumption). + Unfold FSetInter; Unfold FSetUnion; Apply MapDomRestrTo_canon; Apply MapMerge_canon; Assumption. + Apply FSetUnion_Inter_l. +Qed. + +Lemma FSetUnion_Inter_r : (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. (Apply MapMerge_canon; Try Assumption). + Unfold FSetInter. (Apply MapDomRestrTo_canon; Assumption). + Unfold FSetInter; Unfold FSetUnion; Apply MapDomRestrTo_canon; Apply MapMerge_canon; Assumption. + Apply FSetUnion_Inter_r. +Qed. + +Lemma FSetInter_Union_l_c : (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. + Apply MapDomRestrTo_canon; Try Assumption. Unfold FSetUnion. + Apply MapMerge_canon; Assumption. + Unfold FSetUnion; Unfold FSetInter; Apply MapMerge_canon; Apply MapDomRestrTo_canon; + Assumption. + Apply FSetInter_Union_l. +Qed. + +Lemma FSetInter_Union_r : (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. + Apply MapDomRestrTo_canon; Try Assumption. + Unfold FSetUnion. Apply MapMerge_canon; Unfold FSetInter; Apply MapDomRestrTo_canon; Assumption. + Apply FSetInter_Union_r. +Qed. diff --git a/theories7/IntMap/Mapcanon.v b/theories7/IntMap/Mapcanon.v new file mode 100644 index 00000000..7beb1fd4 --- /dev/null +++ b/theories7/IntMap/Mapcanon.v @@ -0,0 +1,376 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require Arith. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Mapaxioms. +Require Mapiter. +Require Fset. +Require PolyList. +Require Lsort. +Require Mapsubset. +Require Mapcard. + +Section MapCanon. + + Variable A : Set. + + Inductive mapcanon : (Map A) -> Prop := + M0_canon : (mapcanon (M0 A)) + | M1_canon : (a:ad) (y:A) (mapcanon (M1 A a y)) + | M2_canon : (m1,m2:(Map A)) (mapcanon m1) -> (mapcanon m2) -> + (le (2) (MapCard A (M2 A m1 m2))) -> (mapcanon (M2 A m1 m2)). + + Lemma mapcanon_M2 : + (m1,m2:(Map A)) (mapcanon (M2 A m1 m2)) -> (le (2) (MapCard A (M2 A m1 m2))). + Proof. + Intros. Inversion H. Assumption. + Qed. + + Lemma mapcanon_M2_1 : (m1,m2:(Map A)) (mapcanon (M2 A m1 m2)) -> (mapcanon m1). + Proof. + Intros. Inversion H. Assumption. + Qed. + + Lemma mapcanon_M2_2 : (m1,m2:(Map A)) (mapcanon (M2 A m1 m2)) -> (mapcanon m2). + Proof. + Intros. Inversion H. Assumption. + Qed. + + Lemma M2_eqmap_1 : (m0,m1,m2,m3:(Map A)) + (eqmap A (M2 A m0 m1) (M2 A m2 m3)) -> (eqmap A m0 m2). + Proof. + Unfold eqmap eqm. 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 : (m0,m1,m2,m3:(Map A)) + (eqmap A (M2 A m0 m1) (M2 A m2 m3)) -> (eqmap A m1 m3). + Proof. + Unfold eqmap eqm. 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 : (m,m':(Map A)) (mapcanon m) -> (mapcanon m') -> + (eqmap A m m') -> m=m'. + Proof. + Induction m. Induction m'. Trivial. + Intros a y H H0 H1. Cut (NONE A)=(MapGet A (M1 A a y) a). Simpl. Rewrite (ad_eq_correct a). + Intro. Discriminate H2. + Exact (H1 a). + Intros. Cut (le (2) (MapCard A (M0 A))). Intro. Elim (le_Sn_O ? H4). + Rewrite (MapCard_ext A ? ? H3). Exact (mapcanon_M2 ? ? H2). + Intros a y. Induction m'. Intros. Cut (MapGet A (M1 A a y) a)=(NONE A). Simpl. + 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. + 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 (le (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). + Induction m'. Intros. Cut (le (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 (le (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 : + (p:positive) (a,a':ad) (y,y':A) (mapcanon (MapPut1 A a y a' y' p)). + Proof. + Induction p. Simpl. 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. Intros. Case (ad_bit_0 a). Apply M2_canon. Apply M0_canon. + Apply H. + Simpl. Rewrite MapCard_Put1_equals_2. Apply le_n. + Apply M2_canon. Apply H. + Apply M0_canon. + Simpl. Rewrite MapCard_Put1_equals_2. Apply le_n. + Simpl. Simpl. Intros. Case (ad_bit_0 a). Apply M2_canon. Apply M1_canon. + Apply M1_canon. + Simpl. Apply le_n. + Apply M2_canon. Apply M1_canon. + Apply M1_canon. + Simpl. Apply le_n. + Qed. + + Lemma MapPut_canon : + (m:(Map A)) (mapcanon m) -> (a:ad) (y:A) (mapcanon (MapPut A m a y)). + Proof. + Induction m. Intros. Simpl. Apply M1_canon. + Intros a0 y0 H a y. Simpl. Case (ad_xor a0 a). Apply M1_canon. + Intro. Apply MapPut1_canon. + Intros. Simpl. Elim a. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1). + Exact (mapcanon_M2_2 m0 m1 H1). + Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). Exact (mapcanon_M2 ? ? H1). + Apply le_plus_plus. 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. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). + Exact (mapcanon_M2 m0 m1 H1). + Apply le_reg_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. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). + Exact (mapcanon_M2 m0 m1 H1). + Apply le_reg_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. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). + Exact (mapcanon_M2 m0 m1 H1). + Apply le_reg_l. Exact (MapCard_Put_lb A m1 ad_z y). + Qed. + + Lemma MapPut_behind_canon : (m:(Map A)) (mapcanon m) -> + (a:ad) (y:A) (mapcanon (MapPut_behind A m a y)). + Proof. + Induction m. Intros. Simpl. Apply M1_canon. + Intros a0 y0 H a y. Simpl. Case (ad_xor a0 a). Apply M1_canon. + Intro. Apply MapPut1_canon. + Intros. Simpl. Elim a. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 m0 m1 H1). + Exact (mapcanon_M2_2 m0 m1 H1). + Simpl. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). Exact (mapcanon_M2 ? ? H1). + Apply le_plus_plus. 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. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). + Exact (mapcanon_M2 m0 m1 H1). + Apply le_reg_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. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). + Exact (mapcanon_M2 m0 m1 H1). + Apply le_reg_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. Apply le_trans with m:=(plus (MapCard A m0) (MapCard A m1)). + Exact (mapcanon_M2 m0 m1 H1). + Apply le_reg_l. Rewrite MapCard_Put_behind_Put. Exact (MapCard_Put_lb A m1 ad_z y). + Qed. + + Lemma makeM2_canon : + (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. (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. (Apply M2_canon; Try Assumption). Apply le_n. + Intros. Simpl. (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. 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) := + Cases m of + (M2 m0 m1) => (makeM2 A (MapCanonicalize m0) (MapCanonicalize m1)) + | _ => m + end. + + Lemma mapcanon_exists_1 : (m:(Map A)) (eqmap A m (MapCanonicalize m)). + Proof. + Induction m. Apply eqmap_refl. + Intros. Apply eqmap_refl. + Intros. Simpl. Unfold eqmap eqm. 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 : (m:(Map A)) (mapcanon (MapCanonicalize m)). + Proof. + Induction m. Apply M0_canon. + Intros. Simpl. Apply M1_canon. + Intros. Simpl. (Apply makeM2_canon; Assumption). + Qed. + + Lemma mapcanon_exists : + (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 : + (m:(Map A)) (mapcanon m) -> (a:ad) (mapcanon (MapRemove A m a)). + Proof. + Induction m. Intros. Exact M0_canon. + Intros a y H a0. Simpl. Case (ad_eq a a0). Exact M0_canon. + Assumption. + Intros. Simpl. 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 : (m,m':(Map A)) (mapcanon m) -> (mapcanon m') -> + (mapcanon (MapMerge A m m')). + Proof. + Induction m. Intros. Exact H0. + Simpl. Intros a y m' H H0. Exact (MapPut_behind_canon m' H0 a y). + Induction m'. Intros. Exact H1. + Intros a y H1 H2. Unfold MapMerge. Exact (MapPut_canon ? H1 a y). + Intros. Simpl. 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 (le (2) (MapCard A (MapMerge A (M2 A m0 m1) (M2 A m2 m3)))). + 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 : (m,m':(Map A)) (mapcanon m) -> (mapcanon m') -> + (mapcanon (MapDelta A m m')). + Proof. + Induction m. Intros. Exact H0. + Simpl. 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). + Induction m'. Intros. Exact H1. + Unfold MapDelta. 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. 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 : (m:(Map A)) (mapcanon m) -> + (m':(Map B)) (mapcanon (MapDomRestrTo A B m m')). + Proof. + Induction m. Intros. Exact M0_canon. + Simpl. Intros a y H m'. Case (MapGet B m' a). Exact M0_canon. + Intro. Apply M1_canon. + Induction m'. Exact M0_canon. + Unfold MapDomRestrTo. Intros a y. Case (MapGet A (M2 A m0 m1) a). Exact M0_canon. + Intro. Apply M1_canon. + Intros. Simpl. 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 : (m:(Map A)) (mapcanon m) -> + (m':(Map B)) (mapcanon (MapDomRestrBy A B m m')). + Proof. + Induction m. Intros. Exact M0_canon. + Simpl. Intros a y H m'. Case (MapGet B m' a). Assumption. + Intro. Exact M0_canon. + Induction m'. Exact H1. + Intros a y. Simpl. 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. Apply makeM2_canon. Apply H. Exact (mapcanon_M2_1 ? ? H1). + Apply H0. Exact (mapcanon_M2_2 ? ? H1). + Qed. + + Lemma Map_of_alist_canon : (l:(alist A)) (mapcanon (Map_of_alist A l)). + Proof. + Induction l. Exact M0_canon. + Intro r. Elim r. Intros a y l0 H. Simpl. Apply MapPut_canon. Assumption. + Qed. + + Lemma MapSubset_c_1 : (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 : (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. Rewrite H. Apply eqmap_refl. + Qed. + +End MapCanon. + +Section FSetCanon. + + Variable A : Set. + + Lemma MapDom_canon : (m:(Map A)) (mapcanon A m) -> (mapcanon unit (MapDom A m)). + Proof. + Induction m. Intro. Exact (M0_canon unit). + Intros a y H. Exact (M1_canon unit a ?). + Intros. Simpl. Apply M2_canon. Apply H. Exact (mapcanon_M2_1 A ? ? H1). + Apply H0. Exact (mapcanon_M2_2 A ? ? H1). + Change (le (2) (MapCard unit (MapDom A (M2 A m0 m1)))). Rewrite <- MapCard_Dom. + Exact (mapcanon_M2 A ? ? H1). + Qed. + +End FSetCanon. + +Section MapFoldCanon. + + Variable A, B : Set. + + Lemma MapFold_canon_1 : (m0:(Map B)) (mapcanon B m0) -> + (op : (Map B) -> (Map B) -> (Map B)) + ((m1:(Map B)) (mapcanon B m1) -> (m2:(Map B)) (mapcanon B m2) -> + (mapcanon B (op m1 m2))) -> + (f : ad->A->(Map B)) ((a:ad) (y:A) (mapcanon B (f a y))) -> + (m:(Map A)) (pf : ad->ad) (mapcanon B (MapFold1 A (Map B) m0 op f pf m)). + Proof. + Induction m. Intro. Exact H. + Intros a y pf. Simpl. Apply H1. + Intros. Simpl. Apply H0. Apply H2. + Apply H3. + Qed. + + Lemma MapFold_canon : (m0:(Map B)) (mapcanon B m0) -> + (op : (Map B) -> (Map B) -> (Map B)) + ((m1:(Map B)) (mapcanon B m1) -> (m2:(Map B)) (mapcanon B m2) -> + (mapcanon B (op m1 m2))) -> + (f : ad->A->(Map B)) ((a:ad) (y:A) (mapcanon B (f a y))) -> + (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 [a:ad]a). + Qed. + + Lemma MapCollect_canon : + (f : ad->A->(Map B)) ((a:ad) (y:A) (mapcanon B (f a y))) -> + (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. diff --git a/theories7/IntMap/Mapcard.v b/theories7/IntMap/Mapcard.v new file mode 100644 index 00000000..5c5e2a93 --- /dev/null +++ b/theories7/IntMap/Mapcard.v @@ -0,0 +1,670 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require Arith. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Mapaxioms. +Require Mapiter. +Require Fset. +Require Mapsubset. +Require PolyList. +Require Lsort. +Require Peano_dec. + +Section MapCard. + + Variable A, B : Set. + + Lemma MapCard_M0 : (MapCard A (M0 A))=O. + Proof. + Trivial. + Qed. + + Lemma MapCard_M1 : (a:ad) (y:A) (MapCard A (M1 A a y))=(1). + Proof. + Trivial. + Qed. + + Lemma MapCard_is_O : (m:(Map A)) (MapCard A m)=O -> + (a:ad) (MapGet A m a)=(NONE A). + Proof. + 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 : (m:(Map A)) (a:ad) (y:A) (MapGet A m a)=(SOME A y) -> + {n:nat | (MapCard A m)=(S n)}. + Proof. + 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 O. + 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. Rewrite H3. Split with (plus (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. Rewrite H3. Split with (plus n (MapCard A m1)). Reflexivity. + Qed. + + Lemma MapCard_is_one : (m:(Map A)) (MapCard A m)=(1) -> + {a:ad & {y:A | (MapGet A m a)=(SOME A y)}}. + Proof. + 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 : (m:(Map A)) (MapCard A m)=(1) -> (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. + 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 : (C:Set) (l:(list C)) + (length l)=(fold_right [_:C][n:nat](S n) O l). + Proof. + Induction l. Reflexivity. + Intros. Simpl. Rewrite H. Reflexivity. + Qed. + + Lemma length_as_fold_2 : (l:(alist A)) + (length l)=(fold_right [r:ad*A][n:nat]let (a,y)=r in (plus (1) n) O l). + Proof. + Induction l. Reflexivity. + Intros. Simpl. Rewrite H. (Elim a; Reflexivity). + Qed. + + Lemma MapCard_as_Fold_1 : (m:(Map A)) (pf:ad->ad) + (MapCard A m)=(MapFold1 A nat O plus [_:ad][_:A](1) pf m). + Proof. + Induction m. Trivial. + Trivial. + Intros. Simpl. Rewrite <- (H [a0:ad](pf (ad_double a0))). + Rewrite <- (H0 [a0:ad](pf (ad_double_plus_un a0))). Reflexivity. + Qed. + + Lemma MapCard_as_Fold : + (m:(Map A)) (MapCard A m)=(MapFold A nat O plus [_:ad][_:A](1) m). + Proof. + Intro. Exact (MapCard_as_Fold_1 m [a0:ad]a0). + Qed. + + Lemma MapCard_as_length : (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:=O f:=[_:ad][_:A](1). Exact plus_assoc_r. + Trivial. + Intro. Rewrite <- plus_n_O. Reflexivity. + Qed. + + Lemma MapCard_Put1_equals_2 : (p:positive) (a,a':ad) (y,y':A) + (MapCard A (MapPut1 A a y a' y' p))=(2). + Proof. + Induction p. Intros. Simpl. (Case (ad_bit_0 a); Reflexivity). + Intros. Simpl. Case (ad_bit_0 a). Exact (H (ad_div_2 a) (ad_div_2 a') y y'). + Simpl. Rewrite <- plus_n_O. Exact (H (ad_div_2 a) (ad_div_2 a') y y'). + Intros. Simpl. (Case (ad_bit_0 a); Reflexivity). + Qed. + + Lemma MapCard_Put_sum : (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. + Induction m. Simpl. 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 : (m:(Map A)) (a:ad) (y:A) + (ge (MapCard A (MapPut A m a y)) (MapCard A m)). + Proof. + Unfold ge. 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 : (m:(Map A)) (a:ad) (y:A) + (le (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 : (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. + 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 (simpl_plus_l ? ? ? 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_sym (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) in H1. + Rewrite (plus_sym (MapCard A m0) (MapCard A m1)) in H1. + Elim (H (ad_div_2 a) y (simpl_plus_l ? ? ? 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 : (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. + 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 simpl_plus_l with n:=(MapCard A m0). + Rewrite <- (plus_Snm_nSm (MapCard A m0) (MapCard A m1)). Simpl in H1. Simpl. Rewrite <- H1. + Clear H1. + NewInduction a. Discriminate H2. + NewInduction 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 (plus (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) + =(plus (S (MapCard A m0)) (MapCard A m1)). + Intro. Rewrite (plus_sym (MapCard A (MapPut A m0 (ad_div_2 a) y)) (MapCard A m1)) in H3. + Rewrite (plus_sym (S (MapCard A m0)) (MapCard A m1)) in H3. Exact (simpl_plus_l ? ? ? H3). + Simpl. Simpl in H1. Rewrite <- H1. NewInduction a. Trivial. + NewInduction p. Discriminate H2. + Reflexivity. + Discriminate H2. + Qed. + + Lemma MapCard_Put_1_conv : (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 : (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 : (m,m':(Map A)) + (eqm A (MapGet A m) (MapGet A m')) -> (MapCard A m)=(MapCard A m'). + Proof. + Unfold eqm. 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. 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 : (m:(Map A)) (MapCard A m)=(MapCard unit (MapDom A m)). + Proof. + (Induction m; Trivial). Intros. Simpl. Rewrite H. Rewrite H0. Reflexivity. + Qed. + + Lemma MapCard_Dom_Put_behind : (m:(Map A)) (a:ad) (y:A) + (MapDom A (MapPut_behind A m a y))=(MapDom A (MapPut A m a y)). + Proof. + Induction m. Trivial. + Intros a y a0 y0. Simpl. 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. Elim (ad_sum a). Intro H1. Elim H1. Intros p H2. Rewrite H2. Case p. + Intro p0. Simpl. Rewrite H0. Reflexivity. + Intro p0. Simpl. Rewrite H. Reflexivity. + Simpl. Rewrite H0. Reflexivity. + Intro H1. Rewrite H1. Simpl. Rewrite H. Reflexivity. + Qed. + + Lemma MapCard_Put_behind_Put : (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 : (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 : (m,m':(Map A)) + (MapCard A (makeM2 A m m'))=(plus (MapCard A m) (MapCard A m')). + Proof. + Intros. Rewrite (MapCard_ext ? ? (makeM2_M2 A m m')). Reflexivity. + Qed. + + Lemma MapCard_Remove_sum : (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. + Induction m. Simpl. Intros. Rewrite H in H1. Simpl in H1. Left . Rewrite H1. Assumption. + Simpl. 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 : (m:(Map A)) (a:ad) + (le (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 : (m:(Map A)) (a:ad) + (ge (S (MapCard A (MapRemove A m a))) (MapCard A m)). + Proof. + Unfold ge. 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 : (m:(Map A)) (a:ad) + (MapCard A (MapRemove A m a))=(MapCard A m) -> (MapGet A m a)=(NONE A). + Proof. + Induction m. Trivial. + Simpl. 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 (simpl_plus_l ? ? ? 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_sym (MapCard A (MapRemove A m0 (ad_div_2 a))) (MapCard A m1)) in H1. + Rewrite (plus_sym (MapCard A m0) (MapCard A m1)) in H1. Exact (simpl_plus_l ? ? ? H1). + Qed. + + Lemma MapCard_Remove_2 : (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. + 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 (plus (S (MapCard A m0)) (MapCard A (MapRemove A m1 (ad_div_2 a)))) + =(plus (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 (simpl_plus_l ? ? ? 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 (plus (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1)) + =(plus (MapCard A m0) (MapCard A m1)) in H1. + Rewrite (plus_sym (S (MapCard A (MapRemove A m0 (ad_div_2 a)))) (MapCard A m1)) in H1. + Rewrite (plus_sym (MapCard A m0) (MapCard A m1)) in H1. Exact (simpl_plus_l ? ? ? H1). + Qed. + + Lemma MapCard_Remove_1_conv : (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 : (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 : (m,m':(Map A)) + (plus (MapCard A m) (MapCard A m'))= + (plus (MapCard A (MapMerge A m m')) (MapCard A (MapDomRestrTo A A m m'))). + Proof. + Induction m. Simpl. Intro. Apply plus_n_O. + Simpl. 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. 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 (plus (plus (MapCard A m0) (MapCard A m1)) (MapCard A m')) + =(plus (MapCard A (MapMerge A (M2 A m0 m1) m')) + (MapCard A (MapDomRestrTo A A (M2 A m0 m1) m'))). + Elim m'. Reflexivity. + Intros a y. Unfold MapMerge. Unfold MapDomRestrTo. + 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. + Rewrite <- (plus_Snm_nSm (plus (MapCard A m0) (MapCard A m1)) O). Reflexivity. + Intros. Simpl. + 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 : (m,m':(Map A)) (MapDisjoint A A m m') -> + (MapCard A (MapMerge A m m'))=(plus (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 : (m:(Map A)) (m':(Map B)) + (MapCard A m)=(plus (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. Apply MapDom_Split_3. + Qed. + + Lemma MapMerge_Card_ub : (m,m':(Map A)) + (le (MapCard A (MapMerge A m m')) (plus (MapCard A m) (MapCard A m'))). + Proof. + Intros. Rewrite MapMerge_Restr_Card. Apply le_plus_l. + Qed. + + Lemma MapDomRestrTo_Card_ub_l : (m:(Map A)) (m':(Map B)) + (le (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 : (m:(Map A)) (m':(Map B)) + (le (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 : (m,m':(Map A)) + (MapCard A (MapMerge A m m'))=(plus (MapCard A m) (MapCard A m')) -> + (MapDisjoint A A m m'). + Proof. + Induction m. Intros. Apply Map_M0_disjoint. + Simpl. Intros. Rewrite (MapCard_Put_behind_Put m' a a0) in H. Unfold MapDisjoint in_dom. + Simpl. 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. + 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 3 MapCard in H1. Rewrite <- (plus_Snm_nSm (MapCard A (M2 A m0 m1)) O) in H1. + Rewrite <- (plus_n_O (S (MapCard A (M2 A m0 m1)))) in H1. Unfold MapDisjoint in_dom. + Unfold 2 MapGet. 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. 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 simpl_le_plus_l with p:=(plus (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))) + =(plus (plus (MapCard A m0) (MapCard A m1)) (plus (MapCard A m2) (MapCard A m3))) in H3. + Rewrite <- H3. Simpl. Apply le_reg_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. 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. 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 simpl_le_plus_l with p:=(plus (MapCard A m1) (MapCard A m3)). + Rewrite (plus_sym (plus (MapCard A m1) (MapCard A m3)) (plus (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_sym (plus (MapCard A m1) (MapCard A m3)) (MapCard A (MapMerge A m0 m2))). + Change (plus (MapCard A (MapMerge A m0 m2)) (MapCard A (MapMerge A m1 m3))) + =(plus (plus (MapCard A m0) (MapCard A m1)) (plus (MapCard A m2) (MapCard A m3))) in H3. + Rewrite <- H3. Apply le_reg_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. 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. Rewrite H7. Reflexivity. + Qed. + + Lemma MapCard_is_Sn : (m:(Map A)) (n:nat) (MapCard ? m)=(S n) -> + {a:ad | (in_dom ? a m)=true}. + Proof. + Induction m. Intros. Discriminate H. + Intros a y n H. Split with a. Unfold in_dom. 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. + 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. + 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. + + Variable A, B : Set. + + Lemma MapSubset_card_eq_1 : (n:nat) (m:(Map A)) (m':(Map B)) + (MapSubset ? ? m m') -> (MapCard ? m)=n -> (MapCard ? m')=n -> + (MapSubset ? ? m' m). + Proof. + Induction n. Intros. Unfold MapSubset in_dom. 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. 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. 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 : (m:(Map A)) (m':(Map B)) + (le (MapCard A (MapDomRestrTo A B m m')) (MapCard B m')). + Proof. + Induction m. Intro. Simpl. Apply le_O_n. + Intros a y m'. Simpl. 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. + Apply le_n_S. Apply le_O_n. + Intro H. Rewrite H. Simpl. Apply le_O_n. + Induction m'. Simpl. Apply le_O_n. + + Intros a y. Unfold MapDomRestrTo. Case (MapGet A (M2 A m0 m1) a). Simpl. Apply le_O_n. + Intro. Simpl. Apply le_n. + Intros. Simpl. Rewrite (MapCard_makeM2 A (MapDomRestrTo A B m0 m2) (MapDomRestrTo A B m1 m3)). + Apply le_plus_plus. Apply H. + Apply H0. + Qed. + +End MapCard2. + +Section MapCard3. + + Variable A, B : Set. + + Lemma MapMerge_Card_lb_l : (m,m':(Map A)) + (ge (MapCard A (MapMerge A m m')) (MapCard A m)). + Proof. + Unfold ge. Intros. Apply (simpl_le_plus_l (MapCard A m')). + Rewrite (plus_sym (MapCard A m') (MapCard A m)). + Rewrite (plus_sym (MapCard A m') (MapCard A (MapMerge A m m'))). + Rewrite (MapMerge_Restr_Card A m m'). Apply le_reg_l. Apply MapDomRestrTo_Card_ub_r. + Qed. + + Lemma MapMerge_Card_lb_r : (m,m':(Map A)) + (ge (MapCard A (MapMerge A m m')) (MapCard A m')). + Proof. + Unfold ge. Intros. Apply (simpl_le_plus_l (MapCard A m)). Rewrite (MapMerge_Restr_Card A m m'). + Rewrite (plus_sym (MapCard A (MapMerge A m m')) (MapCard A (MapDomRestrTo A A m m'))). + Apply le_reg_r. Apply MapDomRestrTo_Card_ub_l. + Qed. + + Lemma MapDomRestrBy_Card_lb : (m:(Map A)) (m':(Map B)) + (ge (plus (MapCard B m') (MapCard A (MapDomRestrBy A B m m'))) (MapCard A m)). + Proof. + Unfold ge. Intros. Rewrite (MapSplit_Card A B m m'). Apply le_reg_r. + Apply MapDomRestrTo_Card_ub_r. + Qed. + + Lemma MapSubset_Card_le : (m:(Map A)) (m':(Map B)) + (MapSubset A B m m') -> (le (MapCard A m) (MapCard B m')). + Proof. + Intros. Apply le_trans with m:=(plus (MapCard B m') (MapCard A (MapDomRestrBy A B m m'))). + Exact (MapDomRestrBy_Card_lb m m'). + Rewrite (MapCard_ext ? ? ? (MapSubset_imp_2 ? ? ? ? H)). Simpl. Rewrite <- plus_n_O. + Apply le_n. + Qed. + + Lemma MapSubset_card_eq : (m:(Map A)) (m':(Map B)) + (MapSubset ? ? m m') -> (le (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. diff --git a/theories7/IntMap/Mapfold.v b/theories7/IntMap/Mapfold.v new file mode 100644 index 00000000..8061f253 --- /dev/null +++ b/theories7/IntMap/Mapfold.v @@ -0,0 +1,381 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Fset. +Require Mapaxioms. +Require Mapiter. +Require Lsort. +Require Mapsubset. +Require PolyList. + +Section MapFoldResults. + + Variable A : Set. + + Variable M : Set. + Variable neutral : M. + Variable op : M -> M -> M. + + Variable nleft : (a:M) (op neutral a)=a. + Variable nright : (a:M) (op a neutral)=a. + Variable assoc : (a,b,c:M) (op (op a b) c)=(op a (op b c)). + + Lemma MapFold_ext : (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 : (m:(Map A)) (f,g:ad->A->M) (pf:ad->ad) + ((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. + Induction m. Trivial. + Simpl. Intros. Apply H. Rewrite (ad_eq_correct a). Reflexivity. + Intros. Simpl. Rewrite (H f g [a0:ad](pf (ad_double a0))). + Rewrite (H0 f g [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 : (f,g:ad->A->M) (m:(Map A)) + ((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 [a0:ad]a0 H). + Qed. + + Lemma MapFold1_as_Fold_1 : (m:(Map A)) (f,f':ad->A->M) (pf, pf':ad->ad) + ((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. + Induction m. Trivial. + Intros. Simpl. Apply H. + Intros. Simpl. + Rewrite (H f f' [a0:ad](pf (ad_double a0)) [a0:ad](pf' (ad_double a0))). + Rewrite (H0 f f' [a0:ad](pf (ad_double_plus_un a0)) [a0:ad](pf' (ad_double_plus_un a0))). + Reflexivity. + Intros. Apply H1. + Intros. Apply H1. + Qed. + + Lemma MapFold1_as_Fold : (f:ad->A->M) (pf:ad->ad) (m:(Map A)) + (MapFold1 ? ? neutral op f pf m)=(MapFold ? ? neutral op [a:ad][y:A] (f (pf a) y) m). + Proof. + Intros. Unfold MapFold. Apply MapFold1_as_Fold_1. Trivial. + Qed. + + Lemma MapFold1_ext : (f:ad->A->M) (m,m':(Map A)) (eqmap A m m') -> (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 : (a,b:M) (op a b)=(op b a). + + Lemma MapFold_Put_disjoint_1 : (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. + Induction p. Intros. Simpl. Elim (sumbool_of_bool (ad_bit_0 a1)). Intro H1. Rewrite H1. + Simpl. Rewrite ad_div_2_double_plus_un. Rewrite ad_div_2_double. Apply comm. + Change (ad_bit_0 a2)=(negb true). Rewrite <- H1. Rewrite (ad_neg_bit_0_2 ? ? ? H0). + Rewrite negb_elim. Reflexivity. + Assumption. + Intro H1. Rewrite H1. Simpl. Rewrite ad_div_2_double. Rewrite ad_div_2_double_plus_un. + Reflexivity. + Change (ad_bit_0 a2)=(negb false). Rewrite <- H1. Rewrite (ad_neg_bit_0_2 ? ? ? H0). + Rewrite negb_elim. Reflexivity. + Assumption. + Simpl. Intros. Elim (sumbool_of_bool (ad_bit_0 a1)). Intro H1. Rewrite H1. Simpl. + Rewrite nleft. + Rewrite (H f [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. Rewrite nright. + Rewrite (H f [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. Elim (sumbool_of_bool (ad_bit_0 a1)). Intro H0. Rewrite H0. Simpl. + Rewrite ad_div_2_double. Rewrite ad_div_2_double_plus_un. Apply comm. + Assumption. + Change (ad_bit_0 a2)=(negb true). Rewrite <- H0. Rewrite (ad_neg_bit_0_1 ? ? H). + Rewrite negb_elim. Reflexivity. + Intro H0. Rewrite H0. Simpl. Rewrite ad_div_2_double. Rewrite ad_div_2_double_plus_un. + Reflexivity. + Change (ad_bit_0 a2)=(negb false). Rewrite <- H0. Rewrite (ad_neg_bit_0_1 ? ? H). + Rewrite negb_elim. Reflexivity. + Assumption. + Qed. + + Lemma MapFold_Put_disjoint_2 : + (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. + Induction m. Intros. Simpl. Rewrite (nright (f (pf a) y)). Reflexivity. + Intros a1 y1 a2 y2 pf H. Simpl. 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. Rewrite (H0 (ad_div_2 a) y [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 [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. 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. Rewrite (H (ad_div_2 a) y [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. 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 : + (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 [a0:ad]a0 H). + Qed. + + Lemma MapFold_Put_behind_disjoint_2 : + (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. Unfold in_dom. Simpl. 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. Unfold in_dom. Simpl. 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 : + (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 [a0:ad]a0 H). + Qed. + + Lemma MapFold_Merge_disjoint_1 : + (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. + Induction m1. Simpl. Intros. Rewrite nleft. Reflexivity. + Intros. Unfold MapMerge. Apply (MapFold_Put_behind_disjoint_2 f m2 a a0 pf). + Apply in_dom_none. Exact (MapDisjoint_M1_l ? ? m2 a a0 H). + Induction m2. Intros. Simpl. Rewrite nright. Reflexivity. + Intros. Unfold MapMerge. 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. Rewrite (H m3 [a0:ad](pf (ad_double a0))). + Rewrite (H0 m4 [a0:ad](pf (ad_double_plus_un a0))). + Cut (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 : + (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 [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 : (c:N)(times neutral c)=neutral'. + Variable distr : (a,b:M) (c:N) (times (op a b) c) = (op' (times a c) (times b c)). + + Lemma MapFold_distr_r_1 : (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' [a:ad][y:A] (times (f a y) c) pf m). + Proof. + Induction m. Intros. Exact (absorb c). + Trivial. + Intros. Simpl. Rewrite distr. Rewrite H. Rewrite H0. Reflexivity. + Qed. + + Lemma MapFold_distr_r : (f:ad->A->M) (m:(Map A)) (c:N) + (times (MapFold A M neutral op f m) c)= + (MapFold A M' neutral' op' [a:ad][y:A] (times (f a y) c) m). + Proof. + Intros. Exact (MapFold_distr_r_1 f m c [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 : (c:N)(times c neutral)=neutral'. + Variable distr : (a,b:M) (c:N) (times c (op a b)) = (op' (times c a) (times c b)). + + Lemma MapFold_distr_l : (f:ad->A->M) (m:(Map A)) (c:N) + (times c (MapFold A M neutral op f m))= + (MapFold A M' neutral' op' [a:ad][y:A] (times c (f a y)) m). + Proof. + Intros. Apply MapFold_distr_r with times:=[a:M][b:N](times b a); Assumption. + Qed. + +End MapFoldDistrL. + +Section MapFoldExists. + + Variable A : Set. + + Lemma MapFold_orb_1 : (f:ad->A->bool) (m:(Map A)) (pf:ad->ad) + (MapFold1 A bool false orb f pf m)= + (Cases (MapSweep1 A f pf m) of + (SOME _) => true + | _ => false + end). + Proof. + Induction m. Trivial. + Intros a y pf. Simpl. Unfold MapSweep2. (Case (f (pf a) y); Reflexivity). + Intros. Simpl. Rewrite (H [a0:ad](pf (ad_double a0))). + Rewrite (H0 [a0:ad](pf (ad_double_plus_un a0))). + Case (MapSweep1 A f [a0:ad](pf (ad_double a0)) m0); Reflexivity. + Qed. + + Lemma MapFold_orb : (f:ad->A->bool) (m:(Map A)) (MapFold A bool false orb f m)= + (Cases (MapSweep A f m) of + (SOME _) => true + | _ => false + end). + Proof. + Intros. Exact (MapFold_orb_1 f m [a:ad]a). + Qed. + +End MapFoldExists. + +Section DMergeDef. + + Variable A : Set. + + Definition DMerge := (MapFold (Map A) (Map A) (M0 A) (MapMerge A) [_:ad][m:(Map A)] m). + + Lemma in_dom_DMerge_1 : (m:(Map (Map A))) (a:ad) (in_dom A a (DMerge m))= + (Cases (MapSweep ? [_:ad][m0:(Map A)] (in_dom A a m0) m) of + (SOME _) => true + | _ => false + end). + Proof. + Unfold DMerge. Intros. + Rewrite (MapFold_distr_l (Map A) (Map A) (M0 A) (MapMerge A) bool false + orb ad (in_dom A) [c:ad](refl_equal ? ?) (in_dom_merge A)). + Apply MapFold_orb. + Qed. + + Lemma in_dom_DMerge_2 : (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) [_: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 : (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 ? [_: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. diff --git a/theories7/IntMap/Mapiter.v b/theories7/IntMap/Mapiter.v new file mode 100644 index 00000000..144572fd --- /dev/null +++ b/theories7/IntMap/Mapiter.v @@ -0,0 +1,527 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Mapaxioms. +Require Fset. +Require PolyList. + +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)] : (option (ad * A)) := + Cases m of + M0 => (NONE ?) + | (M1 a y) => (MapSweep2 (pf a) y) + | (M2 m m') => Cases (MapSweep1 ([a:ad] (pf (ad_double a))) m) of + (SOME r) => (SOME ? r) + | NONE => (MapSweep1 ([a:ad] (pf (ad_double_plus_un a))) m') + end + end. + + Definition MapSweep := [m:(Map A)] (MapSweep1 ([a:ad] a) m). + + Lemma MapSweep_semantics_1_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A) + (MapSweep1 pf m)=(SOME ? (a, y)) -> (f a y)=true. + Proof. + Induction m. Intros. Discriminate H. + Simpl. Intros a y pf a0 y0. Elim (sumbool_of_bool (f (pf a) y)). Intro H. Unfold MapSweep2. + Rewrite H. Intro H0. Inversion H0. Rewrite <- H3. Assumption. + Intro H. Unfold MapSweep2. Rewrite H. Intro H0. Discriminate H0. + Simpl. Intros. Elim (option_sum ad*A (MapSweep1 [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 [a0:ad](pf (ad_double a0)) a y H3). + Intro H2. Rewrite H2 in H1. Exact (H0 [a0:ad](pf (ad_double_plus_un a0)) a y H1). + Qed. + + Lemma MapSweep_semantics_1 : (m:(Map A)) (a:ad) (y:A) + (MapSweep m)=(SOME ? (a, y)) -> (f a y)=true. + Proof. + Intros. Exact (MapSweep_semantics_1_1 m [a:ad]a a y H). + Qed. + + Lemma MapSweep_semantics_2_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A) + (MapSweep1 pf m)=(SOME ? (a, y)) -> {a':ad | a=(pf a')}. + Proof. + Induction m. Intros. Discriminate H. + Simpl. Unfold MapSweep2. 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. + Elim (option_sum ad*A (MapSweep1 [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 [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 [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 : (m:(Map A)) + (pf,fp:ad->ad) ((a0:ad) (fp (pf a0))=a0) -> (a:ad) (y:A) + (MapSweep1 pf m)=(SOME ? (a, y)) -> (MapGet A m (fp a))=(SOME ? y). + Proof. + Induction m. Intros. Discriminate H0. + Simpl. Intros a y pf fp H a0 y0. Unfold MapSweep2. 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 [a0:ad](pf (ad_double a0)) m0)). + Intro H4. Simpl in H2. Apply (H0 [a0:ad](pf (ad_double_plus_un a0)) [a0:ad](ad_div_2 (fp a0))). + Intro. Rewrite H1. Apply ad_double_plus_un_div_2. + Elim (option_sum ad*A (MapSweep1 [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 [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 [a0:ad](pf (ad_double_plus_un a0)) [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 [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 [a0:ad](pf (ad_double a0)) [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 [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 : (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 [a0:ad]a0 [a0:ad]a0 [a0:ad](refl_equal ad a0) a y H). + Qed. + + Lemma MapSweep_semantics_3_1 : (m:(Map A)) (pf:ad->ad) + (MapSweep1 pf m)=(NONE ?) -> + (a:ad) (y:A) (MapGet A m a)=(SOME ? y) -> (f (pf a) y)=false. + Proof. + Induction m. Intros. Discriminate H0. + Simpl. Unfold MapSweep2. 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 [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 [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 [a:ad](pf (ad_double a)) H3 (ad_div_2 a) y H2). + Qed. + + Lemma MapSweep_semantics_3 : (m:(Map A)) + (MapSweep m)=(NONE ?) -> (a:ad) (y:A) (MapGet A m a)=(SOME ? y) -> + (f a y)=false. + Proof. + Intros. + Exact (MapSweep_semantics_3_1 m [a0:ad]a0 H a y H0). + Qed. + + Lemma MapSweep_semantics_4_1 : (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. + 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. + 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 [a0:ad](pf (ad_double_plus_un a0)) (ad_div_2 a) y H1 H2). Intros a'' H4. Elim H4. + Intros y'' H5. Simpl. Elim (option_sum ? (MapSweep1 [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 [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. Rewrite H5. Reflexivity. + Qed. + + Lemma MapSweep_semantics_4 : (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 [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)] : (Map B) := + Cases m of + M0 => (M0 B) + | (M1 a y) => (f (pf a) y) + | (M2 m1 m2) => (MapMerge B (MapCollect1 f [a0:ad] (pf (ad_double a0)) m1) + (MapCollect1 f [a0:ad] (pf (ad_double_plus_un a0)) m2)) + end. + + Definition MapCollect := [f:ad->A->(Map B); m:(Map A)] (MapCollect1 f [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)] : M := + Cases m of + M0 => neutral + | (M1 a y) => (f (pf a) y) + | (M2 m1 m2) => (op (MapFold1 f [a0:ad] (pf (ad_double a0)) m1) + (MapFold1 f [a0:ad] (pf (ad_double_plus_un a0)) m2)) + end. + + Definition MapFold := [f:ad->A->M; m:(Map A)] (MapFold1 f [a:ad]a m). + + Lemma MapFold_empty : (f:ad->A->M) (MapFold f (M0 A))=neutral. + Proof. + Trivial. + Qed. + + Lemma MapFold_M1 : (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)] + : State * M := + Cases m of + M0 => (state, neutral) + | (M1 a y) => (f state (pf a) y) + | (M2 m1 m2) => + Cases (MapFold1_state state [a0:ad] (pf (ad_double a0)) m1) of + (state1, x1) => + Cases (MapFold1_state state1 [a0:ad] (pf (ad_double_plus_un a0)) m2) of + (state2, x2) => (state2, (op x1 x2)) + end + end + end. + + Definition MapFold_state := [state:State] (MapFold1_state state [a:ad]a). + + Lemma pair_sp : (B,C:Set) (x:B*C) x=(Fst x, Snd x). + Proof. + Induction x. Trivial. + Qed. + + Lemma MapFold_state_stateless_1 : (m:(Map A)) (g:ad->A->M) (pf:ad->ad) + ((state:State) (a:ad) (y:A) (Snd (f state a y))=(g a y)) -> + (state:State) + (Snd (MapFold1_state state pf m))=(MapFold1 g pf m). + Proof. + Induction m. Trivial. + Intros. Simpl. Apply H. + Intros. Simpl. Rewrite (pair_sp ? ? + (MapFold1_state state [a0:ad](pf (ad_double a0)) m0)). + Rewrite (H g [a0:ad](pf (ad_double a0)) H1 state). + Rewrite (pair_sp ? ? + (MapFold1_state + (Fst (MapFold1_state state [a0:ad](pf (ad_double a0)) m0)) + [a0:ad](pf (ad_double_plus_un a0)) m1)). + Simpl. + Rewrite (H0 g [a0:ad](pf (ad_double_plus_un a0)) H1 + (Fst (MapFold1_state state [a0:ad](pf (ad_double a0)) m0))). + Reflexivity. + Qed. + + Lemma MapFold_state_stateless : (g:ad->A->M) + ((state:State) (a:ad) (y:A) (Snd (f state a y))=(g a y)) -> + (state:State) (m:(Map A)) + (Snd (MapFold_state state m))=(MapFold g m). + Proof. + Intros. Exact (MapFold_state_stateless_1 m g [a0:ad]a0 H state). + Qed. + + End MapFoldDef. + + Lemma MapCollect_as_Fold : (f:ad->A->(Map B)) (m:(Map A)) + (MapCollect f m)=(MapFold (Map B) (M0 B) (MapMerge B) f m). + Proof. + Induction m;Trivial. + Qed. + + Definition alist := (list (ad*A)). + Definition anil := (nil (ad*A)). + Definition acons := (!cons (ad*A)). + Definition aapp := (!app (ad*A)). + + Definition alist_of_Map := (MapFold alist anil aapp [a:ad;y:A] (acons (pair ? ? a y) anil)). + + Fixpoint alist_semantics [l:alist] : ad -> (option A) := + Cases l of + nil => [_:ad] (NONE A) + | (cons (a, y) l') => [a0:ad] if (ad_eq a a0) then (SOME A y) else (alist_semantics l' a0) + end. + + Lemma alist_semantics_app : (l,l':alist) (a:ad) + (alist_semantics (aapp l l') a)= + (Cases (alist_semantics l a) of + NONE => (alist_semantics l' a) + | (SOME y) => (SOME A y) + end). + Proof. + Unfold aapp. Induction l. Trivial. + Intros. Elim a. Intros a1 y1. Simpl. Case (ad_eq a1 a0). Reflexivity. + Apply H. + Qed. + + Lemma alist_of_Map_semantics_1_1 : (m:(Map A)) (pf:ad->ad) (a:ad) (y:A) + (alist_semantics (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil) pf m) a) + =(SOME A y) -> {a':ad | a=(pf a')}. + Proof. + Induction m. Simpl. Intros. Discriminate H. + Simpl. 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 [a0:ad][y:A](acons (a0,y) anil) + [a0:ad](pf (ad_double a0)) m0) + (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil) + [a0:ad](pf (ad_double_plus_un a0)) m1)) a)=(SOME A y) in H1. + Rewrite (alist_semantics_app + (MapFold1 alist anil aapp [a0:ad][y0:A](acons (a0,y0) anil) + [a0:ad](pf (ad_double a0)) m0) + (MapFold1 alist anil aapp [a0:ad][y0:A](acons (a0,y0) anil) + [a0:ad](pf (ad_double_plus_un a0)) m1) a) in H1. + Elim (option_sum A + (alist_semantics + (MapFold1 alist anil aapp [a0:ad][y0:A](acons (a0,y0) anil) + [a0:ad](pf (ad_double a0)) m0) a)). + Intro H2. Elim H2. Intros y0 H3. Elim (H [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 [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] (a0,a1:ad) (pf a0)=(pf a1) -> a0=a1. + + Lemma ad_comp_double_inj : + (pf:ad->ad) (ad_inj pf) -> (ad_inj [a0:ad] (pf (ad_double a0))). + Proof. + Unfold ad_inj. Intros. Apply ad_double_inj. Exact (H ? ? H0). + Qed. + + Lemma ad_comp_double_plus_un_inj : (pf:ad->ad) (ad_inj pf) -> + (ad_inj [a0:ad] (pf (ad_double_plus_un a0))). + Proof. + Unfold ad_inj. Intros. Apply ad_double_plus_un_inj. Exact (H ? ? H0). + Qed. + + Lemma alist_of_Map_semantics_1 : (m:(Map A)) (pf:ad->ad) (ad_inj pf) -> + (a:ad) (MapGet A m a)=(alist_semantics (MapFold1 alist anil aapp + [a0:ad;y:A] (acons (pair ? ? a0 y) anil) pf m) + (pf a)). + Proof. + Induction m. Trivial. + Simpl. 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 [a0:ad][y:A](acons (a0,y) anil) + [a0:ad](pf (ad_double a0)) m0) + (MapFold1 alist anil aapp [a0:ad][y:A](acons (a0,y) anil) + [a0:ad](pf (ad_double_plus_un a0)) m1)) (pf a)). + 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 [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 [a1:ad][y:A](acons (a1,y) anil) + [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 [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 [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 [a1:ad][y:A](acons (a1,y) anil) + [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 [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 : (m:(Map A)) + (eqm A (MapGet A m) (alist_semantics (alist_of_Map m))). + Proof. + Unfold eqm. Intros. Exact (alist_of_Map_semantics_1 m [a0:ad]a0 [a0,a1:ad][p:a0=a1]p a). + Qed. + + Fixpoint Map_of_alist [l:alist] : (Map A) := + Cases l of + nil => (M0 A) + | (cons (a, y) l') => (MapPut A (Map_of_alist l') a y) + end. + + Lemma Map_of_alist_semantics : (l:alist) + (eqm A (alist_semantics l) (MapGet A (Map_of_alist l))). + Proof. + Unfold eqm. Induction l. Trivial. + Intros r l0 H a. Elim r. Intros a0 y0. Simpl. 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 : (m:(Map A)) (eqmap A (Map_of_alist (alist_of_Map m)) m). + Proof. + Unfold eqmap. 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 : (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 : (M:Set) (neutral:M) (op:M->M->M) + ((a,b,c:M) (op (op a b) c)=(op a (op b c))) -> + ((a:M) (op neutral a)=a) -> + (f:ad->A->M) (l,l':alist) + (fold_right [r:ad*A][m:M] let (a,y)=r in (op (f a y) m) neutral + (aapp l l'))= + (op (fold_right [r:ad*A][m:M] let (a,y)=r in (op (f a y) m) neutral l) + (fold_right [r:ad*A][m:M] let (a,y)=r in (op (f a y) m) neutral l')) +. + Proof. + Induction l. Simpl. Intro. Rewrite H0. Reflexivity. + Intros r l0 H1 l'. Elim r. Intros a y. Simpl. Rewrite H. Rewrite (H1 l'). Reflexivity. + Qed. + + Lemma MapFold_as_fold_1 : (M:Set) (neutral:M) (op:M->M->M) + ((a,b,c:M) (op (op a b) c)=(op a (op b c))) -> + ((a:M) (op neutral a)=a) -> + ((a:M) (op a neutral)=a) -> + (f:ad->A->M) (m:(Map A)) (pf:ad->ad) + (MapFold1 M neutral op f pf m)= + (fold_right [r:(ad*A)][m:M] let (a,y)=r in (op (f a y) m) neutral + (MapFold1 alist anil aapp [a:ad;y:A] (acons (pair ? ? +a y) anil) pf m)). + Proof. + Induction m. Trivial. + Intros. Simpl. Rewrite H1. Reflexivity. + Intros. Simpl. Rewrite (fold_right_aapp M neutral op H H0 f). + Rewrite (H2 [a0:ad](pf (ad_double a0))). Rewrite (H3 [a0:ad](pf (ad_double_plus_un a0))). + Reflexivity. + Qed. + + Lemma MapFold_as_fold : (M:Set) (neutral:M) (op:M->M->M) + ((a,b,c:M) (op (op a b) c)=(op a (op b c))) -> + ((a:M) (op neutral a)=a) -> + ((a:M) (op a neutral)=a) -> + (f:ad->A->M) (m:(Map A)) + (MapFold M neutral op f m)= + (fold_right [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 [a0:ad]a0). + Qed. + + Lemma alist_MapMerge_semantics : (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. 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 : (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. 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 : (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. 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/theories7/IntMap/Maplists.v b/theories7/IntMap/Maplists.v new file mode 100644 index 00000000..f01ee3d8 --- /dev/null +++ b/theories7/IntMap/Maplists.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: Maplists.v,v 1.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Addr. +Require Addec. +Require Map. +Require Fset. +Require Mapaxioms. +Require Mapsubset. +Require Mapcard. +Require Mapcanon. +Require Mapc. +Require Bool. +Require Sumbool. +Require PolyList. +Require Arith. +Require Mapiter. +Require Mapfold. + +Section MapLists. + + Fixpoint ad_in_list [a:ad;l:(list ad)] : bool := + Cases l of + nil => false + | (cons a' l') => (orb (ad_eq a a') (ad_in_list a l')) + end. + + Fixpoint ad_list_stutters [l:(list ad)] : bool := + Cases l of + nil => false + | (cons a l') => (orb (ad_in_list a l') (ad_list_stutters l')) + end. + + Lemma ad_in_list_forms_circuit : (x:ad) (l:(list ad)) (ad_in_list x l)=true -> + {l1 : (list ad) & {l2 : (list ad) | l=(app l1 (cons x l2))}}. + Proof. + Induction l. Intro. Discriminate H. + Intros. Elim (sumbool_of_bool (ad_eq x a)). Intro H1. Simpl in H0. Split with (nil 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 (cons a l'1). Elim H3. Intros l2 H4. Split with l2. Rewrite H4. Reflexivity. + Qed. + + Lemma ad_list_stutters_has_circuit : (l:(list ad)) (ad_list_stutters l)=true -> + {x:ad & {l0 : (list ad) & {l1 : (list ad) & {l2 : (list ad) | + l=(app l0 (cons x (app l1 (cons x l2))))}}}}. + Proof. + Induction l. Intro. Discriminate H. + Intros. Simpl in H0. Elim (orb_true_elim ? ? H0). Intro H1. Split with a. + Split with (nil ad). Simpl. 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 (cons 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 := + Cases l of + nil => (M0 unit) + | (cons a l') => (MapPut ? (Elems l') a tt) + end. + + Lemma Elems_canon : (l:(list ad)) (mapcanon ? (Elems l)). + Proof. + Induction l. Exact (M0_canon unit). + Intros. Simpl. Apply MapPut_canon. Assumption. + Qed. + + Lemma Elems_app : (l,l':(list ad)) (Elems (app l l'))=(FSetUnion (Elems l) (Elems l')). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite (MapPut_as_Merge_c unit (Elems l0)). + Rewrite (MapPut_as_Merge_c unit (Elems (app l0 l'))). + Change (FSetUnion (Elems (app l0 l')) (M1 unit a tt)) + =(FSetUnion (FSetUnion (Elems l0) (M1 unit a tt)) (Elems l')). + 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 : (l:(list ad)) (Elems (rev l))=(Elems l). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite Elems_app. Simpl. Rewrite (MapPut_as_Merge_c unit (Elems l0)). + Rewrite H. Reflexivity. + Apply Elems_canon. + Qed. + + Lemma ad_in_elems_in_list : (l:(list ad)) (a:ad) (in_FSet a (Elems l))=(ad_in_list a l). + Proof. + Induction l. Trivial. + Simpl. Unfold in_FSet. Intros. Rewrite (in_dom_put ? (Elems l0) a tt a0). + Rewrite (H a0). Reflexivity. + Qed. + + Lemma ad_list_not_stutters_card : (l:(list ad)) (ad_list_stutters l)=false -> + (length l)=(MapCard ? (Elems l)). + Proof. + Induction l. Trivial. + Simpl. 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 : (l:(list ad)) (le (MapCard ? (Elems l)) (length l)). + Proof. + Induction l. Trivial. + Intros. Simpl. Apply le_trans with m:=(S (MapCard ? (Elems l0))). Apply MapCard_Put_ub. + Apply le_n_S. Assumption. + Qed. + + Lemma ad_list_stutters_card : (l:(list ad)) (ad_list_stutters l)=true -> + (lt (MapCard ? (Elems l)) (length l)). + Proof. + Induction l. Intro. Discriminate H. + Intros. Simpl. 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 : (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 (lt (MapCard ? (Elems l)) (length l)). Intro. Rewrite H in H1. Elim (lt_n_n ? H1). + Exact (ad_list_stutters_card ? H0). + Trivial. + Qed. + + Lemma ad_list_stutters_card_conv : (l:(list ad)) (lt (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_n_n ? H). + Qed. + + Lemma ad_in_list_l : (l,l':(list ad)) (a:ad) (ad_in_list a l)=true -> + (ad_in_list a (app l l'))=true. + Proof. + Induction l. Intros. Discriminate H. + Intros. Simpl. 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 : (l,l':(list ad)) (ad_list_stutters l)=true -> + (ad_list_stutters (app l l'))=true. + Proof. + Induction l. Intros. Discriminate H. + Intros. Simpl. 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 : (l,l':(list ad)) (a:ad) (ad_in_list a l')=true -> + (ad_in_list a (app l l'))=true. + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite (H l' a0 H0). Apply orb_b_true. + Qed. + + Lemma ad_list_stutters_app_r : (l,l':(list ad)) (ad_list_stutters l')=true -> + (ad_list_stutters (app l l'))=true. + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite (H l' H0). Apply orb_b_true. + Qed. + + Lemma ad_list_stutters_app_conv_l : (l,l':(list ad)) (ad_list_stutters (app 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 : (l,l':(list ad)) (ad_list_stutters (app 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 : (l,l':(list ad)) (x:ad) (ad_in_list x (app l (cons x l')))=true. + Proof. + Induction l. Simpl. Intros. Rewrite (ad_eq_correct x). Reflexivity. + Intros. Simpl. Rewrite (H l' x). Apply orb_b_true. + Qed. + + Lemma ad_in_list_app : (l,l':(list ad)) (x:ad) + (ad_in_list x (app l l'))=(orb (ad_in_list x l) (ad_in_list x l')). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite <- orb_assoc. Rewrite (H l' x). Reflexivity. + Qed. + + Lemma ad_in_list_rev : (l:(list ad)) (x:ad) + (ad_in_list x (rev l))=(ad_in_list x l). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite ad_in_list_app. Rewrite (H x). Simpl. Rewrite orb_b_false. + Apply orb_sym. + Qed. + + Lemma ad_list_has_circuit_stutters : (l0,l1,l2:(list ad)) (x:ad) + (ad_list_stutters (app l0 (cons x (app l1 (cons x l2)))))=true. + Proof. + Induction l0. Simpl. Intros. Rewrite (ad_in_list_app_1 l1 l2 x). Reflexivity. + Intros. Simpl. Rewrite (H l1 l2 x). Apply orb_b_true. + Qed. + + Lemma ad_list_stutters_prev_l : (l,l':(list ad)) (x:ad) (ad_in_list x l)=true -> + (ad_list_stutters (app l (cons 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. Apply ad_list_has_circuit_stutters. + Qed. + + Lemma ad_list_stutters_prev_conv_l : (l,l':(list ad)) (x:ad) + (ad_list_stutters (app l (cons 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 : (l,l':(list ad)) (x:ad) (ad_in_list x l')=true -> + (ad_list_stutters (app l (cons 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 : (l,l':(list ad)) (x:ad) + (ad_list_stutters (app l (cons 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 : (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 : (l,l':(list ad)) (length (app l l'))=(plus (length l) (length l')). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite (H l'). Reflexivity. + Qed. + + Lemma ad_list_stutters_permute : (l,l':(list ad)) + (ad_list_stutters (app l l'))=(ad_list_stutters (app 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_sym. + Qed. + + Lemma ad_list_rev_length : (l:(list ad)) (length (rev l))=(length l). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite ad_list_app_length. Simpl. Rewrite H. Rewrite <- plus_Snm_nSm. + Rewrite <- plus_n_O. Reflexivity. + Qed. + + Lemma ad_list_stutters_rev : (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 : (l,l':(list ad)) (x:ad) + (app (rev l) (cons x l'))=(app (rev (cons x l)) l'). + Proof. + Induction l. Trivial. + Intros. Simpl. Rewrite (app_ass (rev l0) (cons a (nil ad)) (cons x l')). Simpl. + Rewrite (H (cons x l') a). Simpl. + Rewrite (app_ass (rev l0) (cons a (nil ad)) (cons x (nil ad))). Simpl. + Rewrite app_ass. Simpl. Rewrite app_ass. Reflexivity. + Qed. + + Section ListOfDomDef. + + Variable A : Set. + + Definition ad_list_of_dom := + (MapFold A (list ad) (nil ad) (!app ad) [a:ad][_:A] (cons a (nil ad))). + + Lemma ad_in_list_of_dom_in_dom : (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. Intros. + Rewrite (MapFold_distr_l A (list ad) (nil ad) (!app ad) bool false orb + ad [a:ad][l:(list ad)](ad_in_list a l) [c:ad](refl_equal ? ?) + ad_in_list_app [a0:ad][_:A](cons a0 (nil ad)) m a). + Simpl. Rewrite (MapFold_orb A [a0:ad][_:A](orb (ad_eq a a0) false) m). + Elim (option_sum ? (MapSweep A [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. + 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 ? ? ?). + Qed. + + Lemma Elems_of_list_of_dom : + (m:(Map A)) (eqmap unit (Elems (ad_list_of_dom m)) (MapDom A m)). + Proof. + Unfold eqmap eqm. 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 : (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 : (m:(Map A)) (pf:ad->ad) + (length (MapFold1 A (list ad) (nil ad) (app 1!ad) [a:ad][_:A](cons a (nil ad)) pf m))= + (MapCard A m). + Proof. + Induction m; Try Trivial. Simpl. Intros. Rewrite ad_list_app_length. + Rewrite (H [a0:ad](pf (ad_double a0))). Rewrite (H0 [a0:ad](pf (ad_double_plus_un a0))). + Reflexivity. + Qed. + + Lemma ad_list_of_dom_card : (m:(Map A)) (length (ad_list_of_dom m))=(MapCard A m). + Proof. + Exact [m:(Map A)](ad_list_of_dom_card_1 m [a:ad]a). + Qed. + + Lemma ad_list_of_dom_not_stutters : + (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 : (A:Set) + (m:(Map A)) (pf:ad->ad) + (MapFold1 A (list ad) (nil ad) (app 1!ad) + [a:ad][_:A](cons a (nil ad)) pf m)= + (MapFold1 unit (list ad) (nil ad) (app 1!ad) + [a:ad][_:unit](cons a (nil ad)) pf (MapDom A m)). + Proof. + Induction m; Try Trivial. Simpl. Intros. Rewrite (H [a0:ad](pf (ad_double a0))). + Rewrite (H0 [a0:ad](pf (ad_double_plus_un a0))). Reflexivity. + Qed. + + Lemma ad_list_of_dom_Dom : (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 [a0:ad]a0). + Qed. + +End MapLists. diff --git a/theories7/IntMap/Mapsubset.v b/theories7/IntMap/Mapsubset.v new file mode 100644 index 00000000..c0b1cccd --- /dev/null +++ b/theories7/IntMap/Mapsubset.v @@ -0,0 +1,554 @@ +(************************************************************************) +(* 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.1.2.1 2004/07/16 19:31:28 herbelin Exp $ i*) + +Require Bool. +Require Sumbool. +Require Arith. +Require ZArith. +Require Addr. +Require Adist. +Require Addec. +Require Map. +Require Fset. +Require Mapaxioms. +Require Mapiter. + +Section MapSubsetDef. + + Variable A, B : Set. + + Definition MapSubset := [m:(Map A)] [m':(Map B)] + (a:ad) (in_dom A a m)=true -> (in_dom B a m')=true. + + Definition MapSubset_1 := [m:(Map A)] [m':(Map B)] + Cases (MapSweep A [a:ad][_:A] (negb (in_dom B a m')) m) of + 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 : (m:(Map A)) (m':(Map B)) + (MapSubset m m') -> (MapSubset_1 m m')=true. + Proof. + Unfold MapSubset MapSubset_1. Intros. + Elim (option_sum ? (MapSweep A [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 : (m:(Map A)) (m':(Map B)) + (MapSubset_1 m m')=true -> (MapSubset m m'). + Proof. + Unfold MapSubset MapSubset_1. Unfold 2 in_dom. Intros. Elim (option_sum ? (MapGet A m a)). + Intro H1. Elim H1. Intros y H2. + Elim (option_sum ? (MapSweep A [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 : + (m:(Map A)) (eqmap A m (M0 A)) -> (a:ad) (in_dom ? a m)=false. + Proof. + Unfold eqmap eqm in_dom. Intros. Rewrite (H a). Reflexivity. + Qed. + + Lemma map_dom_empty_2 : + (m:(Map A)) ((a:ad) (in_dom ? a m)=false) -> (eqmap A m (M0 A)). + Proof. + Unfold eqmap eqm in_dom. Intros. + Cut (Cases (MapGet A m a) of NONE => false | (SOME _) => true end)=false. + Case (MapGet A m a). Trivial. + Intros. Discriminate H0. + Exact (H a). + Qed. + + Lemma MapSubset_imp_2 : + (m:(Map A)) (m':(Map B)) (MapSubset m m') -> (MapSubset_2 m m'). + Proof. + Unfold MapSubset MapSubset_2. 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 : + (m:(Map A)) (m':(Map B)) (MapSubset_2 m m') -> (MapSubset m m'). + Proof. + Unfold MapSubset MapSubset_2. 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. + + Variable A, B, C : Set. + + Lemma MapSubset_refl : (m:(Map A)) (MapSubset A A m m). + Proof. + Unfold MapSubset. Trivial. + Qed. + + Lemma MapSubset_antisym : (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. 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. 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. Rewrite H3. Reflexivity. + Intro H2. Rewrite H2. Exact H1. + Qed. + + Lemma MapSubset_trans : (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. Intros. Apply H0. Apply H. Assumption. + Qed. + +End MapSubsetOrder. + +Section FSubsetOrder. + + Lemma FSubset_refl : (s:FSet) (MapSubset ? ? s s). + Proof. + Exact (MapSubset_refl unit). + Qed. + + Lemma FSubset_antisym : (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 : (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. + + Variable A, B : Set. + + Lemma MapSubset_Dom_1 : (m:(Map A)) (m':(Map B)) + (MapSubset A B m m') -> (MapSubset unit unit (MapDom A m) (MapDom B m')). + Proof. + Unfold MapSubset. 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 : (m:(Map A)) (m':(Map B)) + (MapSubset unit unit (MapDom A m) (MapDom B m')) -> (MapSubset A B m m'). + Proof. + Unfold MapSubset. 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. Rewrite H3. Reflexivity. + Intro H1. Rewrite H1 in H0. Discriminate H0. + Qed. + + Lemma MapSubset_1_Dom : (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 : (m:(Map A)) (a:ad) (y:A) (MapSubset A A m (MapPut A m a y)). + Proof. + Unfold MapSubset. Intros. Rewrite in_dom_put. Rewrite H. Apply orb_b_true. + Qed. + + Lemma MapSubset_Put_mono : (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. 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 : + (m:(Map A)) (a:ad) (y:A) (MapSubset A A m (MapPut_behind A m a y)). + Proof. + Unfold MapSubset. Intros. Rewrite in_dom_put_behind. Rewrite H. Apply orb_b_true. + Qed. + + Lemma MapSubset_Put_behind_mono : (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. 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 : (m:(Map A)) (a:ad) (MapSubset A A (MapRemove A m a) m). + Proof. + Unfold MapSubset. Intros. Unfold MapSubset. Intros. Rewrite (in_dom_remove ? m a a0) in H. + Elim (andb_prop ? ? H). Trivial. + Qed. + + Lemma MapSubset_Remove_mono : (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. 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 : (m,m':(Map A)) (MapSubset A A m (MapMerge A m m')). + Proof. + Unfold MapSubset. Intros. Rewrite in_dom_merge. Rewrite H. Reflexivity. + Qed. + + Lemma MapSubset_Merge_r : (m,m':(Map A)) (MapSubset A A m' (MapMerge A m m')). + Proof. + Unfold MapSubset. Intros. Rewrite in_dom_merge. Rewrite H. Apply orb_b_true. + Qed. + + Lemma MapSubset_Merge_mono : (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. 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 : (m:(Map A)) (m':(Map B)) + (MapSubset A A (MapDomRestrTo A B m m') m). + Proof. + Unfold MapSubset. Intros. Rewrite (in_dom_restrto ? ? m m' a) in H. Elim (andb_prop ? ? H). + Trivial. + Qed. + + Lemma MapSubset_DomRestrTo_r: (m:(Map A)) (m':(Map B)) + (MapSubset A B (MapDomRestrTo A B m m') m'). + Proof. + Unfold MapSubset. Intros. Rewrite (in_dom_restrto ? ? m m' a) in H. Elim (andb_prop ? ? H). + Trivial. + Qed. + + Lemma MapSubset_ext : (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. + 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. + + Variable C, D : Set. + + Lemma MapSubset_DomRestrTo_mono : + (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. 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 : (m:(Map A)) (m':(Map B)) + (MapSubset A A (MapDomRestrBy A B m m') m). + Proof. + Unfold MapSubset. Intros. Rewrite (in_dom_restrby ? ? m m' a) in H. Elim (andb_prop ? ? H). + Trivial. + Qed. + + Lemma MapSubset_DomRestrBy_mono : + (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. 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. + + Variable A, B : Set. + + Definition MapDisjoint := [m:(Map A)] [m':(Map B)] + (a:ad) (in_dom A a m)=true -> (in_dom B a m')=true -> False. + + Definition MapDisjoint_1 := [m:(Map A)] [m':(Map B)] + Cases (MapSweep A [a:ad][_:A] (in_dom B a m') m) of + 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 : (m:(Map A)) (m':(Map B)) + (MapDisjoint m m') -> (MapDisjoint_1 m m')=true. + Proof. + Unfold MapDisjoint MapDisjoint_1. Intros. + Elim (option_sum ? (MapSweep A [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 1 in_dom 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 : (m:(Map A)) (m':(Map B)) + (MapDisjoint_1 m m')=true -> (MapDisjoint m m'). + Proof. + Unfold MapDisjoint MapDisjoint_1. Intros. + Elim (option_sum ? (MapSweep A [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 : (m:(Map A)) (m':(Map B)) (MapDisjoint m m') -> + (MapDisjoint_2 m m'). + Proof. + Unfold MapDisjoint MapDisjoint_2. Unfold eqmap eqm. 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 1 in_dom in H0. + Elim (option_sum ? (MapGet B m' a)). Intro H3. Elim H3. Intros y' H4. Unfold 1 in_dom 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 : (m:(Map A)) (m':(Map B)) (MapDisjoint_2 m m') -> + (MapDisjoint m m'). + Proof. + Unfold MapDisjoint MapDisjoint_2. Unfold eqmap eqm. 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 : (m:(Map B)) (MapDisjoint (M0 A) m). + Proof. + Unfold MapDisjoint in_dom. Intros. Discriminate H. + Qed. + + Lemma Map_disjoint_M0 : (m:(Map A)) (MapDisjoint m (M0 B)). + Proof. + Unfold MapDisjoint in_dom. Intros. Discriminate H0. + Qed. + +End MapDisjointDef. + +Section MapDisjointExtra. + + Variable A, B : Set. + + Lemma MapDisjoint_ext : (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. + 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 : (m,m':(Map A)) (MapDisjoint A A m m') -> + (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. 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. Rewrite andb_b_true. Reflexivity. + Qed. + + Lemma MapDisjoint_M2_l : (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. 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 : (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. 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 : (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. 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 : (m:(Map A)) (a:ad) (y:B) + (MapDisjoint B A (M1 B a y) m) -> (in_dom A a m)=false. + Proof. + Unfold MapDisjoint. 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 : (m:(Map A)) (a:ad) (y:B) + (MapDisjoint A B m (M1 B a y)) -> (in_dom A a m)=false. + Proof. + Unfold MapDisjoint. 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 : (m:(Map A)) (a:ad) (y:B) + (in_dom A a m)=false -> (MapDisjoint B A (M1 B a y) m). + Proof. + Unfold MapDisjoint. 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 : (m:(Map A)) (a:ad) (y:B) + (in_dom A a m)=false -> (MapDisjoint A B m (M1 B a y)). + Proof. + Unfold MapDisjoint. Intros. Rewrite (in_dom_M1_2 B a a0 y H1) in H. Rewrite H0 in H. + Discriminate H. + Qed. + + Lemma MapDisjoint_sym : (m:(Map A)) (m':(Map B)) + (MapDisjoint A B m m') -> (MapDisjoint B A m' m). + Proof. + Unfold MapDisjoint. Intros. Exact (H ? H1 H0). + Qed. + + Lemma MapDisjoint_empty : (m:(Map A)) (MapDisjoint A A m m) -> (eqmap A m (M0 A)). + Proof. + Unfold eqmap eqm. Intros. Rewrite <- (MapDomRestrTo_idempotent A m a). + Exact (MapDisjoint_imp_2 A A m m H a). + Qed. + + Lemma MapDelta_disjoint : (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 : (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. 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 : (m,m':(Map A)) + (MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m m')). + Proof. + Unfold MapDisjoint. 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 : (m,m':(Map A)) + (MapDisjoint A A (MapDelta A m m') (MapDomRestrTo A A m' m)). + Proof. + Unfold MapDisjoint. 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 : (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. Intros. Exact (H1 ? (H ? H2) (H0 ? H3)). + Qed. + + Lemma MapSubset_Disjoint_l : (m:(Map A)) (m':(Map B)) (m'':(Map C)) + (MapSubset ? ? m m') -> (MapDisjoint ? ? m' m'') -> + (MapDisjoint ? ? m m''). + Proof. + Unfold MapSubset MapDisjoint. Intros. Exact (H0 ? (H ? H1) H2). + Qed. + + Lemma MapSubset_Disjoint_r : (m:(Map A)) (m'':(Map C)) (m''':(Map D)) + (MapSubset ? ? m'' m''') -> (MapDisjoint ? ? m m''') -> + (MapDisjoint ? ? m m''). + Proof. + Unfold MapSubset MapDisjoint. Intros. Exact (H0 ? H1 (H ? H2)). + Qed. + +End MapDisjointExtra. |