1039 "i < length ls \<Longrightarrow> j < length ls \<Longrightarrow> |
1039 "i < length ls \<Longrightarrow> j < length ls \<Longrightarrow> |
1040 multiset_of (ls[j := ls ! i, i := ls ! j]) = multiset_of ls" |
1040 multiset_of (ls[j := ls ! i, i := ls ! j]) = multiset_of ls" |
1041 by (cases "i = j") (simp_all add: multiset_of_update nth_mem_multiset_of) |
1041 by (cases "i = j") (simp_all add: multiset_of_update nth_mem_multiset_of) |
1042 |
1042 |
1043 |
1043 |
1044 subsubsection {* Association lists -- including rudimentary code generation *} |
1044 subsubsection {* Association lists -- including code generation *} |
|
1045 |
|
1046 text {* Preliminaries *} |
|
1047 |
|
1048 text {* Raw operations on lists *} |
|
1049 |
|
1050 definition join_raw :: "('key \<Rightarrow> 'val \<times> 'val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list" |
|
1051 where |
|
1052 "join_raw f xs ys = foldr (\<lambda>(k, v). map_default k v (%v'. f k (v', v))) ys xs" |
|
1053 |
|
1054 lemma join_raw_Nil [simp]: |
|
1055 "join_raw f xs [] = xs" |
|
1056 by (simp add: join_raw_def) |
|
1057 |
|
1058 lemma join_raw_Cons [simp]: |
|
1059 "join_raw f xs ((k, v) # ys) = map_default k v (%v'. f k (v', v)) (join_raw f xs ys)" |
|
1060 by (simp add: join_raw_def) |
|
1061 |
|
1062 lemma map_of_join_raw: |
|
1063 assumes "distinct (map fst ys)" |
|
1064 shows "map_of (join_raw f xs ys) x = (case map_of xs x of None => map_of ys x | Some v => (case map_of ys x of None => Some v | Some v' => Some (f x (v, v'))))" |
|
1065 using assms |
|
1066 apply (induct ys) |
|
1067 apply (auto simp add: map_of_map_default split: option.split) |
|
1068 apply (metis map_of_eq_None_iff option.simps(2) weak_map_of_SomeI) |
|
1069 by (metis Some_eq_map_of_iff map_of_eq_None_iff option.simps(2)) |
|
1070 |
|
1071 lemma distinct_join_raw: |
|
1072 assumes "distinct (map fst xs)" |
|
1073 shows "distinct (map fst (join_raw f xs ys))" |
|
1074 using assms |
|
1075 proof (induct ys) |
|
1076 case (Cons y ys) |
|
1077 thus ?case by (cases y) (simp add: distinct_map_default) |
|
1078 qed auto |
|
1079 |
|
1080 definition |
|
1081 "subtract_entries_raw xs ys = foldr (%(k, v). AList_Impl.map_entry k (%v'. v' - v)) ys xs" |
|
1082 |
|
1083 lemma map_of_subtract_entries_raw: |
|
1084 "distinct (map fst ys) ==> map_of (subtract_entries_raw xs ys) x = (case map_of xs x of None => None | Some v => (case map_of ys x of None => Some v | Some v' => Some (v - v')))" |
|
1085 unfolding subtract_entries_raw_def |
|
1086 apply (induct ys) |
|
1087 apply auto |
|
1088 apply (simp split: option.split) |
|
1089 apply (simp add: map_of_map_entry) |
|
1090 apply (auto split: option.split) |
|
1091 apply (metis map_of_eq_None_iff option.simps(3) option.simps(4)) |
|
1092 by (metis map_of_eq_None_iff option.simps(4) option.simps(5)) |
|
1093 |
|
1094 lemma distinct_subtract_entries_raw: |
|
1095 assumes "distinct (map fst xs)" |
|
1096 shows "distinct (map fst (subtract_entries_raw xs ys))" |
|
1097 using assms |
|
1098 unfolding subtract_entries_raw_def by (induct ys) (auto simp add: distinct_map_entry) |
|
1099 |
|
1100 text {* Operations on alists *} |
|
1101 |
|
1102 definition join |
|
1103 where |
|
1104 "join f xs ys = AList.Alist (join_raw f (AList.impl_of xs) (AList.impl_of ys))" |
|
1105 |
|
1106 lemma [code abstract]: |
|
1107 "AList.impl_of (join f xs ys) = join_raw f (AList.impl_of xs) (AList.impl_of ys)" |
|
1108 unfolding join_def by (simp add: Alist_inverse distinct_join_raw) |
|
1109 |
|
1110 definition subtract_entries |
|
1111 where |
|
1112 "subtract_entries xs ys = AList.Alist (subtract_entries_raw (AList.impl_of xs) (AList.impl_of ys))" |
|
1113 |
|
1114 lemma [code abstract]: |
|
1115 "AList.impl_of (subtract_entries xs ys) = subtract_entries_raw (AList.impl_of xs) (AList.impl_of ys)" |
|
1116 unfolding subtract_entries_def by (simp add: Alist_inverse distinct_subtract_entries_raw) |
|
1117 |
|
1118 text {* Implementing multisets by means of association lists *} |
1045 |
1119 |
1046 definition count_of :: "('a \<times> nat) list \<Rightarrow> 'a \<Rightarrow> nat" where |
1120 definition count_of :: "('a \<times> nat) list \<Rightarrow> 'a \<Rightarrow> nat" where |
1047 "count_of xs x = (case map_of xs x of None \<Rightarrow> 0 | Some n \<Rightarrow> n)" |
1121 "count_of xs x = (case map_of xs x of None \<Rightarrow> 0 | Some n \<Rightarrow> n)" |
1048 |
1122 |
1049 lemma count_of_multiset: |
1123 lemma count_of_multiset: |
1072 lemma count_of_empty: |
1146 lemma count_of_empty: |
1073 "x \<notin> fst ` set xs \<Longrightarrow> count_of xs x = 0" |
1147 "x \<notin> fst ` set xs \<Longrightarrow> count_of xs x = 0" |
1074 by (induct xs) (simp_all add: count_of_def) |
1148 by (induct xs) (simp_all add: count_of_def) |
1075 |
1149 |
1076 lemma count_of_filter: |
1150 lemma count_of_filter: |
1077 "count_of (filter (P \<circ> fst) xs) x = (if P x then count_of xs x else 0)" |
1151 "count_of (List.filter (P \<circ> fst) xs) x = (if P x then count_of xs x else 0)" |
1078 by (induct xs) auto |
1152 by (induct xs) auto |
1079 |
1153 |
1080 definition Bag :: "('a \<times> nat) list \<Rightarrow> 'a multiset" where |
1154 lemma count_of_map_default [simp]: |
1081 "Bag xs = Abs_multiset (count_of xs)" |
1155 "count_of (map_default x b (%x. x + b) xs) y = (if x = y then count_of xs x + b else count_of xs y)" |
|
1156 unfolding count_of_def by (simp add: map_of_map_default split: option.split) |
|
1157 |
|
1158 lemma count_of_join_raw: |
|
1159 "distinct (map fst ys) ==> count_of xs x + count_of ys x = count_of (join_raw (%x (x, y). x + y) xs ys) x" |
|
1160 unfolding count_of_def by (simp add: map_of_join_raw split: option.split) |
|
1161 |
|
1162 lemma count_of_subtract_entries_raw: |
|
1163 "distinct (map fst ys) ==> count_of xs x - count_of ys x = count_of (subtract_entries_raw xs ys) x" |
|
1164 unfolding count_of_def by (simp add: map_of_subtract_entries_raw split: option.split) |
|
1165 |
|
1166 text {* Code equations for multiset operations *} |
|
1167 |
|
1168 definition Bag :: "('a, nat) alist \<Rightarrow> 'a multiset" where |
|
1169 "Bag xs = Abs_multiset (count_of (AList.impl_of xs))" |
1082 |
1170 |
1083 code_datatype Bag |
1171 code_datatype Bag |
1084 |
1172 |
1085 lemma count_Bag [simp, code]: |
1173 lemma count_Bag [simp, code]: |
1086 "count (Bag xs) = count_of xs" |
1174 "count (Bag xs) = count_of (AList.impl_of xs)" |
1087 by (simp add: Bag_def count_of_multiset Abs_multiset_inverse) |
1175 by (simp add: Bag_def count_of_multiset Abs_multiset_inverse) |
1088 |
1176 |
1089 lemma Mempty_Bag [code]: |
1177 lemma Mempty_Bag [code]: |
1090 "{#} = Bag []" |
1178 "{#} = Bag (Alist [])" |
1091 by (simp add: multiset_eq_iff) |
1179 by (simp add: multiset_eq_iff alist.Alist_inverse) |
1092 |
1180 |
1093 lemma single_Bag [code]: |
1181 lemma single_Bag [code]: |
1094 "{#x#} = Bag [(x, 1)]" |
1182 "{#x#} = Bag (Alist [(x, 1)])" |
1095 by (simp add: multiset_eq_iff) |
1183 by (simp add: multiset_eq_iff alist.Alist_inverse) |
|
1184 |
|
1185 lemma union_Bag [code]: |
|
1186 "Bag xs + Bag ys = Bag (join (\<lambda>x (n1, n2). n1 + n2) xs ys)" |
|
1187 by (rule multiset_eqI) (simp add: count_of_join_raw alist.Alist_inverse distinct_join_raw join_def) |
|
1188 |
|
1189 lemma minus_Bag [code]: |
|
1190 "Bag xs - Bag ys = Bag (subtract_entries xs ys)" |
|
1191 by (rule multiset_eqI) |
|
1192 (simp add: count_of_subtract_entries_raw alist.Alist_inverse distinct_subtract_entries_raw subtract_entries_def) |
1096 |
1193 |
1097 lemma filter_Bag [code]: |
1194 lemma filter_Bag [code]: |
1098 "Multiset.filter P (Bag xs) = Bag (filter (P \<circ> fst) xs)" |
1195 "Multiset.filter P (Bag xs) = Bag (AList.filter (P \<circ> fst) xs)" |
1099 by (rule multiset_eqI) (simp add: count_of_filter) |
1196 by (rule multiset_eqI) (simp add: count_of_filter impl_of_filter) |
1100 |
1197 |
1101 lemma mset_less_eq_Bag [code]: |
1198 lemma mset_less_eq_Bag [code]: |
1102 "Bag xs \<le> A \<longleftrightarrow> (\<forall>(x, n) \<in> set xs. count_of xs x \<le> count A x)" |
1199 "Bag xs \<le> A \<longleftrightarrow> (\<forall>(x, n) \<in> set (AList.impl_of xs). count_of (AList.impl_of xs) x \<le> count A x)" |
1103 (is "?lhs \<longleftrightarrow> ?rhs") |
1200 (is "?lhs \<longleftrightarrow> ?rhs") |
1104 proof |
1201 proof |
1105 assume ?lhs then show ?rhs |
1202 assume ?lhs then show ?rhs |
1106 by (auto simp add: mset_le_def count_Bag) |
1203 by (auto simp add: mset_le_def count_Bag) |
1107 next |
1204 next |
1108 assume ?rhs |
1205 assume ?rhs |
1109 show ?lhs |
1206 show ?lhs |
1110 proof (rule mset_less_eqI) |
1207 proof (rule mset_less_eqI) |
1111 fix x |
1208 fix x |
1112 from `?rhs` have "count_of xs x \<le> count A x" |
1209 from `?rhs` have "count_of (AList.impl_of xs) x \<le> count A x" |
1113 by (cases "x \<in> fst ` set xs") (auto simp add: count_of_empty) |
1210 by (cases "x \<in> fst ` set (AList.impl_of xs)") (auto simp add: count_of_empty) |
1114 then show "count (Bag xs) x \<le> count A x" |
1211 then show "count (Bag xs) x \<le> count A x" |
1115 by (simp add: mset_le_def count_Bag) |
1212 by (simp add: mset_le_def count_Bag) |
1116 qed |
1213 qed |
1117 qed |
1214 qed |
1118 |
1215 |
1125 instance proof |
1222 instance proof |
1126 qed (simp add: equal_multiset_def eq_iff) |
1223 qed (simp add: equal_multiset_def eq_iff) |
1127 |
1224 |
1128 end |
1225 end |
1129 |
1226 |
1130 lemma [code nbe]: |
1227 text {* Quickcheck generators *} |
1131 "HOL.equal (A :: 'a::equal multiset) A \<longleftrightarrow> True" |
|
1132 by (fact equal_refl) |
|
1133 |
1228 |
1134 definition (in term_syntax) |
1229 definition (in term_syntax) |
1135 bagify :: "('a\<Colon>typerep \<times> nat) list \<times> (unit \<Rightarrow> Code_Evaluation.term) |
1230 bagify :: "('a\<Colon>typerep, nat) alist \<times> (unit \<Rightarrow> Code_Evaluation.term) |
1136 \<Rightarrow> 'a multiset \<times> (unit \<Rightarrow> Code_Evaluation.term)" where |
1231 \<Rightarrow> 'a multiset \<times> (unit \<Rightarrow> Code_Evaluation.term)" where |
1137 [code_unfold]: "bagify xs = Code_Evaluation.valtermify Bag {\<cdot>} xs" |
1232 [code_unfold]: "bagify xs = Code_Evaluation.valtermify Bag {\<cdot>} xs" |
1138 |
1233 |
1139 notation fcomp (infixl "\<circ>>" 60) |
1234 notation fcomp (infixl "\<circ>>" 60) |
1140 notation scomp (infixl "\<circ>\<rightarrow>" 60) |
1235 notation scomp (infixl "\<circ>\<rightarrow>" 60) |