416 done |
416 done |
417 |
417 |
418 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False" |
418 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False" |
419 by (induct xs) auto |
419 by (induct xs) auto |
420 |
420 |
421 lemma list_induct2 [consumes 1]: |
421 lemma list_induct2 [consumes 1, case_names Nil Cons]: |
422 "\<lbrakk> length xs = length ys; |
422 "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow> |
423 P [] []; |
423 (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys)) |
424 \<And>x xs y ys. \<lbrakk> length xs = length ys; P xs ys \<rbrakk> \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk> |
424 \<Longrightarrow> P xs ys" |
425 \<Longrightarrow> P xs ys" |
425 proof (induct xs arbitrary: ys) |
426 apply(induct xs arbitrary: ys) |
426 case Nil then show ?case by simp |
427 apply simp |
427 next |
428 apply(case_tac ys) |
428 case (Cons x xs ys) then show ?case by (cases ys) simp_all |
429 apply simp |
429 qed |
430 apply simp |
430 |
431 done |
431 lemma list_induct3 [consumes 2, case_names Nil Cons]: |
|
432 "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow> |
|
433 (\<And>x xs y ys z zs. length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P xs ys zs \<Longrightarrow> P (x#xs) (y#ys) (z#zs)) |
|
434 \<Longrightarrow> P xs ys zs" |
|
435 proof (induct xs arbitrary: ys zs) |
|
436 case Nil then show ?case by simp |
|
437 next |
|
438 case (Cons x xs ys zs) then show ?case by (cases ys, simp_all) |
|
439 (cases zs, simp_all) |
|
440 qed |
432 |
441 |
433 lemma list_induct2': |
442 lemma list_induct2': |
434 "\<lbrakk> P [] []; |
443 "\<lbrakk> P [] []; |
435 \<And>x xs. P (x#xs) []; |
444 \<And>x xs. P (x#xs) []; |
436 \<And>y ys. P [] (y#ys); |
445 \<And>y ys. P [] (y#ys); |
1090 apply simp |
1102 apply simp |
1091 apply(erule thin_rl) |
1103 apply(erule thin_rl) |
1092 by (induct ys) simp_all |
1104 by (induct ys) simp_all |
1093 |
1105 |
1094 |
1106 |
|
1107 subsubsection {* List partitioning *} |
|
1108 |
|
1109 primrec partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" where |
|
1110 "partition P [] = ([], [])" |
|
1111 | "partition P (x # xs) = |
|
1112 (let (yes, no) = partition P xs |
|
1113 in if P x then (x # yes, no) else (yes, x # no))" |
|
1114 |
|
1115 lemma partition_filter1: |
|
1116 "fst (partition P xs) = filter P xs" |
|
1117 by (induct xs) (auto simp add: Let_def split_def) |
|
1118 |
|
1119 lemma partition_filter2: |
|
1120 "snd (partition P xs) = filter (Not o P) xs" |
|
1121 by (induct xs) (auto simp add: Let_def split_def) |
|
1122 |
|
1123 lemma partition_P: |
|
1124 assumes "partition P xs = (yes, no)" |
|
1125 shows "(\<forall>p \<in> set yes. P p) \<and> (\<forall>p \<in> set no. \<not> P p)" |
|
1126 proof - |
|
1127 from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)" |
|
1128 by simp_all |
|
1129 then show ?thesis by (simp_all add: partition_filter1 partition_filter2) |
|
1130 qed |
|
1131 |
|
1132 lemma partition_set: |
|
1133 assumes "partition P xs = (yes, no)" |
|
1134 shows "set yes \<union> set no = set xs" |
|
1135 proof - |
|
1136 from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)" |
|
1137 by simp_all |
|
1138 then show ?thesis by (auto simp add: partition_filter1 partition_filter2) |
|
1139 qed |
|
1140 |
|
1141 |
1095 subsubsection {* @{text concat} *} |
1142 subsubsection {* @{text concat} *} |
1096 |
1143 |
1097 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys" |
1144 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys" |
1098 by (induct xs) auto |
1145 by (induct xs) auto |
1099 |
1146 |
1964 "foldl (op @) xs xxs = xs @ (concat xxs)" |
2011 "foldl (op @) xs xxs = xs @ (concat xxs)" |
1965 by(simp add:concat_conv_foldl monoid_append.foldl_absorb0) |
2012 by(simp add:concat_conv_foldl monoid_append.foldl_absorb0) |
1966 |
2013 |
1967 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*} |
2014 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*} |
1968 |
2015 |
1969 lemma listsum_append[simp]: "listsum (xs @ ys) = listsum xs + listsum ys" |
2016 lemma listsum_append [simp]: "listsum (xs @ ys) = listsum xs + listsum ys" |
1970 by (induct xs) (simp_all add:add_assoc) |
2017 by (induct xs) (simp_all add:add_assoc) |
1971 |
2018 |
1972 lemma listsum_rev[simp]: |
2019 lemma listsum_rev [simp]: |
1973 fixes xs :: "'a::comm_monoid_add list" |
2020 fixes xs :: "'a\<Colon>comm_monoid_add list" |
1974 shows "listsum (rev xs) = listsum xs" |
2021 shows "listsum (rev xs) = listsum xs" |
1975 by (induct xs) (simp_all add:add_ac) |
2022 by (induct xs) (simp_all add:add_ac) |
1976 |
2023 |
1977 lemma listsum_foldr: |
2024 lemma listsum_foldr: "listsum xs = foldr (op +) xs 0" |
1978 "listsum xs = foldr (op +) xs 0" |
2025 by (induct xs) auto |
1979 by(induct xs) auto |
2026 |
|
2027 lemma length_concat: "length (concat xss) = listsum (map length xss)" |
|
2028 by (induct xss) simp_all |
1980 |
2029 |
1981 text{* For efficient code generation --- |
2030 text{* For efficient code generation --- |
1982 @{const listsum} is not tail recursive but @{const foldl} is. *} |
2031 @{const listsum} is not tail recursive but @{const foldl} is. *} |
1983 lemma listsum[code unfold]: "listsum xs = foldl (op +) 0 xs" |
2032 lemma listsum[code unfold]: "listsum xs = foldl (op +) 0 xs" |
1984 by(simp add:listsum_foldr foldl_foldr1) |
2033 by(simp add:listsum_foldr foldl_foldr1) |
1995 |
2044 |
1996 translations -- {* Beware of argument permutation! *} |
2045 translations -- {* Beware of argument permutation! *} |
1997 "SUM x<-xs. b" == "CONST listsum (map (%x. b) xs)" |
2046 "SUM x<-xs. b" == "CONST listsum (map (%x. b) xs)" |
1998 "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (map (%x. b) xs)" |
2047 "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (map (%x. b) xs)" |
1999 |
2048 |
|
2049 lemma listsum_triv: "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r" |
|
2050 by (induct xs) (simp_all add: left_distrib) |
|
2051 |
2000 lemma listsum_0 [simp]: "(\<Sum>x\<leftarrow>xs. 0) = 0" |
2052 lemma listsum_0 [simp]: "(\<Sum>x\<leftarrow>xs. 0) = 0" |
2001 by (induct xs) simp_all |
2053 by (induct xs) (simp_all add: left_distrib) |
2002 |
2054 |
2003 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *} |
2055 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *} |
2004 lemma uminus_listsum_map: |
2056 lemma uminus_listsum_map: |
2005 "- listsum (map f xs) = (listsum (map (uminus o f) xs) :: 'a::ab_group_add)" |
2057 fixes f :: "'a \<Rightarrow> 'b\<Colon>ab_group_add" |
2006 by(induct xs) simp_all |
2058 shows "- listsum (map f xs) = (listsum (map (uminus o f) xs))" |
|
2059 by (induct xs) simp_all |
2007 |
2060 |
2008 |
2061 |
2009 subsubsection {* @{text upt} *} |
2062 subsubsection {* @{text upt} *} |
2010 |
2063 |
2011 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])" |
2064 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])" |
3273 *} |
3324 *} |
3274 |
3325 |
3275 |
3326 |
3276 subsubsection {* Generation of efficient code *} |
3327 subsubsection {* Generation of efficient code *} |
3277 |
3328 |
3278 consts |
|
3279 null:: "'a list \<Rightarrow> bool" |
|
3280 list_inter :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" |
|
3281 list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" |
|
3282 list_all :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)" |
|
3283 filtermap :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" |
|
3284 map_filter :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list" |
|
3285 |
|
3286 primrec |
3329 primrec |
3287 member :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "mem" 55) |
3330 member :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "mem" 55) |
3288 where |
3331 where |
3289 "x mem [] \<longleftrightarrow> False" |
3332 "x mem [] \<longleftrightarrow> False" |
3290 | "x mem (y#ys) \<longleftrightarrow> (if y = x then True else x mem ys)" |
3333 | "x mem (y#ys) \<longleftrightarrow> (if y = x then True else x mem ys)" |
3291 |
3334 |
3292 primrec |
3335 primrec |
|
3336 null:: "'a list \<Rightarrow> bool" |
|
3337 where |
3293 "null [] = True" |
3338 "null [] = True" |
3294 "null (x#xs) = False" |
3339 | "null (x#xs) = False" |
3295 |
3340 |
3296 primrec |
3341 primrec |
|
3342 list_inter :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" |
|
3343 where |
3297 "list_inter [] bs = []" |
3344 "list_inter [] bs = []" |
3298 "list_inter (a#as) bs = |
3345 | "list_inter (a#as) bs = |
3299 (if a \<in> set bs then a # list_inter as bs else list_inter as bs)" |
3346 (if a \<in> set bs then a # list_inter as bs else list_inter as bs)" |
3300 |
3347 |
3301 primrec |
3348 primrec |
|
3349 list_all :: "('a \<Rightarrow> bool) \<Rightarrow> ('a list \<Rightarrow> bool)" |
|
3350 where |
3302 "list_all P [] = True" |
3351 "list_all P [] = True" |
3303 "list_all P (x#xs) = (P x \<and> list_all P xs)" |
3352 | "list_all P (x#xs) = (P x \<and> list_all P xs)" |
3304 |
3353 |
3305 primrec |
3354 primrec |
|
3355 list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" |
|
3356 where |
3306 "list_ex P [] = False" |
3357 "list_ex P [] = False" |
3307 "list_ex P (x#xs) = (P x \<or> list_ex P xs)" |
3358 | "list_ex P (x#xs) = (P x \<or> list_ex P xs)" |
3308 |
3359 |
3309 primrec |
3360 primrec |
|
3361 filtermap :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" |
|
3362 where |
3310 "filtermap f [] = []" |
3363 "filtermap f [] = []" |
3311 "filtermap f (x#xs) = |
3364 | "filtermap f (x#xs) = |
3312 (case f x of None \<Rightarrow> filtermap f xs |
3365 (case f x of None \<Rightarrow> filtermap f xs |
3313 | Some y \<Rightarrow> y # filtermap f xs)" |
3366 | Some y \<Rightarrow> y # filtermap f xs)" |
3314 |
3367 |
3315 primrec |
3368 primrec |
|
3369 map_filter :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list" |
|
3370 where |
3316 "map_filter f P [] = []" |
3371 "map_filter f P [] = []" |
3317 "map_filter f P (x#xs) = |
3372 | "map_filter f P (x#xs) = |
3318 (if P x then f x # map_filter f P xs else map_filter f P xs)" |
3373 (if P x then f x # map_filter f P xs else map_filter f P xs)" |
3319 |
|
3320 |
3374 |
3321 text {* |
3375 text {* |
3322 Only use @{text mem} for generating executable code. Otherwise use |
3376 Only use @{text mem} for generating executable code. Otherwise use |
3323 @{prop "x : set xs"} instead --- it is much easier to reason about. |
3377 @{prop "x : set xs"} instead --- it is much easier to reason about. |
3324 The same is true for @{const list_all} and @{const list_ex}: write |
3378 The same is true for @{const list_all} and @{const list_ex}: write |
3446 |
3500 |
3447 lemma ex_nat_less [code unfold]: |
3501 lemma ex_nat_less [code unfold]: |
3448 "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)" |
3502 "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)" |
3449 by auto |
3503 by auto |
3450 |
3504 |
3451 lemma setsum_set_upt_conv_listsum[code unfold]: |
3505 lemma setsum_set_upt_conv_listsum [code unfold]: |
3452 "setsum f (set[k..<n]) = listsum (map f [k..<n])" |
3506 "setsum f (set [k..<n]) = listsum (map f [k..<n])" |
3453 apply(subst atLeastLessThan_upt[symmetric]) |
3507 apply(subst atLeastLessThan_upt[symmetric]) |
3454 by (induct n) simp_all |
3508 by (induct n) simp_all |
3455 |
3509 |
3456 subsubsection {* List partitioning *} |
|
3457 |
|
3458 consts |
|
3459 partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" |
|
3460 primrec |
|
3461 "partition P [] = ([], [])" |
|
3462 "partition P (x # xs) = |
|
3463 (let (yes, no) = partition P xs |
|
3464 in if P x then (x # yes, no) else (yes, x # no))" |
|
3465 |
|
3466 lemma partition_P: |
|
3467 "partition P xs = (yes, no) \<Longrightarrow> (\<forall>p\<in> set yes. P p) \<and> (\<forall>p\<in> set no. \<not> P p)" |
|
3468 proof (induct xs arbitrary: yes no rule: partition.induct) |
|
3469 case Nil then show ?case by simp |
|
3470 next |
|
3471 case (Cons a as) |
|
3472 let ?p = "partition P as" |
|
3473 let ?p' = "partition P (a # as)" |
|
3474 note prem = `?p' = (yes, no)` |
|
3475 show ?case |
|
3476 proof (cases "P a") |
|
3477 case True |
|
3478 with prem have yes: "yes = a # fst ?p" and no: "no = snd ?p" |
|
3479 by (simp_all add: Let_def split_def) |
|
3480 have "(\<forall>p\<in> set (fst ?p). P p) \<and> (\<forall>p\<in> set no. \<not> P p)" |
|
3481 by (rule Cons.hyps) (simp add: yes no) |
|
3482 with True yes show ?thesis by simp |
|
3483 next |
|
3484 case False |
|
3485 with prem have yes: "yes = fst ?p" and no: "no = a # snd ?p" |
|
3486 by (simp_all add: Let_def split_def) |
|
3487 have "(\<forall>p\<in> set yes. P p) \<and> (\<forall>p\<in> set (snd ?p). \<not> P p)" |
|
3488 by (rule Cons.hyps) (simp add: yes no) |
|
3489 with False no show ?thesis by simp |
|
3490 qed |
|
3491 qed |
|
3492 |
|
3493 lemma partition_filter1: |
|
3494 "fst (partition P xs) = filter P xs" |
|
3495 by (induct xs rule: partition.induct) (auto simp add: Let_def split_def) |
|
3496 |
|
3497 lemma partition_filter2: |
|
3498 "snd (partition P xs) = filter (Not o P) xs" |
|
3499 by (induct xs rule: partition.induct) (auto simp add: Let_def split_def) |
|
3500 |
|
3501 lemma partition_set: |
|
3502 assumes "partition P xs = (yes, no)" |
|
3503 shows "set yes \<union> set no = set xs" |
|
3504 proof - |
|
3505 have "set xs = {x. x \<in> set xs \<and> P x} \<union> {x. x \<in> set xs \<and> \<not> P x}" by blast |
|
3506 also have "\<dots> = set (List.filter P xs) Un (set (List.filter (Not o P) xs))" by simp |
|
3507 also have "\<dots> = set (fst (partition P xs)) \<union> set (snd (partition P xs))" |
|
3508 using partition_filter1 [of P xs] partition_filter2 [of P xs] by simp |
|
3509 finally show "set yes Un set no = set xs" using assms by simp |
|
3510 qed |
|
3511 |
|
3512 end |
3510 end |