src/HOL/Quotient_Examples/DList.thy
 author haftmann Sun Oct 08 22:28:22 2017 +0200 (23 months ago) changeset 66816 212a3334e7da parent 66453 cc19f7ca2ed6 permissions -rw-r--r--
more fundamental definition of div and mod on int
1 (*  Title:      HOL/Quotient_Examples/DList.thy
2     Author:     Cezary Kaliszyk, University of Tsukuba
4 Based on typedef version "Library/Dlist" by Florian Haftmann
5 and theory morphism version by Maksym Bortin
6 *)
8 section \<open>Lists with distinct elements\<close>
10 theory DList
11 imports "HOL-Library.Quotient_List"
12 begin
14 text \<open>Some facts about lists\<close>
16 lemma remdups_removeAll_commute[simp]:
17   "remdups (removeAll x l) = removeAll x (remdups l)"
18   by (induct l) auto
20 lemma removeAll_distinct[simp]:
21   assumes "distinct l"
22   shows "distinct (removeAll x l)"
23   using assms by (induct l) simp_all
25 lemma removeAll_commute:
26   "removeAll x (removeAll y l) = removeAll y (removeAll x l)"
27   by (induct l) auto
29 lemma remdups_hd_notin_tl:
30   "remdups dl = h # t \<Longrightarrow> h \<notin> set t"
31 proof (induct dl arbitrary: h t)
32   case Nil
33   then show ?case by simp
34 next
35   case (Cons a dl)
36   then show ?case by (cases "a \<in> set dl") auto
37 qed
39 lemma remdups_repeat:
40   "remdups dl = h # t \<Longrightarrow> t = remdups t"
41 proof (induct dl arbitrary: h t)
42   case Nil
43   then show ?case by simp
44 next
45   case (Cons a dl)
46   then show ?case by (cases "a \<in> set dl") (auto simp: remdups_remdups)
47 qed
49 lemma remdups_nil_noteq_cons:
50   "remdups (h # t) \<noteq> remdups []"
51   "remdups [] \<noteq> remdups (h # t)"
52   by auto
54 lemma remdups_eq_map_eq:
55   assumes "remdups xa = remdups ya"
56     shows "remdups (map f xa) = remdups (map f ya)"
57   using assms
58   by (induct xa ya rule: list_induct2')
59      (metis (full_types) remdups_nil_noteq_cons(2) remdups_map_remdups)+
61 lemma remdups_eq_member_eq:
62   assumes "remdups xa = remdups ya"
63     shows "List.member xa = List.member ya"
64   using assms
65   unfolding fun_eq_iff List.member_def
66   by (induct xa ya rule: list_induct2')
67      (metis remdups_nil_noteq_cons set_remdups)+
69 text \<open>Setting up the quotient type\<close>
71 definition
72   dlist_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
73 where
74   [simp]: "dlist_eq xs ys \<longleftrightarrow> remdups xs = remdups ys"
76 lemma dlist_eq_reflp:
77   "reflp dlist_eq"
78   by (auto intro: reflpI)
80 lemma dlist_eq_symp:
81   "symp dlist_eq"
82   by (auto intro: sympI)
84 lemma dlist_eq_transp:
85   "transp dlist_eq"
86   by (auto intro: transpI)
88 lemma dlist_eq_equivp:
89   "equivp dlist_eq"
90   by (auto intro: equivpI dlist_eq_reflp dlist_eq_symp dlist_eq_transp)
92 quotient_type
93   'a dlist = "'a list" / "dlist_eq"
94   by (rule dlist_eq_equivp)
96 text \<open>respectfulness and constant definitions\<close>
98 definition [simp]: "card_remdups = length \<circ> remdups"
99 definition [simp]: "foldr_remdups f xs e = foldr f (remdups xs) e"
101 quotient_definition empty where "empty :: 'a dlist"
102   is "Nil" .
104 quotient_definition insert where "insert :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
105   is "Cons" by (metis (mono_tags) List.insert_def dlist_eq_def remdups.simps(2) set_remdups)
107 quotient_definition "member :: 'a dlist \<Rightarrow> 'a \<Rightarrow> bool"
108   is "List.member" by (metis dlist_eq_def remdups_eq_member_eq)
110 quotient_definition foldr where "foldr :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b"
111   is "foldr_remdups" by auto
113 quotient_definition "remove :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
114   is "removeAll" by force
116 quotient_definition card where "card :: 'a dlist \<Rightarrow> nat"
117   is "card_remdups" by fastforce
119 quotient_definition map where "map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist"
120   is "List.map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" by (metis dlist_eq_def remdups_eq_map_eq)
122 quotient_definition filter where "filter :: ('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
123   is "List.filter" by (metis dlist_eq_def remdups_filter)
125 quotient_definition "list_of_dlist :: 'a dlist \<Rightarrow> 'a list"
126   is "remdups" by simp
128 text \<open>lifted theorems\<close>
130 lemma dlist_member_insert:
131   "member dl x \<Longrightarrow> insert x dl = dl"
132   by descending (simp add: List.member_def)
134 lemma dlist_member_insert_eq:
135   "member (insert y dl) x = (x = y \<or> member dl x)"
136   by descending (simp add: List.member_def)
138 lemma dlist_insert_idem:
139   "insert x (insert x dl) = insert x dl"
140   by descending simp
142 lemma dlist_insert_not_empty:
143   "insert x dl \<noteq> empty"
144   by descending auto
146 lemma not_dlist_member_empty:
147   "\<not> member empty x"
148   by descending (simp add: List.member_def)
150 lemma not_dlist_member_remove:
151   "\<not> member (remove x dl) x"
152   by descending (simp add: List.member_def)
154 lemma dlist_in_remove:
155   "a \<noteq> b \<Longrightarrow> member (remove b dl) a = member dl a"
156   by descending (simp add: List.member_def)
158 lemma dlist_not_memb_remove:
159   "\<not> member dl x \<Longrightarrow> remove x dl = dl"
160   by descending (simp add: List.member_def)
162 lemma dlist_no_memb_remove_insert:
163   "\<not> member dl x \<Longrightarrow> remove x (insert x dl) = dl"
164   by descending (simp add: List.member_def)
166 lemma dlist_remove_empty:
167   "remove x empty = empty"
168   by descending simp
170 lemma dlist_remove_insert_commute:
171   "a \<noteq> b \<Longrightarrow> remove a (insert b dl) = insert b (remove a dl)"
172   by descending simp
174 lemma dlist_remove_commute:
175 "remove a (remove b dl) = remove b (remove a dl)"
176   by (lifting removeAll_commute)
178 lemma dlist_foldr_empty:
179   "foldr f empty e = e"
180   by descending simp
182 lemma dlist_no_memb_foldr:
183   assumes "\<not> member dl x"
184   shows "foldr f (insert x dl) e = f x (foldr f dl e)"
185   using assms by descending (simp add: List.member_def)
187 lemma dlist_foldr_insert_not_memb:
188   assumes "\<not>member t h"
189   shows "foldr f (insert h t) e = f h (foldr f t e)"
190   using assms by descending (simp add: List.member_def)
192 lemma list_of_dlist_empty[simp]:
193   "list_of_dlist empty = []"
194   by descending simp
196 lemma list_of_dlist_insert[simp]:
197   "list_of_dlist (insert x xs) =
198     (if member xs x then (remdups (list_of_dlist xs))
199     else x # (remdups (list_of_dlist xs)))"
200   by descending (simp add: List.member_def remdups_remdups)
202 lemma list_of_dlist_remove[simp]:
203   "list_of_dlist (remove x dxs) = remove1 x (list_of_dlist dxs)"
204   by descending (simp add: distinct_remove1_removeAll)
206 lemma list_of_dlist_map[simp]:
207   "list_of_dlist (map f dxs) = remdups (List.map f (list_of_dlist dxs))"
208   by descending (simp add: remdups_map_remdups)
210 lemma list_of_dlist_filter [simp]:
211   "list_of_dlist (filter P dxs) = List.filter P (list_of_dlist dxs)"
212   by descending (simp add: remdups_filter)
214 lemma dlist_map_empty:
215   "map f empty = empty"
216   by descending simp
218 lemma dlist_map_insert:
219   "map f (insert x xs) = insert (f x) (map f xs)"
220   by descending simp
222 lemma dlist_eq_iff:
223   "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
224   by descending simp
226 lemma dlist_eqI:
227   "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
230 abbreviation
231   "dlist xs \<equiv> abs_dlist xs"
233 lemma distinct_list_of_dlist [simp, intro]:
234   "distinct (list_of_dlist dxs)"
235   by descending simp
237 lemma list_of_dlist_dlist [simp]:
238   "list_of_dlist (dlist xs) = remdups xs"
239   unfolding list_of_dlist_def map_fun_apply id_def
240   by (metis Quotient3_rep_abs[OF Quotient3_dlist] dlist_eq_def)
242 lemma remdups_list_of_dlist [simp]:
243   "remdups (list_of_dlist dxs) = list_of_dlist dxs"
244   by simp
246 lemma dlist_list_of_dlist [simp, code abstype]:
247   "dlist (list_of_dlist dxs) = dxs"
249   (metis Quotient3_def Quotient3_dlist dlist_eqI list_of_dlist_dlist remdups_list_of_dlist)
251 lemma dlist_filter_simps:
252   "filter P empty = empty"
253   "filter P (insert x xs) = (if P x then insert x (filter P xs) else filter P xs)"
254   by (lifting filter.simps)
256 lemma dlist_induct:
257   assumes "P empty"
258       and "\<And>a dl. P dl \<Longrightarrow> P (insert a dl)"
259     shows "P dl"
260   using assms by descending (drule list.induct, simp)
262 lemma dlist_induct_stronger:
263   assumes a1: "P empty"
264   and     a2: "\<And>x dl. \<lbrakk>\<not>member dl x; P dl\<rbrakk> \<Longrightarrow> P (insert x dl)"
265   shows "P dl"
266 proof(induct dl rule: dlist_induct)
267   show "P empty" using a1 by simp
268 next
269   fix x dl
270   assume "P dl"
271   then show "P (insert x dl)" using a2
272     by (cases "member dl x") (simp_all add: dlist_member_insert)
273 qed
275 lemma dlist_card_induct:
276   assumes "\<And>xs. (\<And>ys. card ys < card xs \<Longrightarrow> P ys) \<Longrightarrow> P xs"
277     shows "P xs"
278   using assms
279   by descending (rule measure_induct [of card_remdups], blast)
281 lemma dlist_cases:
282   "dl = empty \<or> (\<exists>h t. dl = insert h t \<and> \<not> member t h)"
283   by descending
284     (metis List.member_def dlist_eq_def hd_Cons_tl list_of_dlist_dlist remdups_hd_notin_tl remdups_list_of_dlist)
286 lemma dlist_exhaust:
287   obtains "y = empty" | a dl where "y = insert a dl"
288   by (lifting list.exhaust)
290 lemma dlist_exhaust_stronger:
291   obtains "y = empty" | a dl where "y = insert a dl" "\<not> member dl a"
292   by (metis dlist_cases)
294 end