src/HOL/List.thy
author blanchet
Thu Jun 12 01:00:49 2014 +0200 (2014-06-12)
changeset 57231 dca8d06ecbba
parent 57206 d9be905d6283
child 57243 8c261f0a9b32
child 57247 8191ccf6a1bd
permissions -rw-r--r--
reduces Sledgehammer dependencies
     1 (*  Title:      HOL/List.thy
     2     Author:     Tobias Nipkow
     3 *)
     4 
     5 header {* The datatype of finite lists *}
     6 
     7 theory List
     8 imports Sledgehammer Code_Numeral Quotient Lifting_Set Lifting_Option Lifting_Product
     9 begin
    10 
    11 datatype_new (set: 'a) list =
    12     Nil  ("[]")
    13   | Cons (hd: 'a) (tl: "'a list")  (infixr "#" 65)
    14 for
    15   map: map
    16   rel: list_all2
    17 where
    18   "tl [] = []"
    19 
    20 datatype_compat list
    21 
    22 lemma [case_names Nil Cons, cases type: list]:
    23   -- {* for backward compatibility -- names of variables differ *}
    24   "(y = [] \<Longrightarrow> P) \<Longrightarrow> (\<And>a list. y = a # list \<Longrightarrow> P) \<Longrightarrow> P"
    25 by (rule list.exhaust)
    26 
    27 lemma [case_names Nil Cons, induct type: list]:
    28   -- {* for backward compatibility -- names of variables differ *}
    29   "P [] \<Longrightarrow> (\<And>a list. P list \<Longrightarrow> P (a # list)) \<Longrightarrow> P list"
    30 by (rule list.induct)
    31 
    32 text {* Compatibility: *}
    33 
    34 setup {* Sign.mandatory_path "list" *}
    35 
    36 lemmas inducts = list.induct
    37 lemmas recs = list.rec
    38 lemmas cases = list.case
    39 
    40 setup {* Sign.parent_path *}
    41 
    42 syntax
    43   -- {* list Enumeration *}
    44   "_list" :: "args => 'a list"    ("[(_)]")
    45 
    46 translations
    47   "[x, xs]" == "x#[xs]"
    48   "[x]" == "x#[]"
    49 
    50 
    51 subsection {* Basic list processing functions *}
    52 
    53 primrec last :: "'a list \<Rightarrow> 'a" where
    54 "last (x # xs) = (if xs = [] then x else last xs)"
    55 
    56 primrec butlast :: "'a list \<Rightarrow> 'a list" where
    57 "butlast []= []" |
    58 "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
    59 
    60 declare list.set[simp del, code del]
    61 
    62 lemma set_simps[simp, code, code_post]:
    63   "set [] = {}"
    64   "set (x # xs) = insert x (set xs)"
    65 by (simp_all add: list.set)
    66 
    67 lemma set_rec: "set xs = rec_list {} (\<lambda>x _. insert x) xs"
    68   by (induct xs) auto
    69 
    70 definition coset :: "'a list \<Rightarrow> 'a set" where
    71 [simp]: "coset xs = - set xs"
    72 
    73 primrec append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
    74 append_Nil: "[] @ ys = ys" |
    75 append_Cons: "(x#xs) @ ys = x # xs @ ys"
    76 
    77 primrec rev :: "'a list \<Rightarrow> 'a list" where
    78 "rev [] = []" |
    79 "rev (x # xs) = rev xs @ [x]"
    80 
    81 primrec filter:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    82 "filter P [] = []" |
    83 "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"
    84 
    85 syntax
    86   -- {* Special syntax for filter *}
    87   "_filter" :: "[pttrn, 'a list, bool] => 'a list"    ("(1[_<-_./ _])")
    88 
    89 translations
    90   "[x<-xs . P]"== "CONST filter (%x. P) xs"
    91 
    92 syntax (xsymbols)
    93   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
    94 syntax (HTML output)
    95   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
    96 
    97 primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
    98 fold_Nil:  "fold f [] = id" |
    99 fold_Cons: "fold f (x # xs) = fold f xs \<circ> f x"
   100 
   101 primrec foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
   102 foldr_Nil:  "foldr f [] = id" |
   103 foldr_Cons: "foldr f (x # xs) = f x \<circ> foldr f xs"
   104 
   105 primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
   106 foldl_Nil:  "foldl f a [] = a" |
   107 foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
   108 
   109 primrec concat:: "'a list list \<Rightarrow> 'a list" where
   110 "concat [] = []" |
   111 "concat (x # xs) = x @ concat xs"
   112 
   113 definition (in monoid_add) listsum :: "'a list \<Rightarrow> 'a" where
   114 "listsum xs = foldr plus xs 0"
   115 
   116 primrec drop:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   117 drop_Nil: "drop n [] = []" |
   118 drop_Cons: "drop n (x # xs) = (case n of 0 \<Rightarrow> x # xs | Suc m \<Rightarrow> drop m xs)"
   119   -- {*Warning: simpset does not contain this definition, but separate
   120        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}
   121 
   122 primrec take:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   123 take_Nil:"take n [] = []" |
   124 take_Cons: "take n (x # xs) = (case n of 0 \<Rightarrow> [] | Suc m \<Rightarrow> x # take m xs)"
   125   -- {*Warning: simpset does not contain this definition, but separate
   126        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}
   127 
   128 primrec nth :: "'a list => nat => 'a" (infixl "!" 100) where
   129 nth_Cons: "(x # xs) ! n = (case n of 0 \<Rightarrow> x | Suc k \<Rightarrow> xs ! k)"
   130   -- {*Warning: simpset does not contain this definition, but separate
   131        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}
   132 
   133 primrec list_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
   134 "list_update [] i v = []" |
   135 "list_update (x # xs) i v =
   136   (case i of 0 \<Rightarrow> v # xs | Suc j \<Rightarrow> x # list_update xs j v)"
   137 
   138 nonterminal lupdbinds and lupdbind
   139 
   140 syntax
   141   "_lupdbind":: "['a, 'a] => lupdbind"    ("(2_ :=/ _)")
   142   "" :: "lupdbind => lupdbinds"    ("_")
   143   "_lupdbinds" :: "[lupdbind, lupdbinds] => lupdbinds"    ("_,/ _")
   144   "_LUpdate" :: "['a, lupdbinds] => 'a"    ("_/[(_)]" [900,0] 900)
   145 
   146 translations
   147   "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"
   148   "xs[i:=x]" == "CONST list_update xs i x"
   149 
   150 primrec takeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   151 "takeWhile P [] = []" |
   152 "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"
   153 
   154 primrec dropWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   155 "dropWhile P [] = []" |
   156 "dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"
   157 
   158 primrec zip :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
   159 "zip xs [] = []" |
   160 zip_Cons: "zip xs (y # ys) =
   161   (case xs of [] => [] | z # zs => (z, y) # zip zs ys)"
   162   -- {*Warning: simpset does not contain this definition, but separate
   163        theorems for @{text "xs = []"} and @{text "xs = z # zs"} *}
   164 
   165 primrec product :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
   166 "product [] _ = []" |
   167 "product (x#xs) ys = map (Pair x) ys @ product xs ys"
   168 
   169 hide_const (open) product
   170 
   171 primrec product_lists :: "'a list list \<Rightarrow> 'a list list" where
   172 "product_lists [] = [[]]" |
   173 "product_lists (xs # xss) = concat (map (\<lambda>x. map (Cons x) (product_lists xss)) xs)"
   174 
   175 primrec upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_..</_'])") where
   176 upt_0: "[i..<0] = []" |
   177 upt_Suc: "[i..<(Suc j)] = (if i <= j then [i..<j] @ [j] else [])"
   178 
   179 definition insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   180 "insert x xs = (if x \<in> set xs then xs else x # xs)"
   181 
   182 definition union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   183 "union = fold insert"
   184 
   185 hide_const (open) insert union
   186 hide_fact (open) insert_def union_def
   187 
   188 primrec find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
   189 "find _ [] = None" |
   190 "find P (x#xs) = (if P x then Some x else find P xs)"
   191 
   192 hide_const (open) find
   193 
   194 definition
   195    "extract" :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a * 'a list) option"
   196 where "extract P xs =
   197   (case dropWhile (Not o P) xs of
   198      [] \<Rightarrow> None |
   199      y#ys \<Rightarrow> Some(takeWhile (Not o P) xs, y, ys))"
   200 
   201 hide_const (open) "extract"
   202 
   203 primrec those :: "'a option list \<Rightarrow> 'a list option"
   204 where
   205 "those [] = Some []" |
   206 "those (x # xs) = (case x of
   207   None \<Rightarrow> None
   208 | Some y \<Rightarrow> map_option (Cons y) (those xs))"
   209 
   210 primrec remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   211 "remove1 x [] = []" |
   212 "remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"
   213 
   214 primrec removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   215 "removeAll x [] = []" |
   216 "removeAll x (y # xs) = (if x = y then removeAll x xs else y # removeAll x xs)"
   217 
   218 primrec distinct :: "'a list \<Rightarrow> bool" where
   219 "distinct [] \<longleftrightarrow> True" |
   220 "distinct (x # xs) \<longleftrightarrow> x \<notin> set xs \<and> distinct xs"
   221 
   222 primrec remdups :: "'a list \<Rightarrow> 'a list" where
   223 "remdups [] = []" |
   224 "remdups (x # xs) = (if x \<in> set xs then remdups xs else x # remdups xs)"
   225 
   226 fun remdups_adj :: "'a list \<Rightarrow> 'a list" where
   227 "remdups_adj [] = []" |
   228 "remdups_adj [x] = [x]" |
   229 "remdups_adj (x # y # xs) = (if x = y then remdups_adj (x # xs) else x # remdups_adj (y # xs))"
   230 
   231 primrec replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
   232 replicate_0: "replicate 0 x = []" |
   233 replicate_Suc: "replicate (Suc n) x = x # replicate n x"
   234 
   235 text {*
   236   Function @{text size} is overloaded for all datatypes. Users may
   237   refer to the list version as @{text length}. *}
   238 
   239 abbreviation length :: "'a list \<Rightarrow> nat" where
   240 "length \<equiv> size"
   241 
   242 definition enumerate :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list" where
   243 enumerate_eq_zip: "enumerate n xs = zip [n..<n + length xs] xs"
   244 
   245 primrec rotate1 :: "'a list \<Rightarrow> 'a list" where
   246 "rotate1 [] = []" |
   247 "rotate1 (x # xs) = xs @ [x]"
   248 
   249 definition rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   250 "rotate n = rotate1 ^^ n"
   251 
   252 definition sublist :: "'a list => nat set => 'a list" where
   253 "sublist xs A = map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [0..<size xs]))"
   254 
   255 primrec sublists :: "'a list \<Rightarrow> 'a list list" where
   256 "sublists [] = [[]]" |
   257 "sublists (x#xs) = (let xss = sublists xs in map (Cons x) xss @ xss)"
   258 
   259 primrec n_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
   260 "n_lists 0 xs = [[]]" |
   261 "n_lists (Suc n) xs = concat (map (\<lambda>ys. map (\<lambda>y. y # ys) xs) (n_lists n xs))"
   262 
   263 hide_const (open) n_lists
   264 
   265 fun splice :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   266 "splice [] ys = ys" |
   267 "splice xs [] = xs" |
   268 "splice (x#xs) (y#ys) = x # y # splice xs ys"
   269 
   270 text{*
   271 \begin{figure}[htbp]
   272 \fbox{
   273 \begin{tabular}{l}
   274 @{lemma "[a,b]@[c,d] = [a,b,c,d]" by simp}\\
   275 @{lemma "length [a,b,c] = 3" by simp}\\
   276 @{lemma "set [a,b,c] = {a,b,c}" by simp}\\
   277 @{lemma "map f [a,b,c] = [f a, f b, f c]" by simp}\\
   278 @{lemma "rev [a,b,c] = [c,b,a]" by simp}\\
   279 @{lemma "hd [a,b,c,d] = a" by simp}\\
   280 @{lemma "tl [a,b,c,d] = [b,c,d]" by simp}\\
   281 @{lemma "last [a,b,c,d] = d" by simp}\\
   282 @{lemma "butlast [a,b,c,d] = [a,b,c]" by simp}\\
   283 @{lemma[source] "filter (\<lambda>n::nat. n<2) [0,2,1] = [0,1]" by simp}\\
   284 @{lemma "concat [[a,b],[c,d,e],[],[f]] = [a,b,c,d,e,f]" by simp}\\
   285 @{lemma "fold f [a,b,c] x = f c (f b (f a x))" by simp}\\
   286 @{lemma "foldr f [a,b,c] x = f a (f b (f c x))" by simp}\\
   287 @{lemma "foldl f x [a,b,c] = f (f (f x a) b) c" by simp}\\
   288 @{lemma "zip [a,b,c] [x,y,z] = [(a,x),(b,y),(c,z)]" by simp}\\
   289 @{lemma "zip [a,b] [x,y,z] = [(a,x),(b,y)]" by simp}\\
   290 @{lemma "enumerate 3 [a,b,c] = [(3,a),(4,b),(5,c)]" by normalization}\\
   291 @{lemma "List.product [a,b] [c,d] = [(a, c), (a, d), (b, c), (b, d)]" by simp}\\
   292 @{lemma "product_lists [[a,b], [c], [d,e]] = [[a,c,d], [a,c,e], [b,c,d], [b,c,e]]" by simp}\\
   293 @{lemma "splice [a,b,c] [x,y,z] = [a,x,b,y,c,z]" by simp}\\
   294 @{lemma "splice [a,b,c,d] [x,y] = [a,x,b,y,c,d]" by simp}\\
   295 @{lemma "take 2 [a,b,c,d] = [a,b]" by simp}\\
   296 @{lemma "take 6 [a,b,c,d] = [a,b,c,d]" by simp}\\
   297 @{lemma "drop 2 [a,b,c,d] = [c,d]" by simp}\\
   298 @{lemma "drop 6 [a,b,c,d] = []" by simp}\\
   299 @{lemma "takeWhile (%n::nat. n<3) [1,2,3,0] = [1,2]" by simp}\\
   300 @{lemma "dropWhile (%n::nat. n<3) [1,2,3,0] = [3,0]" by simp}\\
   301 @{lemma "distinct [2,0,1::nat]" by simp}\\
   302 @{lemma "remdups [2,0,2,1::nat,2] = [0,1,2]" by simp}\\
   303 @{lemma "remdups_adj [2,2,3,1,1::nat,2,1] = [2,3,1,2,1]" by simp}\\
   304 @{lemma "List.insert 2 [0::nat,1,2] = [0,1,2]" by (simp add: List.insert_def)}\\
   305 @{lemma "List.insert 3 [0::nat,1,2] = [3,0,1,2]" by (simp add: List.insert_def)}\\
   306 @{lemma "List.union [2,3,4] [0::int,1,2] = [4,3,0,1,2]" by (simp add: List.insert_def List.union_def)}\\
   307 @{lemma "List.find (%i::int. i>0) [0,0] = None" by simp}\\
   308 @{lemma "List.find (%i::int. i>0) [0,1,0,2] = Some 1" by simp}\\
   309 @{lemma "List.extract (%i::int. i>0) [0,0] = None" by(simp add: extract_def)}\\
   310 @{lemma "List.extract (%i::int. i>0) [0,1,0,2] = Some([0], 1, [0,2])" by(simp add: extract_def)}\\
   311 @{lemma "remove1 2 [2,0,2,1::nat,2] = [0,2,1,2]" by simp}\\
   312 @{lemma "removeAll 2 [2,0,2,1::nat,2] = [0,1]" by simp}\\
   313 @{lemma "nth [a,b,c,d] 2 = c" by simp}\\
   314 @{lemma "[a,b,c,d][2 := x] = [a,b,x,d]" by simp}\\
   315 @{lemma "sublist [a,b,c,d,e] {0,2,3} = [a,c,d]" by (simp add:sublist_def)}\\
   316 @{lemma "sublists [a,b] = [[a, b], [a], [b], []]" by simp}\\
   317 @{lemma "List.n_lists 2 [a,b,c] = [[a, a], [b, a], [c, a], [a, b], [b, b], [c, b], [a, c], [b, c], [c, c]]" by (simp add: eval_nat_numeral)}\\
   318 @{lemma "rotate1 [a,b,c,d] = [b,c,d,a]" by simp}\\
   319 @{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate_def eval_nat_numeral)}\\
   320 @{lemma "replicate 4 a = [a,a,a,a]" by (simp add:eval_nat_numeral)}\\
   321 @{lemma "[2..<5] = [2,3,4]" by (simp add:eval_nat_numeral)}\\
   322 @{lemma "listsum [1,2,3::nat] = 6" by (simp add: listsum_def)}
   323 \end{tabular}}
   324 \caption{Characteristic examples}
   325 \label{fig:Characteristic}
   326 \end{figure}
   327 Figure~\ref{fig:Characteristic} shows characteristic examples
   328 that should give an intuitive understanding of the above functions.
   329 *}
   330 
   331 text{* The following simple sort functions are intended for proofs,
   332 not for efficient implementations. *}
   333 
   334 context linorder
   335 begin
   336 
   337 inductive sorted :: "'a list \<Rightarrow> bool" where
   338   Nil [iff]: "sorted []"
   339 | Cons: "\<forall>y\<in>set xs. x \<le> y \<Longrightarrow> sorted xs \<Longrightarrow> sorted (x # xs)"
   340 
   341 lemma sorted_single [iff]:
   342   "sorted [x]"
   343   by (rule sorted.Cons) auto
   344 
   345 lemma sorted_many:
   346   "x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> sorted (x # y # zs)"
   347   by (rule sorted.Cons) (cases "y # zs" rule: sorted.cases, auto)
   348 
   349 lemma sorted_many_eq [simp, code]:
   350   "sorted (x # y # zs) \<longleftrightarrow> x \<le> y \<and> sorted (y # zs)"
   351   by (auto intro: sorted_many elim: sorted.cases)
   352 
   353 lemma [code]:
   354   "sorted [] \<longleftrightarrow> True"
   355   "sorted [x] \<longleftrightarrow> True"
   356   by simp_all
   357 
   358 primrec insort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   359 "insort_key f x [] = [x]" |
   360 "insort_key f x (y#ys) =
   361   (if f x \<le> f y then (x#y#ys) else y#(insort_key f x ys))"
   362 
   363 definition sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   364 "sort_key f xs = foldr (insort_key f) xs []"
   365 
   366 definition insort_insert_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   367 "insort_insert_key f x xs =
   368   (if f x \<in> f ` set xs then xs else insort_key f x xs)"
   369 
   370 abbreviation "sort \<equiv> sort_key (\<lambda>x. x)"
   371 abbreviation "insort \<equiv> insort_key (\<lambda>x. x)"
   372 abbreviation "insort_insert \<equiv> insort_insert_key (\<lambda>x. x)"
   373 
   374 end
   375 
   376 
   377 subsubsection {* List comprehension *}
   378 
   379 text{* Input syntax for Haskell-like list comprehension notation.
   380 Typical example: @{text"[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x \<noteq> y]"},
   381 the list of all pairs of distinct elements from @{text xs} and @{text ys}.
   382 The syntax is as in Haskell, except that @{text"|"} becomes a dot
   383 (like in Isabelle's set comprehension): @{text"[e. x \<leftarrow> xs, \<dots>]"} rather than
   384 \verb![e| x <- xs, ...]!.
   385 
   386 The qualifiers after the dot are
   387 \begin{description}
   388 \item[generators] @{text"p \<leftarrow> xs"},
   389  where @{text p} is a pattern and @{text xs} an expression of list type, or
   390 \item[guards] @{text"b"}, where @{text b} is a boolean expression.
   391 %\item[local bindings] @ {text"let x = e"}.
   392 \end{description}
   393 
   394 Just like in Haskell, list comprehension is just a shorthand. To avoid
   395 misunderstandings, the translation into desugared form is not reversed
   396 upon output. Note that the translation of @{text"[e. x \<leftarrow> xs]"} is
   397 optmized to @{term"map (%x. e) xs"}.
   398 
   399 It is easy to write short list comprehensions which stand for complex
   400 expressions. During proofs, they may become unreadable (and
   401 mangled). In such cases it can be advisable to introduce separate
   402 definitions for the list comprehensions in question.  *}
   403 
   404 nonterminal lc_qual and lc_quals
   405 
   406 syntax
   407   "_listcompr" :: "'a \<Rightarrow> lc_qual \<Rightarrow> lc_quals \<Rightarrow> 'a list"  ("[_ . __")
   408   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ <- _")
   409   "_lc_test" :: "bool \<Rightarrow> lc_qual" ("_")
   410   (*"_lc_let" :: "letbinds => lc_qual"  ("let _")*)
   411   "_lc_end" :: "lc_quals" ("]")
   412   "_lc_quals" :: "lc_qual \<Rightarrow> lc_quals \<Rightarrow> lc_quals"  (", __")
   413   "_lc_abs" :: "'a => 'b list => 'b list"
   414 
   415 (* These are easier than ML code but cannot express the optimized
   416    translation of [e. p<-xs]
   417 translations
   418   "[e. p<-xs]" => "concat(map (_lc_abs p [e]) xs)"
   419   "_listcompr e (_lc_gen p xs) (_lc_quals Q Qs)"
   420    => "concat (map (_lc_abs p (_listcompr e Q Qs)) xs)"
   421   "[e. P]" => "if P then [e] else []"
   422   "_listcompr e (_lc_test P) (_lc_quals Q Qs)"
   423    => "if P then (_listcompr e Q Qs) else []"
   424   "_listcompr e (_lc_let b) (_lc_quals Q Qs)"
   425    => "_Let b (_listcompr e Q Qs)"
   426 *)
   427 
   428 syntax (xsymbols)
   429   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")
   430 syntax (HTML output)
   431   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")
   432 
   433 parse_translation {*
   434   let
   435     val NilC = Syntax.const @{const_syntax Nil};
   436     val ConsC = Syntax.const @{const_syntax Cons};
   437     val mapC = Syntax.const @{const_syntax map};
   438     val concatC = Syntax.const @{const_syntax concat};
   439     val IfC = Syntax.const @{const_syntax If};
   440 
   441     fun single x = ConsC $ x $ NilC;
   442 
   443     fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)
   444       let
   445         (* FIXME proper name context!? *)
   446         val x =
   447           Free (singleton (Name.variant_list (fold Term.add_free_names [p, e] [])) "x", dummyT);
   448         val e = if opti then single e else e;
   449         val case1 = Syntax.const @{syntax_const "_case1"} $ p $ e;
   450         val case2 =
   451           Syntax.const @{syntax_const "_case1"} $
   452             Syntax.const @{const_syntax Pure.dummy_pattern} $ NilC;
   453         val cs = Syntax.const @{syntax_const "_case2"} $ case1 $ case2;
   454       in Syntax_Trans.abs_tr [x, Case_Translation.case_tr false ctxt [x, cs]] end;
   455 
   456     fun abs_tr ctxt p e opti =
   457       (case Term_Position.strip_positions p of
   458         Free (s, T) =>
   459           let
   460             val thy = Proof_Context.theory_of ctxt;
   461             val s' = Proof_Context.intern_const ctxt s;
   462           in
   463             if Sign.declared_const thy s'
   464             then (pat_tr ctxt p e opti, false)
   465             else (Syntax_Trans.abs_tr [p, e], true)
   466           end
   467       | _ => (pat_tr ctxt p e opti, false));
   468 
   469     fun lc_tr ctxt [e, Const (@{syntax_const "_lc_test"}, _) $ b, qs] =
   470           let
   471             val res =
   472               (case qs of
   473                 Const (@{syntax_const "_lc_end"}, _) => single e
   474               | Const (@{syntax_const "_lc_quals"}, _) $ q $ qs => lc_tr ctxt [e, q, qs]);
   475           in IfC $ b $ res $ NilC end
   476       | lc_tr ctxt
   477             [e, Const (@{syntax_const "_lc_gen"}, _) $ p $ es,
   478               Const(@{syntax_const "_lc_end"}, _)] =
   479           (case abs_tr ctxt p e true of
   480             (f, true) => mapC $ f $ es
   481           | (f, false) => concatC $ (mapC $ f $ es))
   482       | lc_tr ctxt
   483             [e, Const (@{syntax_const "_lc_gen"}, _) $ p $ es,
   484               Const (@{syntax_const "_lc_quals"}, _) $ q $ qs] =
   485           let val e' = lc_tr ctxt [e, q, qs];
   486           in concatC $ (mapC $ (fst (abs_tr ctxt p e' false)) $ es) end;
   487 
   488   in [(@{syntax_const "_listcompr"}, lc_tr)] end
   489 *}
   490 
   491 ML_val {*
   492   let
   493     val read = Syntax.read_term @{context};
   494     fun check s1 s2 = read s1 aconv read s2 orelse error ("Check failed: " ^ quote s1);
   495   in
   496     check "[(x,y,z). b]" "if b then [(x, y, z)] else []";
   497     check "[(x,y,z). x\<leftarrow>xs]" "map (\<lambda>x. (x, y, z)) xs";
   498     check "[e x y. x\<leftarrow>xs, y\<leftarrow>ys]" "concat (map (\<lambda>x. map (\<lambda>y. e x y) ys) xs)";
   499     check "[(x,y,z). x<a, x>b]" "if x < a then if b < x then [(x, y, z)] else [] else []";
   500     check "[(x,y,z). x\<leftarrow>xs, x>b]" "concat (map (\<lambda>x. if b < x then [(x, y, z)] else []) xs)";
   501     check "[(x,y,z). x<a, x\<leftarrow>xs]" "if x < a then map (\<lambda>x. (x, y, z)) xs else []";
   502     check "[(x,y). Cons True x \<leftarrow> xs]"
   503       "concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | True # x \<Rightarrow> [(x, y)] | False # x \<Rightarrow> []) xs)";
   504     check "[(x,y,z). Cons x [] \<leftarrow> xs]"
   505       "concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | [x] \<Rightarrow> [(x, y, z)] | x # aa # lista \<Rightarrow> []) xs)";
   506     check "[(x,y,z). x<a, x>b, x=d]"
   507       "if x < a then if b < x then if x = d then [(x, y, z)] else [] else [] else []";
   508     check "[(x,y,z). x<a, x>b, y\<leftarrow>ys]"
   509       "if x < a then if b < x then map (\<lambda>y. (x, y, z)) ys else [] else []";
   510     check "[(x,y,z). x<a, x\<leftarrow>xs,y>b]"
   511       "if x < a then concat (map (\<lambda>x. if b < y then [(x, y, z)] else []) xs) else []";
   512     check "[(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys]"
   513       "if x < a then concat (map (\<lambda>x. map (\<lambda>y. (x, y, z)) ys) xs) else []";
   514     check "[(x,y,z). x\<leftarrow>xs, x>b, y<a]"
   515       "concat (map (\<lambda>x. if b < x then if y < a then [(x, y, z)] else [] else []) xs)";
   516     check "[(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys]"
   517       "concat (map (\<lambda>x. if b < x then map (\<lambda>y. (x, y, z)) ys else []) xs)";
   518     check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x]"
   519       "concat (map (\<lambda>x. concat (map (\<lambda>y. if x < y then [(x, y, z)] else []) ys)) xs)";
   520     check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs]"
   521       "concat (map (\<lambda>x. concat (map (\<lambda>y. map (\<lambda>z. (x, y, z)) zs) ys)) xs)"
   522   end;
   523 *}
   524 
   525 (*
   526 term "[(x,y). x\<leftarrow>xs, let xx = x+x, y\<leftarrow>ys, y \<noteq> xx]"
   527 *)
   528 
   529 
   530 ML {*
   531 (* Simproc for rewriting list comprehensions applied to List.set to set
   532    comprehension. *)
   533 
   534 signature LIST_TO_SET_COMPREHENSION =
   535 sig
   536   val simproc : Proof.context -> cterm -> thm option
   537 end
   538 
   539 structure List_to_Set_Comprehension : LIST_TO_SET_COMPREHENSION =
   540 struct
   541 
   542 (* conversion *)
   543 
   544 fun all_exists_conv cv ctxt ct =
   545   (case Thm.term_of ct of
   546     Const (@{const_name HOL.Ex}, _) $ Abs _ =>
   547       Conv.arg_conv (Conv.abs_conv (all_exists_conv cv o #2) ctxt) ct
   548   | _ => cv ctxt ct)
   549 
   550 fun all_but_last_exists_conv cv ctxt ct =
   551   (case Thm.term_of ct of
   552     Const (@{const_name HOL.Ex}, _) $ Abs (_, _, Const (@{const_name HOL.Ex}, _) $ _) =>
   553       Conv.arg_conv (Conv.abs_conv (all_but_last_exists_conv cv o #2) ctxt) ct
   554   | _ => cv ctxt ct)
   555 
   556 fun Collect_conv cv ctxt ct =
   557   (case Thm.term_of ct of
   558     Const (@{const_name Set.Collect}, _) $ Abs _ => Conv.arg_conv (Conv.abs_conv cv ctxt) ct
   559   | _ => raise CTERM ("Collect_conv", [ct]))
   560 
   561 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)
   562 
   563 fun conjunct_assoc_conv ct =
   564   Conv.try_conv
   565     (rewr_conv' @{thm conj_assoc} then_conv HOLogic.conj_conv Conv.all_conv conjunct_assoc_conv) ct
   566 
   567 fun right_hand_set_comprehension_conv conv ctxt =
   568   HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv
   569     (Collect_conv (all_exists_conv conv o #2) ctxt))
   570 
   571 
   572 (* term abstraction of list comprehension patterns *)
   573 
   574 datatype termlets = If | Case of (typ * int)
   575 
   576 fun simproc ctxt redex =
   577   let
   578     val set_Nil_I = @{thm trans} OF [@{thm set_simps(1)}, @{thm empty_def}]
   579     val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}
   580     val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}
   581     val del_refl_eq = @{lemma "(t = t & P) == P" by simp}
   582     fun mk_set T = Const (@{const_name List.set}, HOLogic.listT T --> HOLogic.mk_setT T)
   583     fun dest_set (Const (@{const_name List.set}, _) $ xs) = xs
   584     fun dest_singleton_list (Const (@{const_name List.Cons}, _)
   585           $ t $ (Const (@{const_name List.Nil}, _))) = t
   586       | dest_singleton_list t = raise TERM ("dest_singleton_list", [t])
   587     (* We check that one case returns a singleton list and all other cases
   588        return [], and return the index of the one singleton list case *)
   589     fun possible_index_of_singleton_case cases =
   590       let
   591         fun check (i, case_t) s =
   592           (case strip_abs_body case_t of
   593             (Const (@{const_name List.Nil}, _)) => s
   594           | _ => (case s of SOME NONE => SOME (SOME i) | _ => NONE))
   595       in
   596         fold_index check cases (SOME NONE) |> the_default NONE
   597       end
   598     (* returns (case_expr type index chosen_case constr_name) option  *)
   599     fun dest_case case_term =
   600       let
   601         val (case_const, args) = strip_comb case_term
   602       in
   603         (case try dest_Const case_const of
   604           SOME (c, T) =>
   605             (case Ctr_Sugar.ctr_sugar_of_case ctxt c of
   606               SOME {ctrs, ...} =>
   607                 (case possible_index_of_singleton_case (fst (split_last args)) of
   608                   SOME i =>
   609                     let
   610                       val constr_names = map (fst o dest_Const) ctrs
   611                       val (Ts, _) = strip_type T
   612                       val T' = List.last Ts
   613                     in SOME (List.last args, T', i, nth args i, nth constr_names i) end
   614                 | NONE => NONE)
   615             | NONE => NONE)
   616         | NONE => NONE)
   617       end
   618     (* returns condition continuing term option *)
   619     fun dest_if (Const (@{const_name If}, _) $ cond $ then_t $ Const (@{const_name Nil}, _)) =
   620           SOME (cond, then_t)
   621       | dest_if _ = NONE
   622     fun tac _ [] = rtac set_singleton 1 ORELSE rtac inst_Collect_mem_eq 1
   623       | tac ctxt (If :: cont) =
   624           Splitter.split_tac [@{thm split_if}] 1
   625           THEN rtac @{thm conjI} 1
   626           THEN rtac @{thm impI} 1
   627           THEN Subgoal.FOCUS (fn {prems, context, ...} =>
   628             CONVERSION (right_hand_set_comprehension_conv (K
   629               (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv
   630                then_conv
   631                rewr_conv' @{lemma "(True & P) = P" by simp})) context) 1) ctxt 1
   632           THEN tac ctxt cont
   633           THEN rtac @{thm impI} 1
   634           THEN Subgoal.FOCUS (fn {prems, context, ...} =>
   635               CONVERSION (right_hand_set_comprehension_conv (K
   636                 (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv
   637                  then_conv rewr_conv' @{lemma "(False & P) = False" by simp})) context) 1) ctxt 1
   638           THEN rtac set_Nil_I 1
   639       | tac ctxt (Case (T, i) :: cont) =
   640           let
   641             val SOME {injects, distincts, case_thms, split, ...} =
   642               Ctr_Sugar.ctr_sugar_of ctxt (fst (dest_Type T))
   643           in
   644             (* do case distinction *)
   645             Splitter.split_tac [split] 1
   646             THEN EVERY (map_index (fn (i', _) =>
   647               (if i' < length case_thms - 1 then rtac @{thm conjI} 1 else all_tac)
   648               THEN REPEAT_DETERM (rtac @{thm allI} 1)
   649               THEN rtac @{thm impI} 1
   650               THEN (if i' = i then
   651                 (* continue recursively *)
   652                 Subgoal.FOCUS (fn {prems, context, ...} =>
   653                   CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K
   654                       ((HOLogic.conj_conv
   655                         (HOLogic.eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv
   656                           (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq injects))))
   657                         Conv.all_conv)
   658                         then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))
   659                         then_conv conjunct_assoc_conv)) context
   660                     then_conv (HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt) =>
   661                       Conv.repeat_conv
   662                         (all_but_last_exists_conv
   663                           (K (rewr_conv'
   664                             @{lemma "(EX x. x = t & P x) = P t" by simp})) ctxt)) context)))) 1) ctxt 1
   665                 THEN tac ctxt cont
   666               else
   667                 Subgoal.FOCUS (fn {prems, context, ...} =>
   668                   CONVERSION
   669                     (right_hand_set_comprehension_conv (K
   670                       (HOLogic.conj_conv
   671                         ((HOLogic.eq_conv Conv.all_conv
   672                           (rewr_conv' (List.last prems))) then_conv
   673                           (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) distincts)))
   674                         Conv.all_conv then_conv
   675                         (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv
   676                       HOLogic.Trueprop_conv
   677                         (HOLogic.eq_conv Conv.all_conv
   678                           (Collect_conv (fn (_, ctxt) =>
   679                             Conv.repeat_conv
   680                               (Conv.bottom_conv
   681                                 (K (rewr_conv'
   682                                   @{lemma "(EX x. P) = P" by simp})) ctxt)) context))) 1) ctxt 1
   683                 THEN rtac set_Nil_I 1)) case_thms)
   684           end
   685     fun make_inner_eqs bound_vs Tis eqs t =
   686       (case dest_case t of
   687         SOME (x, T, i, cont, constr_name) =>
   688           let
   689             val (vs, body) = strip_abs (Envir.eta_long (map snd bound_vs) cont)
   690             val x' = incr_boundvars (length vs) x
   691             val eqs' = map (incr_boundvars (length vs)) eqs
   692             val constr_t =
   693               list_comb
   694                 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))
   695             val constr_eq = Const (@{const_name HOL.eq}, T --> T --> @{typ bool}) $ constr_t $ x'
   696           in
   697             make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body
   698           end
   699       | NONE =>
   700           (case dest_if t of
   701             SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont
   702           | NONE =>
   703             if eqs = [] then NONE (* no rewriting, nothing to be done *)
   704             else
   705               let
   706                 val Type (@{type_name List.list}, [rT]) = fastype_of1 (map snd bound_vs, t)
   707                 val pat_eq =
   708                   (case try dest_singleton_list t of
   709                     SOME t' =>
   710                       Const (@{const_name HOL.eq}, rT --> rT --> @{typ bool}) $
   711                         Bound (length bound_vs) $ t'
   712                   | NONE =>
   713                       Const (@{const_name Set.member}, rT --> HOLogic.mk_setT rT --> @{typ bool}) $
   714                         Bound (length bound_vs) $ (mk_set rT $ t))
   715                 val reverse_bounds = curry subst_bounds
   716                   ((map Bound ((length bound_vs - 1) downto 0)) @ [Bound (length bound_vs)])
   717                 val eqs' = map reverse_bounds eqs
   718                 val pat_eq' = reverse_bounds pat_eq
   719                 val inner_t =
   720                   fold (fn (_, T) => fn t => HOLogic.exists_const T $ absdummy T t)
   721                     (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')
   722                 val lhs = term_of redex
   723                 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)
   724                 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))
   725               in
   726                 SOME
   727                   ((Goal.prove ctxt [] [] rewrite_rule_t
   728                     (fn {context, ...} => tac context (rev Tis))) RS @{thm eq_reflection})
   729               end))
   730   in
   731     make_inner_eqs [] [] [] (dest_set (term_of redex))
   732   end
   733 
   734 end
   735 *}
   736 
   737 simproc_setup list_to_set_comprehension ("set xs") = {* K List_to_Set_Comprehension.simproc *}
   738 
   739 code_datatype set coset
   740 
   741 hide_const (open) coset
   742 
   743 
   744 subsubsection {* @{const Nil} and @{const Cons} *}
   745 
   746 lemma not_Cons_self [simp]:
   747   "xs \<noteq> x # xs"
   748 by (induct xs) auto
   749 
   750 lemma not_Cons_self2 [simp]:
   751   "x # xs \<noteq> xs"
   752 by (rule not_Cons_self [symmetric])
   753 
   754 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"
   755 by (induct xs) auto
   756 
   757 lemma tl_Nil: "tl xs = [] \<longleftrightarrow> xs = [] \<or> (EX x. xs = [x])"
   758 by (cases xs) auto
   759 
   760 lemma Nil_tl: "[] = tl xs \<longleftrightarrow> xs = [] \<or> (EX x. xs = [x])"
   761 by (cases xs) auto
   762 
   763 lemma length_induct:
   764   "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"
   765 by (fact measure_induct)
   766 
   767 lemma list_nonempty_induct [consumes 1, case_names single cons]:
   768   assumes "xs \<noteq> []"
   769   assumes single: "\<And>x. P [x]"
   770   assumes cons: "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)"
   771   shows "P xs"
   772 using `xs \<noteq> []` proof (induct xs)
   773   case Nil then show ?case by simp
   774 next
   775   case (Cons x xs)
   776   show ?case
   777   proof (cases xs)
   778     case Nil
   779     with single show ?thesis by simp
   780   next
   781     case Cons
   782     show ?thesis
   783     proof (rule cons)
   784       from Cons show "xs \<noteq> []" by simp
   785       with Cons.hyps show "P xs" .
   786     qed
   787   qed
   788 qed
   789 
   790 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"
   791   by (auto intro!: inj_onI)
   792 
   793 
   794 subsubsection {* @{const length} *}
   795 
   796 text {*
   797   Needs to come before @{text "@"} because of theorem @{text
   798   append_eq_append_conv}.
   799 *}
   800 
   801 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"
   802 by (induct xs) auto
   803 
   804 lemma length_map [simp]: "length (map f xs) = length xs"
   805 by (induct xs) auto
   806 
   807 lemma length_rev [simp]: "length (rev xs) = length xs"
   808 by (induct xs) auto
   809 
   810 lemma length_tl [simp]: "length (tl xs) = length xs - 1"
   811 by (cases xs) auto
   812 
   813 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"
   814 by (induct xs) auto
   815 
   816 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"
   817 by (induct xs) auto
   818 
   819 lemma length_pos_if_in_set: "x : set xs \<Longrightarrow> length xs > 0"
   820 by auto
   821 
   822 lemma length_Suc_conv:
   823 "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
   824 by (induct xs) auto
   825 
   826 lemma Suc_length_conv:
   827 "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
   828 apply (induct xs, simp, simp)
   829 apply blast
   830 done
   831 
   832 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False"
   833   by (induct xs) auto
   834 
   835 lemma list_induct2 [consumes 1, case_names Nil Cons]:
   836   "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>
   837    (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))
   838    \<Longrightarrow> P xs ys"
   839 proof (induct xs arbitrary: ys)
   840   case Nil then show ?case by simp
   841 next
   842   case (Cons x xs ys) then show ?case by (cases ys) simp_all
   843 qed
   844 
   845 lemma list_induct3 [consumes 2, case_names Nil Cons]:
   846   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>
   847    (\<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))
   848    \<Longrightarrow> P xs ys zs"
   849 proof (induct xs arbitrary: ys zs)
   850   case Nil then show ?case by simp
   851 next
   852   case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)
   853     (cases zs, simp_all)
   854 qed
   855 
   856 lemma list_induct4 [consumes 3, case_names Nil Cons]:
   857   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>
   858    P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>
   859    length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>
   860    P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"
   861 proof (induct xs arbitrary: ys zs ws)
   862   case Nil then show ?case by simp
   863 next
   864   case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)
   865 qed
   866 
   867 lemma list_induct2': 
   868   "\<lbrakk> P [] [];
   869   \<And>x xs. P (x#xs) [];
   870   \<And>y ys. P [] (y#ys);
   871    \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>
   872  \<Longrightarrow> P xs ys"
   873 by (induct xs arbitrary: ys) (case_tac x, auto)+
   874 
   875 lemma list_all2_iff:
   876   "list_all2 P xs ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x, y) \<in> set (zip xs ys). P x y)"
   877 by (induct xs ys rule: list_induct2') auto
   878 
   879 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"
   880 by (rule Eq_FalseI) auto
   881 
   882 simproc_setup list_neq ("(xs::'a list) = ys") = {*
   883 (*
   884 Reduces xs=ys to False if xs and ys cannot be of the same length.
   885 This is the case if the atomic sublists of one are a submultiset
   886 of those of the other list and there are fewer Cons's in one than the other.
   887 *)
   888 
   889 let
   890 
   891 fun len (Const(@{const_name Nil},_)) acc = acc
   892   | len (Const(@{const_name Cons},_) $ _ $ xs) (ts,n) = len xs (ts,n+1)
   893   | len (Const(@{const_name append},_) $ xs $ ys) acc = len xs (len ys acc)
   894   | len (Const(@{const_name rev},_) $ xs) acc = len xs acc
   895   | len (Const(@{const_name map},_) $ _ $ xs) acc = len xs acc
   896   | len t (ts,n) = (t::ts,n);
   897 
   898 val ss = simpset_of @{context};
   899 
   900 fun list_neq ctxt ct =
   901   let
   902     val (Const(_,eqT) $ lhs $ rhs) = Thm.term_of ct;
   903     val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);
   904     fun prove_neq() =
   905       let
   906         val Type(_,listT::_) = eqT;
   907         val size = HOLogic.size_const listT;
   908         val eq_len = HOLogic.mk_eq (size $ lhs, size $ rhs);
   909         val neq_len = HOLogic.mk_Trueprop (HOLogic.Not $ eq_len);
   910         val thm = Goal.prove ctxt [] [] neq_len
   911           (K (simp_tac (put_simpset ss ctxt) 1));
   912       in SOME (thm RS @{thm neq_if_length_neq}) end
   913   in
   914     if m < n andalso submultiset (op aconv) (ls,rs) orelse
   915        n < m andalso submultiset (op aconv) (rs,ls)
   916     then prove_neq() else NONE
   917   end;
   918 in K list_neq end;
   919 *}
   920 
   921 
   922 subsubsection {* @{text "@"} -- append *}
   923 
   924 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
   925 by (induct xs) auto
   926 
   927 lemma append_Nil2 [simp]: "xs @ [] = xs"
   928 by (induct xs) auto
   929 
   930 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"
   931 by (induct xs) auto
   932 
   933 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"
   934 by (induct xs) auto
   935 
   936 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"
   937 by (induct xs) auto
   938 
   939 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"
   940 by (induct xs) auto
   941 
   942 lemma append_eq_append_conv [simp]:
   943  "length xs = length ys \<or> length us = length vs
   944  ==> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"
   945 apply (induct xs arbitrary: ys)
   946  apply (case_tac ys, simp, force)
   947 apply (case_tac ys, force, simp)
   948 done
   949 
   950 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =
   951   (EX us. xs = zs @ us & us @ ys = ts | xs @ us = zs & ys = us@ ts)"
   952 apply (induct xs arbitrary: ys zs ts)
   953  apply fastforce
   954 apply(case_tac zs)
   955  apply simp
   956 apply fastforce
   957 done
   958 
   959 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"
   960 by simp
   961 
   962 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"
   963 by simp
   964 
   965 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"
   966 by simp
   967 
   968 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"
   969 using append_same_eq [of _ _ "[]"] by auto
   970 
   971 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"
   972 using append_same_eq [of "[]"] by auto
   973 
   974 lemma hd_Cons_tl [simp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"
   975 by (induct xs) auto
   976 
   977 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
   978 by (induct xs) auto
   979 
   980 lemma hd_append2 [simp]: "xs \<noteq> [] ==> hd (xs @ ys) = hd xs"
   981 by (simp add: hd_append split: list.split)
   982 
   983 lemma tl_append: "tl (xs @ ys) = (case xs of [] => tl ys | z#zs => zs @ ys)"
   984 by (simp split: list.split)
   985 
   986 lemma tl_append2 [simp]: "xs \<noteq> [] ==> tl (xs @ ys) = tl xs @ ys"
   987 by (simp add: tl_append split: list.split)
   988 
   989 
   990 lemma Cons_eq_append_conv: "x#xs = ys@zs =
   991  (ys = [] & x#xs = zs | (EX ys'. x#ys' = ys & xs = ys'@zs))"
   992 by(cases ys) auto
   993 
   994 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =
   995  (ys = [] & zs = x#xs | (EX ys'. ys = x#ys' & ys'@zs = xs))"
   996 by(cases ys) auto
   997 
   998 
   999 text {* Trivial rules for solving @{text "@"}-equations automatically. *}
  1000 
  1001 lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"
  1002 by simp
  1003 
  1004 lemma Cons_eq_appendI:
  1005 "[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"
  1006 by (drule sym) simp
  1007 
  1008 lemma append_eq_appendI:
  1009 "[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"
  1010 by (drule sym) simp
  1011 
  1012 
  1013 text {*
  1014 Simplification procedure for all list equalities.
  1015 Currently only tries to rearrange @{text "@"} to see if
  1016 - both lists end in a singleton list,
  1017 - or both lists end in the same list.
  1018 *}
  1019 
  1020 simproc_setup list_eq ("(xs::'a list) = ys")  = {*
  1021   let
  1022     fun last (cons as Const (@{const_name Cons}, _) $ _ $ xs) =
  1023           (case xs of Const (@{const_name Nil}, _) => cons | _ => last xs)
  1024       | last (Const(@{const_name append},_) $ _ $ ys) = last ys
  1025       | last t = t;
  1026     
  1027     fun list1 (Const(@{const_name Cons},_) $ _ $ Const(@{const_name Nil},_)) = true
  1028       | list1 _ = false;
  1029     
  1030     fun butlast ((cons as Const(@{const_name Cons},_) $ x) $ xs) =
  1031           (case xs of Const (@{const_name Nil}, _) => xs | _ => cons $ butlast xs)
  1032       | butlast ((app as Const (@{const_name append}, _) $ xs) $ ys) = app $ butlast ys
  1033       | butlast xs = Const(@{const_name Nil}, fastype_of xs);
  1034     
  1035     val rearr_ss =
  1036       simpset_of (put_simpset HOL_basic_ss @{context}
  1037         addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}]);
  1038     
  1039     fun list_eq ctxt (F as (eq as Const(_,eqT)) $ lhs $ rhs) =
  1040       let
  1041         val lastl = last lhs and lastr = last rhs;
  1042         fun rearr conv =
  1043           let
  1044             val lhs1 = butlast lhs and rhs1 = butlast rhs;
  1045             val Type(_,listT::_) = eqT
  1046             val appT = [listT,listT] ---> listT
  1047             val app = Const(@{const_name append},appT)
  1048             val F2 = eq $ (app$lhs1$lastl) $ (app$rhs1$lastr)
  1049             val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (F,F2));
  1050             val thm = Goal.prove ctxt [] [] eq
  1051               (K (simp_tac (put_simpset rearr_ss ctxt) 1));
  1052           in SOME ((conv RS (thm RS trans)) RS eq_reflection) end;
  1053       in
  1054         if list1 lastl andalso list1 lastr then rearr @{thm append1_eq_conv}
  1055         else if lastl aconv lastr then rearr @{thm append_same_eq}
  1056         else NONE
  1057       end;
  1058   in fn _ => fn ctxt => fn ct => list_eq ctxt (term_of ct) end;
  1059 *}
  1060 
  1061 
  1062 subsubsection {* @{const map} *}
  1063 
  1064 lemma hd_map:
  1065   "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"
  1066   by (cases xs) simp_all
  1067 
  1068 lemma map_tl:
  1069   "map f (tl xs) = tl (map f xs)"
  1070   by (cases xs) simp_all
  1071 
  1072 lemma map_ext: "(!!x. x : set xs --> f x = g x) ==> map f xs = map g xs"
  1073 by (induct xs) simp_all
  1074 
  1075 lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"
  1076 by (rule ext, induct_tac xs) auto
  1077 
  1078 lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"
  1079 by (induct xs) auto
  1080 
  1081 lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"
  1082 by (induct xs) auto
  1083 
  1084 lemma map_comp_map[simp]: "((map f) o (map g)) = map(f o g)"
  1085 apply(rule ext)
  1086 apply(simp)
  1087 done
  1088 
  1089 lemma rev_map: "rev (map f xs) = map f (rev xs)"
  1090 by (induct xs) auto
  1091 
  1092 lemma map_eq_conv[simp]: "(map f xs = map g xs) = (!x : set xs. f x = g x)"
  1093 by (induct xs) auto
  1094 
  1095 lemma map_cong [fundef_cong]:
  1096   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g ys"
  1097   by simp
  1098 
  1099 lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"
  1100 by (cases xs) auto
  1101 
  1102 lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"
  1103 by (cases xs) auto
  1104 
  1105 lemma map_eq_Cons_conv:
  1106  "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"
  1107 by (cases xs) auto
  1108 
  1109 lemma Cons_eq_map_conv:
  1110  "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"
  1111 by (cases ys) auto
  1112 
  1113 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]
  1114 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]
  1115 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]
  1116 
  1117 lemma ex_map_conv:
  1118   "(EX xs. ys = map f xs) = (ALL y : set ys. EX x. y = f x)"
  1119 by(induct ys, auto simp add: Cons_eq_map_conv)
  1120 
  1121 lemma map_eq_imp_length_eq:
  1122   assumes "map f xs = map g ys"
  1123   shows "length xs = length ys"
  1124   using assms
  1125 proof (induct ys arbitrary: xs)
  1126   case Nil then show ?case by simp
  1127 next
  1128   case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto
  1129   from Cons xs have "map f zs = map g ys" by simp
  1130   with Cons have "length zs = length ys" by blast
  1131   with xs show ?case by simp
  1132 qed
  1133   
  1134 lemma map_inj_on:
  1135  "[| map f xs = map f ys; inj_on f (set xs Un set ys) |]
  1136   ==> xs = ys"
  1137 apply(frule map_eq_imp_length_eq)
  1138 apply(rotate_tac -1)
  1139 apply(induct rule:list_induct2)
  1140  apply simp
  1141 apply(simp)
  1142 apply (blast intro:sym)
  1143 done
  1144 
  1145 lemma inj_on_map_eq_map:
  1146  "inj_on f (set xs Un set ys) \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"
  1147 by(blast dest:map_inj_on)
  1148 
  1149 lemma map_injective:
  1150  "map f xs = map f ys ==> inj f ==> xs = ys"
  1151 by (induct ys arbitrary: xs) (auto dest!:injD)
  1152 
  1153 lemma inj_map_eq_map[simp]: "inj f \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"
  1154 by(blast dest:map_injective)
  1155 
  1156 lemma inj_mapI: "inj f ==> inj (map f)"
  1157 by (iprover dest: map_injective injD intro: inj_onI)
  1158 
  1159 lemma inj_mapD: "inj (map f) ==> inj f"
  1160 apply (unfold inj_on_def, clarify)
  1161 apply (erule_tac x = "[x]" in ballE)
  1162  apply (erule_tac x = "[y]" in ballE, simp, blast)
  1163 apply blast
  1164 done
  1165 
  1166 lemma inj_map[iff]: "inj (map f) = inj f"
  1167 by (blast dest: inj_mapD intro: inj_mapI)
  1168 
  1169 lemma inj_on_mapI: "inj_on f (\<Union>(set ` A)) \<Longrightarrow> inj_on (map f) A"
  1170 apply(rule inj_onI)
  1171 apply(erule map_inj_on)
  1172 apply(blast intro:inj_onI dest:inj_onD)
  1173 done
  1174 
  1175 lemma map_idI: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = x) \<Longrightarrow> map f xs = xs"
  1176 by (induct xs, auto)
  1177 
  1178 lemma map_fun_upd [simp]: "y \<notin> set xs \<Longrightarrow> map (f(y:=v)) xs = map f xs"
  1179 by (induct xs) auto
  1180 
  1181 lemma map_fst_zip[simp]:
  1182   "length xs = length ys \<Longrightarrow> map fst (zip xs ys) = xs"
  1183 by (induct rule:list_induct2, simp_all)
  1184 
  1185 lemma map_snd_zip[simp]:
  1186   "length xs = length ys \<Longrightarrow> map snd (zip xs ys) = ys"
  1187 by (induct rule:list_induct2, simp_all)
  1188 
  1189 functor map: map
  1190 by (simp_all add: id_def)
  1191 
  1192 declare map.id [simp]
  1193 
  1194 
  1195 subsubsection {* @{const rev} *}
  1196 
  1197 lemma rev_append [simp]: "rev (xs @ ys) = rev ys @ rev xs"
  1198 by (induct xs) auto
  1199 
  1200 lemma rev_rev_ident [simp]: "rev (rev xs) = xs"
  1201 by (induct xs) auto
  1202 
  1203 lemma rev_swap: "(rev xs = ys) = (xs = rev ys)"
  1204 by auto
  1205 
  1206 lemma rev_is_Nil_conv [iff]: "(rev xs = []) = (xs = [])"
  1207 by (induct xs) auto
  1208 
  1209 lemma Nil_is_rev_conv [iff]: "([] = rev xs) = (xs = [])"
  1210 by (induct xs) auto
  1211 
  1212 lemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"
  1213 by (cases xs) auto
  1214 
  1215 lemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"
  1216 by (cases xs) auto
  1217 
  1218 lemma rev_is_rev_conv [iff]: "(rev xs = rev ys) = (xs = ys)"
  1219 apply (induct xs arbitrary: ys, force)
  1220 apply (case_tac ys, simp, force)
  1221 done
  1222 
  1223 lemma inj_on_rev[iff]: "inj_on rev A"
  1224 by(simp add:inj_on_def)
  1225 
  1226 lemma rev_induct [case_names Nil snoc]:
  1227   "[| P []; !!x xs. P xs ==> P (xs @ [x]) |] ==> P xs"
  1228 apply(simplesubst rev_rev_ident[symmetric])
  1229 apply(rule_tac list = "rev xs" in list.induct, simp_all)
  1230 done
  1231 
  1232 lemma rev_exhaust [case_names Nil snoc]:
  1233   "(xs = [] ==> P) ==>(!!ys y. xs = ys @ [y] ==> P) ==> P"
  1234 by (induct xs rule: rev_induct) auto
  1235 
  1236 lemmas rev_cases = rev_exhaust
  1237 
  1238 lemma rev_eq_Cons_iff[iff]: "(rev xs = y#ys) = (xs = rev ys @ [y])"
  1239 by(rule rev_cases[of xs]) auto
  1240 
  1241 
  1242 subsubsection {* @{const set} *}
  1243 
  1244 lemma finite_set [iff]: "finite (set xs)"
  1245 by (induct xs) auto
  1246 
  1247 lemma set_append [simp]: "set (xs @ ys) = (set xs \<union> set ys)"
  1248 by (induct xs) auto
  1249 
  1250 lemma hd_in_set[simp]: "xs \<noteq> [] \<Longrightarrow> hd xs : set xs"
  1251 by(cases xs) auto
  1252 
  1253 lemma set_subset_Cons: "set xs \<subseteq> set (x # xs)"
  1254 by auto
  1255 
  1256 lemma set_ConsD: "y \<in> set (x # xs) \<Longrightarrow> y=x \<or> y \<in> set xs" 
  1257 by auto
  1258 
  1259 lemma set_empty [iff]: "(set xs = {}) = (xs = [])"
  1260 by (induct xs) auto
  1261 
  1262 lemma set_empty2[iff]: "({} = set xs) = (xs = [])"
  1263 by(induct xs) auto
  1264 
  1265 lemma set_rev [simp]: "set (rev xs) = set xs"
  1266 by (induct xs) auto
  1267 
  1268 lemma set_map [simp]: "set (map f xs) = f`(set xs)"
  1269 by (induct xs) auto
  1270 
  1271 lemma set_filter [simp]: "set (filter P xs) = {x. x : set xs \<and> P x}"
  1272 by (induct xs) auto
  1273 
  1274 lemma set_upt [simp]: "set[i..<j] = {i..<j}"
  1275 by (induct j) auto
  1276 
  1277 
  1278 lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
  1279 proof (induct xs)
  1280   case Nil thus ?case by simp
  1281 next
  1282   case Cons thus ?case by (auto intro: Cons_eq_appendI)
  1283 qed
  1284 
  1285 lemma in_set_conv_decomp: "x \<in> set xs \<longleftrightarrow> (\<exists>ys zs. xs = ys @ x # zs)"
  1286   by (auto elim: split_list)
  1287 
  1288 lemma split_list_first: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys"
  1289 proof (induct xs)
  1290   case Nil thus ?case by simp
  1291 next
  1292   case (Cons a xs)
  1293   show ?case
  1294   proof cases
  1295     assume "x = a" thus ?case using Cons by fastforce
  1296   next
  1297     assume "x \<noteq> a" thus ?case using Cons by(fastforce intro!: Cons_eq_appendI)
  1298   qed
  1299 qed
  1300 
  1301 lemma in_set_conv_decomp_first:
  1302   "(x : set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys)"
  1303   by (auto dest!: split_list_first)
  1304 
  1305 lemma split_list_last: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs"
  1306 proof (induct xs rule: rev_induct)
  1307   case Nil thus ?case by simp
  1308 next
  1309   case (snoc a xs)
  1310   show ?case
  1311   proof cases
  1312     assume "x = a" thus ?case using snoc by (auto intro!: exI)
  1313   next
  1314     assume "x \<noteq> a" thus ?case using snoc by fastforce
  1315   qed
  1316 qed
  1317 
  1318 lemma in_set_conv_decomp_last:
  1319   "(x : set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs)"
  1320   by (auto dest!: split_list_last)
  1321 
  1322 lemma split_list_prop: "\<exists>x \<in> set xs. P x \<Longrightarrow> \<exists>ys x zs. xs = ys @ x # zs & P x"
  1323 proof (induct xs)
  1324   case Nil thus ?case by simp
  1325 next
  1326   case Cons thus ?case
  1327     by(simp add:Bex_def)(metis append_Cons append.simps(1))
  1328 qed
  1329 
  1330 lemma split_list_propE:
  1331   assumes "\<exists>x \<in> set xs. P x"
  1332   obtains ys x zs where "xs = ys @ x # zs" and "P x"
  1333 using split_list_prop [OF assms] by blast
  1334 
  1335 lemma split_list_first_prop:
  1336   "\<exists>x \<in> set xs. P x \<Longrightarrow>
  1337    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"
  1338 proof (induct xs)
  1339   case Nil thus ?case by simp
  1340 next
  1341   case (Cons x xs)
  1342   show ?case
  1343   proof cases
  1344     assume "P x"
  1345     hence "x # xs = [] @ x # xs \<and> P x \<and> (\<forall>y\<in>set []. \<not> P y)" by simp
  1346     thus ?thesis by fast
  1347   next
  1348     assume "\<not> P x"
  1349     hence "\<exists>x\<in>set xs. P x" using Cons(2) by simp
  1350     thus ?thesis using `\<not> P x` Cons(1) by (metis append_Cons set_ConsD)
  1351   qed
  1352 qed
  1353 
  1354 lemma split_list_first_propE:
  1355   assumes "\<exists>x \<in> set xs. P x"
  1356   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>y \<in> set ys. \<not> P y"
  1357 using split_list_first_prop [OF assms] by blast
  1358 
  1359 lemma split_list_first_prop_iff:
  1360   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
  1361    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y))"
  1362 by (rule, erule split_list_first_prop) auto
  1363 
  1364 lemma split_list_last_prop:
  1365   "\<exists>x \<in> set xs. P x \<Longrightarrow>
  1366    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z)"
  1367 proof(induct xs rule:rev_induct)
  1368   case Nil thus ?case by simp
  1369 next
  1370   case (snoc x xs)
  1371   show ?case
  1372   proof cases
  1373     assume "P x" thus ?thesis by (auto intro!: exI)
  1374   next
  1375     assume "\<not> P x"
  1376     hence "\<exists>x\<in>set xs. P x" using snoc(2) by simp
  1377     thus ?thesis using `\<not> P x` snoc(1) by fastforce
  1378   qed
  1379 qed
  1380 
  1381 lemma split_list_last_propE:
  1382   assumes "\<exists>x \<in> set xs. P x"
  1383   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>z \<in> set zs. \<not> P z"
  1384 using split_list_last_prop [OF assms] by blast
  1385 
  1386 lemma split_list_last_prop_iff:
  1387   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
  1388    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"
  1389   by rule (erule split_list_last_prop, auto)
  1390 
  1391 
  1392 lemma finite_list: "finite A ==> EX xs. set xs = A"
  1393   by (erule finite_induct) (auto simp add: set_simps(2) [symmetric] simp del: set_simps(2))
  1394 
  1395 lemma card_length: "card (set xs) \<le> length xs"
  1396 by (induct xs) (auto simp add: card_insert_if)
  1397 
  1398 lemma set_minus_filter_out:
  1399   "set xs - {y} = set (filter (\<lambda>x. \<not> (x = y)) xs)"
  1400   by (induct xs) auto
  1401 
  1402 
  1403 subsubsection {* @{const filter} *}
  1404 
  1405 lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"
  1406 by (induct xs) auto
  1407 
  1408 lemma rev_filter: "rev (filter P xs) = filter P (rev xs)"
  1409 by (induct xs) simp_all
  1410 
  1411 lemma filter_filter [simp]: "filter P (filter Q xs) = filter (\<lambda>x. Q x \<and> P x) xs"
  1412 by (induct xs) auto
  1413 
  1414 lemma length_filter_le [simp]: "length (filter P xs) \<le> length xs"
  1415 by (induct xs) (auto simp add: le_SucI)
  1416 
  1417 lemma sum_length_filter_compl:
  1418   "length(filter P xs) + length(filter (%x. ~P x) xs) = length xs"
  1419 by(induct xs) simp_all
  1420 
  1421 lemma filter_True [simp]: "\<forall>x \<in> set xs. P x ==> filter P xs = xs"
  1422 by (induct xs) auto
  1423 
  1424 lemma filter_False [simp]: "\<forall>x \<in> set xs. \<not> P x ==> filter P xs = []"
  1425 by (induct xs) auto
  1426 
  1427 lemma filter_empty_conv: "(filter P xs = []) = (\<forall>x\<in>set xs. \<not> P x)" 
  1428 by (induct xs) simp_all
  1429 
  1430 lemma filter_id_conv: "(filter P xs = xs) = (\<forall>x\<in>set xs. P x)"
  1431 apply (induct xs)
  1432  apply auto
  1433 apply(cut_tac P=P and xs=xs in length_filter_le)
  1434 apply simp
  1435 done
  1436 
  1437 lemma filter_map:
  1438   "filter P (map f xs) = map f (filter (P o f) xs)"
  1439 by (induct xs) simp_all
  1440 
  1441 lemma length_filter_map[simp]:
  1442   "length (filter P (map f xs)) = length(filter (P o f) xs)"
  1443 by (simp add:filter_map)
  1444 
  1445 lemma filter_is_subset [simp]: "set (filter P xs) \<le> set xs"
  1446 by auto
  1447 
  1448 lemma length_filter_less:
  1449   "\<lbrakk> x : set xs; ~ P x \<rbrakk> \<Longrightarrow> length(filter P xs) < length xs"
  1450 proof (induct xs)
  1451   case Nil thus ?case by simp
  1452 next
  1453   case (Cons x xs) thus ?case
  1454     apply (auto split:split_if_asm)
  1455     using length_filter_le[of P xs] apply arith
  1456   done
  1457 qed
  1458 
  1459 lemma length_filter_conv_card:
  1460  "length(filter p xs) = card{i. i < length xs & p(xs!i)}"
  1461 proof (induct xs)
  1462   case Nil thus ?case by simp
  1463 next
  1464   case (Cons x xs)
  1465   let ?S = "{i. i < length xs & p(xs!i)}"
  1466   have fin: "finite ?S" by(fast intro: bounded_nat_set_is_finite)
  1467   show ?case (is "?l = card ?S'")
  1468   proof (cases)
  1469     assume "p x"
  1470     hence eq: "?S' = insert 0 (Suc ` ?S)"
  1471       by(auto simp: image_def split:nat.split dest:gr0_implies_Suc)
  1472     have "length (filter p (x # xs)) = Suc(card ?S)"
  1473       using Cons `p x` by simp
  1474     also have "\<dots> = Suc(card(Suc ` ?S))" using fin
  1475       by (simp add: card_image)
  1476     also have "\<dots> = card ?S'" using eq fin
  1477       by (simp add:card_insert_if) (simp add:image_def)
  1478     finally show ?thesis .
  1479   next
  1480     assume "\<not> p x"
  1481     hence eq: "?S' = Suc ` ?S"
  1482       by(auto simp add: image_def split:nat.split elim:lessE)
  1483     have "length (filter p (x # xs)) = card ?S"
  1484       using Cons `\<not> p x` by simp
  1485     also have "\<dots> = card(Suc ` ?S)" using fin
  1486       by (simp add: card_image)
  1487     also have "\<dots> = card ?S'" using eq fin
  1488       by (simp add:card_insert_if)
  1489     finally show ?thesis .
  1490   qed
  1491 qed
  1492 
  1493 lemma Cons_eq_filterD:
  1494  "x#xs = filter P ys \<Longrightarrow>
  1495   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
  1496   (is "_ \<Longrightarrow> \<exists>us vs. ?P ys us vs")
  1497 proof(induct ys)
  1498   case Nil thus ?case by simp
  1499 next
  1500   case (Cons y ys)
  1501   show ?case (is "\<exists>x. ?Q x")
  1502   proof cases
  1503     assume Py: "P y"
  1504     show ?thesis
  1505     proof cases
  1506       assume "x = y"
  1507       with Py Cons.prems have "?Q []" by simp
  1508       then show ?thesis ..
  1509     next
  1510       assume "x \<noteq> y"
  1511       with Py Cons.prems show ?thesis by simp
  1512     qed
  1513   next
  1514     assume "\<not> P y"
  1515     with Cons obtain us vs where "?P (y#ys) (y#us) vs" by fastforce
  1516     then have "?Q (y#us)" by simp
  1517     then show ?thesis ..
  1518   qed
  1519 qed
  1520 
  1521 lemma filter_eq_ConsD:
  1522  "filter P ys = x#xs \<Longrightarrow>
  1523   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
  1524 by(rule Cons_eq_filterD) simp
  1525 
  1526 lemma filter_eq_Cons_iff:
  1527  "(filter P ys = x#xs) =
  1528   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"
  1529 by(auto dest:filter_eq_ConsD)
  1530 
  1531 lemma Cons_eq_filter_iff:
  1532  "(x#xs = filter P ys) =
  1533   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"
  1534 by(auto dest:Cons_eq_filterD)
  1535 
  1536 lemma filter_cong[fundef_cong]:
  1537  "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x) \<Longrightarrow> filter P xs = filter Q ys"
  1538 apply simp
  1539 apply(erule thin_rl)
  1540 by (induct ys) simp_all
  1541 
  1542 
  1543 subsubsection {* List partitioning *}
  1544 
  1545 primrec partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" where
  1546 "partition P [] = ([], [])" |
  1547 "partition P (x # xs) = 
  1548   (let (yes, no) = partition P xs
  1549    in if P x then (x # yes, no) else (yes, x # no))"
  1550 
  1551 lemma partition_filter1:
  1552     "fst (partition P xs) = filter P xs"
  1553 by (induct xs) (auto simp add: Let_def split_def)
  1554 
  1555 lemma partition_filter2:
  1556     "snd (partition P xs) = filter (Not o P) xs"
  1557 by (induct xs) (auto simp add: Let_def split_def)
  1558 
  1559 lemma partition_P:
  1560   assumes "partition P xs = (yes, no)"
  1561   shows "(\<forall>p \<in> set yes.  P p) \<and> (\<forall>p  \<in> set no. \<not> P p)"
  1562 proof -
  1563   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"
  1564     by simp_all
  1565   then show ?thesis by (simp_all add: partition_filter1 partition_filter2)
  1566 qed
  1567 
  1568 lemma partition_set:
  1569   assumes "partition P xs = (yes, no)"
  1570   shows "set yes \<union> set no = set xs"
  1571 proof -
  1572   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"
  1573     by simp_all
  1574   then show ?thesis by (auto simp add: partition_filter1 partition_filter2) 
  1575 qed
  1576 
  1577 lemma partition_filter_conv[simp]:
  1578   "partition f xs = (filter f xs,filter (Not o f) xs)"
  1579 unfolding partition_filter2[symmetric]
  1580 unfolding partition_filter1[symmetric] by simp
  1581 
  1582 declare partition.simps[simp del]
  1583 
  1584 
  1585 subsubsection {* @{const concat} *}
  1586 
  1587 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"
  1588 by (induct xs) auto
  1589 
  1590 lemma concat_eq_Nil_conv [simp]: "(concat xss = []) = (\<forall>xs \<in> set xss. xs = [])"
  1591 by (induct xss) auto
  1592 
  1593 lemma Nil_eq_concat_conv [simp]: "([] = concat xss) = (\<forall>xs \<in> set xss. xs = [])"
  1594 by (induct xss) auto
  1595 
  1596 lemma set_concat [simp]: "set (concat xs) = (UN x:set xs. set x)"
  1597 by (induct xs) auto
  1598 
  1599 lemma concat_map_singleton[simp]: "concat(map (%x. [f x]) xs) = map f xs"
  1600 by (induct xs) auto
  1601 
  1602 lemma map_concat: "map f (concat xs) = concat (map (map f) xs)"
  1603 by (induct xs) auto
  1604 
  1605 lemma filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"
  1606 by (induct xs) auto
  1607 
  1608 lemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"
  1609 by (induct xs) auto
  1610 
  1611 lemma concat_eq_concat_iff: "\<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> length xs = length ys ==> (concat xs = concat ys) = (xs = ys)"
  1612 proof (induct xs arbitrary: ys)
  1613   case (Cons x xs ys)
  1614   thus ?case by (cases ys) auto
  1615 qed (auto)
  1616 
  1617 lemma concat_injective: "concat xs = concat ys ==> length xs = length ys ==> \<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> xs = ys"
  1618 by (simp add: concat_eq_concat_iff)
  1619 
  1620 
  1621 subsubsection {* @{const nth} *}
  1622 
  1623 lemma nth_Cons_0 [simp, code]: "(x # xs)!0 = x"
  1624 by auto
  1625 
  1626 lemma nth_Cons_Suc [simp, code]: "(x # xs)!(Suc n) = xs!n"
  1627 by auto
  1628 
  1629 declare nth.simps [simp del]
  1630 
  1631 lemma nth_Cons_pos[simp]: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"
  1632 by(auto simp: Nat.gr0_conv_Suc)
  1633 
  1634 lemma nth_append:
  1635   "(xs @ ys)!n = (if n < length xs then xs!n else ys!(n - length xs))"
  1636 apply (induct xs arbitrary: n, simp)
  1637 apply (case_tac n, auto)
  1638 done
  1639 
  1640 lemma nth_append_length [simp]: "(xs @ x # ys) ! length xs = x"
  1641 by (induct xs) auto
  1642 
  1643 lemma nth_append_length_plus[simp]: "(xs @ ys) ! (length xs + n) = ys ! n"
  1644 by (induct xs) auto
  1645 
  1646 lemma nth_map [simp]: "n < length xs ==> (map f xs)!n = f(xs!n)"
  1647 apply (induct xs arbitrary: n, simp)
  1648 apply (case_tac n, auto)
  1649 done
  1650 
  1651 lemma nth_tl:
  1652   assumes "n < length (tl x)" shows "tl x ! n = x ! Suc n"
  1653 using assms by (induct x) auto
  1654 
  1655 lemma hd_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd xs = xs!0"
  1656 by(cases xs) simp_all
  1657 
  1658 
  1659 lemma list_eq_iff_nth_eq:
  1660  "(xs = ys) = (length xs = length ys \<and> (ALL i<length xs. xs!i = ys!i))"
  1661 apply(induct xs arbitrary: ys)
  1662  apply force
  1663 apply(case_tac ys)
  1664  apply simp
  1665 apply(simp add:nth_Cons split:nat.split)apply blast
  1666 done
  1667 
  1668 lemma set_conv_nth: "set xs = {xs!i | i. i < length xs}"
  1669 apply (induct xs, simp, simp)
  1670 apply safe
  1671 apply (metis nat.case(1) nth.simps zero_less_Suc)
  1672 apply (metis less_Suc_eq_0_disj nth_Cons_Suc)
  1673 apply (case_tac i, simp)
  1674 apply (metis diff_Suc_Suc nat.case(2) nth.simps zero_less_diff)
  1675 done
  1676 
  1677 lemma in_set_conv_nth: "(x \<in> set xs) = (\<exists>i < length xs. xs!i = x)"
  1678 by(auto simp:set_conv_nth)
  1679 
  1680 lemma nth_equal_first_eq:
  1681   assumes "x \<notin> set xs"
  1682   assumes "n \<le> length xs"
  1683   shows "(x # xs) ! n = x \<longleftrightarrow> n = 0" (is "?lhs \<longleftrightarrow> ?rhs")
  1684 proof
  1685   assume ?lhs
  1686   show ?rhs
  1687   proof (rule ccontr)
  1688     assume "n \<noteq> 0"
  1689     then have "n > 0" by simp
  1690     with `?lhs` have "xs ! (n - 1) = x" by simp
  1691     moreover from `n > 0` `n \<le> length xs` have "n - 1 < length xs" by simp
  1692     ultimately have "\<exists>i<length xs. xs ! i = x" by auto
  1693     with `x \<notin> set xs` in_set_conv_nth [of x xs] show False by simp
  1694   qed
  1695 next
  1696   assume ?rhs then show ?lhs by simp
  1697 qed
  1698 
  1699 lemma nth_non_equal_first_eq:
  1700   assumes "x \<noteq> y"
  1701   shows "(x # xs) ! n = y \<longleftrightarrow> xs ! (n - 1) = y \<and> n > 0" (is "?lhs \<longleftrightarrow> ?rhs")
  1702 proof
  1703   assume "?lhs" with assms have "n > 0" by (cases n) simp_all
  1704   with `?lhs` show ?rhs by simp
  1705 next
  1706   assume "?rhs" then show "?lhs" by simp
  1707 qed
  1708 
  1709 lemma list_ball_nth: "[| n < length xs; !x : set xs. P x|] ==> P(xs!n)"
  1710 by (auto simp add: set_conv_nth)
  1711 
  1712 lemma nth_mem [simp]: "n < length xs ==> xs!n : set xs"
  1713 by (auto simp add: set_conv_nth)
  1714 
  1715 lemma all_nth_imp_all_set:
  1716 "[| !i < length xs. P(xs!i); x : set xs|] ==> P x"
  1717 by (auto simp add: set_conv_nth)
  1718 
  1719 lemma all_set_conv_all_nth:
  1720 "(\<forall>x \<in> set xs. P x) = (\<forall>i. i < length xs --> P (xs ! i))"
  1721 by (auto simp add: set_conv_nth)
  1722 
  1723 lemma rev_nth:
  1724   "n < size xs \<Longrightarrow> rev xs ! n = xs ! (length xs - Suc n)"
  1725 proof (induct xs arbitrary: n)
  1726   case Nil thus ?case by simp
  1727 next
  1728   case (Cons x xs)
  1729   hence n: "n < Suc (length xs)" by simp
  1730   moreover
  1731   { assume "n < length xs"
  1732     with n obtain n' where n': "length xs - n = Suc n'"
  1733       by (cases "length xs - n", auto)
  1734     moreover
  1735     from n' have "length xs - Suc n = n'" by simp
  1736     ultimately
  1737     have "xs ! (length xs - Suc n) = (x # xs) ! (length xs - n)" by simp
  1738   }
  1739   ultimately
  1740   show ?case by (clarsimp simp add: Cons nth_append)
  1741 qed
  1742 
  1743 lemma Skolem_list_nth:
  1744   "(ALL i<k. EX x. P i x) = (EX xs. size xs = k & (ALL i<k. P i (xs!i)))"
  1745   (is "_ = (EX xs. ?P k xs)")
  1746 proof(induct k)
  1747   case 0 show ?case by simp
  1748 next
  1749   case (Suc k)
  1750   show ?case (is "?L = ?R" is "_ = (EX xs. ?P' xs)")
  1751   proof
  1752     assume "?R" thus "?L" using Suc by auto
  1753   next
  1754     assume "?L"
  1755     with Suc obtain x xs where "?P k xs & P k x" by (metis less_Suc_eq)
  1756     hence "?P'(xs@[x])" by(simp add:nth_append less_Suc_eq)
  1757     thus "?R" ..
  1758   qed
  1759 qed
  1760 
  1761 
  1762 subsubsection {* @{const list_update} *}
  1763 
  1764 lemma length_list_update [simp]: "length(xs[i:=x]) = length xs"
  1765 by (induct xs arbitrary: i) (auto split: nat.split)
  1766 
  1767 lemma nth_list_update:
  1768 "i < length xs==> (xs[i:=x])!j = (if i = j then x else xs!j)"
  1769 by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)
  1770 
  1771 lemma nth_list_update_eq [simp]: "i < length xs ==> (xs[i:=x])!i = x"
  1772 by (simp add: nth_list_update)
  1773 
  1774 lemma nth_list_update_neq [simp]: "i \<noteq> j ==> xs[i:=x]!j = xs!j"
  1775 by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)
  1776 
  1777 lemma list_update_id[simp]: "xs[i := xs!i] = xs"
  1778 by (induct xs arbitrary: i) (simp_all split:nat.splits)
  1779 
  1780 lemma list_update_beyond[simp]: "length xs \<le> i \<Longrightarrow> xs[i:=x] = xs"
  1781 apply (induct xs arbitrary: i)
  1782  apply simp
  1783 apply (case_tac i)
  1784 apply simp_all
  1785 done
  1786 
  1787 lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"
  1788 by (simp only: length_0_conv[symmetric] length_list_update)
  1789 
  1790 lemma list_update_same_conv:
  1791 "i < length xs ==> (xs[i := x] = xs) = (xs!i = x)"
  1792 by (induct xs arbitrary: i) (auto split: nat.split)
  1793 
  1794 lemma list_update_append1:
  1795  "i < size xs \<Longrightarrow> (xs @ ys)[i:=x] = xs[i:=x] @ ys"
  1796 apply (induct xs arbitrary: i, simp)
  1797 apply(simp split:nat.split)
  1798 done
  1799 
  1800 lemma list_update_append:
  1801   "(xs @ ys) [n:= x] = 
  1802   (if n < length xs then xs[n:= x] @ ys else xs @ (ys [n-length xs:= x]))"
  1803 by (induct xs arbitrary: n) (auto split:nat.splits)
  1804 
  1805 lemma list_update_length [simp]:
  1806  "(xs @ x # ys)[length xs := y] = (xs @ y # ys)"
  1807 by (induct xs, auto)
  1808 
  1809 lemma map_update: "map f (xs[k:= y]) = (map f xs)[k := f y]"
  1810 by(induct xs arbitrary: k)(auto split:nat.splits)
  1811 
  1812 lemma rev_update:
  1813   "k < length xs \<Longrightarrow> rev (xs[k:= y]) = (rev xs)[length xs - k - 1 := y]"
  1814 by (induct xs arbitrary: k) (auto simp: list_update_append split:nat.splits)
  1815 
  1816 lemma update_zip:
  1817   "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
  1818 by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)
  1819 
  1820 lemma set_update_subset_insert: "set(xs[i:=x]) <= insert x (set xs)"
  1821 by (induct xs arbitrary: i) (auto split: nat.split)
  1822 
  1823 lemma set_update_subsetI: "[| set xs <= A; x:A |] ==> set(xs[i := x]) <= A"
  1824 by (blast dest!: set_update_subset_insert [THEN subsetD])
  1825 
  1826 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"
  1827 by (induct xs arbitrary: n) (auto split:nat.splits)
  1828 
  1829 lemma list_update_overwrite[simp]:
  1830   "xs [i := x, i := y] = xs [i := y]"
  1831 apply (induct xs arbitrary: i) apply simp
  1832 apply (case_tac i, simp_all)
  1833 done
  1834 
  1835 lemma list_update_swap:
  1836   "i \<noteq> i' \<Longrightarrow> xs [i := x, i' := x'] = xs [i' := x', i := x]"
  1837 apply (induct xs arbitrary: i i')
  1838 apply simp
  1839 apply (case_tac i, case_tac i')
  1840 apply auto
  1841 apply (case_tac i')
  1842 apply auto
  1843 done
  1844 
  1845 lemma list_update_code [code]:
  1846   "[][i := y] = []"
  1847   "(x # xs)[0 := y] = y # xs"
  1848   "(x # xs)[Suc i := y] = x # xs[i := y]"
  1849   by simp_all
  1850 
  1851 
  1852 subsubsection {* @{const last} and @{const butlast} *}
  1853 
  1854 lemma last_snoc [simp]: "last (xs @ [x]) = x"
  1855 by (induct xs) auto
  1856 
  1857 lemma butlast_snoc [simp]: "butlast (xs @ [x]) = xs"
  1858 by (induct xs) auto
  1859 
  1860 lemma last_ConsL: "xs = [] \<Longrightarrow> last(x#xs) = x"
  1861   by simp
  1862 
  1863 lemma last_ConsR: "xs \<noteq> [] \<Longrightarrow> last(x#xs) = last xs"
  1864   by simp
  1865 
  1866 lemma last_append: "last(xs @ ys) = (if ys = [] then last xs else last ys)"
  1867 by (induct xs) (auto)
  1868 
  1869 lemma last_appendL[simp]: "ys = [] \<Longrightarrow> last(xs @ ys) = last xs"
  1870 by(simp add:last_append)
  1871 
  1872 lemma last_appendR[simp]: "ys \<noteq> [] \<Longrightarrow> last(xs @ ys) = last ys"
  1873 by(simp add:last_append)
  1874 
  1875 lemma last_tl: "xs = [] \<or> tl xs \<noteq> [] \<Longrightarrow>last (tl xs) = last xs"
  1876 by (induct xs) simp_all
  1877 
  1878 lemma butlast_tl: "butlast (tl xs) = tl (butlast xs)"
  1879 by (induct xs) simp_all
  1880 
  1881 lemma hd_rev: "xs \<noteq> [] \<Longrightarrow> hd(rev xs) = last xs"
  1882 by(rule rev_exhaust[of xs]) simp_all
  1883 
  1884 lemma last_rev: "xs \<noteq> [] \<Longrightarrow> last(rev xs) = hd xs"
  1885 by(cases xs) simp_all
  1886 
  1887 lemma last_in_set[simp]: "as \<noteq> [] \<Longrightarrow> last as \<in> set as"
  1888 by (induct as) auto
  1889 
  1890 lemma length_butlast [simp]: "length (butlast xs) = length xs - 1"
  1891 by (induct xs rule: rev_induct) auto
  1892 
  1893 lemma butlast_append:
  1894   "butlast (xs @ ys) = (if ys = [] then butlast xs else xs @ butlast ys)"
  1895 by (induct xs arbitrary: ys) auto
  1896 
  1897 lemma append_butlast_last_id [simp]:
  1898 "xs \<noteq> [] ==> butlast xs @ [last xs] = xs"
  1899 by (induct xs) auto
  1900 
  1901 lemma in_set_butlastD: "x : set (butlast xs) ==> x : set xs"
  1902 by (induct xs) (auto split: split_if_asm)
  1903 
  1904 lemma in_set_butlast_appendI:
  1905 "x : set (butlast xs) | x : set (butlast ys) ==> x : set (butlast (xs @ ys))"
  1906 by (auto dest: in_set_butlastD simp add: butlast_append)
  1907 
  1908 lemma last_drop[simp]: "n < length xs \<Longrightarrow> last (drop n xs) = last xs"
  1909 apply (induct xs arbitrary: n)
  1910  apply simp
  1911 apply (auto split:nat.split)
  1912 done
  1913 
  1914 lemma nth_butlast:
  1915   assumes "n < length (butlast xs)" shows "butlast xs ! n = xs ! n"
  1916 proof (cases xs)
  1917   case (Cons y ys)
  1918   moreover from assms have "butlast xs ! n = (butlast xs @ [last xs]) ! n"
  1919     by (simp add: nth_append)
  1920   ultimately show ?thesis using append_butlast_last_id by simp
  1921 qed simp
  1922 
  1923 lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - 1)"
  1924 by(induct xs)(auto simp:neq_Nil_conv)
  1925 
  1926 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"
  1927 by (induct xs, simp, case_tac xs, simp_all)
  1928 
  1929 lemma last_list_update:
  1930   "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"
  1931 by (auto simp: last_conv_nth)
  1932 
  1933 lemma butlast_list_update:
  1934   "butlast(xs[k:=x]) =
  1935  (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"
  1936 apply(cases xs rule:rev_cases)
  1937 apply simp
  1938 apply(simp add:list_update_append split:nat.splits)
  1939 done
  1940 
  1941 lemma last_map:
  1942   "xs \<noteq> [] \<Longrightarrow> last (map f xs) = f (last xs)"
  1943   by (cases xs rule: rev_cases) simp_all
  1944 
  1945 lemma map_butlast:
  1946   "map f (butlast xs) = butlast (map f xs)"
  1947   by (induct xs) simp_all
  1948 
  1949 lemma snoc_eq_iff_butlast:
  1950   "xs @ [x] = ys \<longleftrightarrow> (ys \<noteq> [] & butlast ys = xs & last ys = x)"
  1951 by fastforce
  1952 
  1953 
  1954 subsubsection {* @{const take} and @{const drop} *}
  1955 
  1956 lemma take_0 [simp]: "take 0 xs = []"
  1957 by (induct xs) auto
  1958 
  1959 lemma drop_0 [simp]: "drop 0 xs = xs"
  1960 by (induct xs) auto
  1961 
  1962 lemma take_Suc_Cons [simp]: "take (Suc n) (x # xs) = x # take n xs"
  1963 by simp
  1964 
  1965 lemma drop_Suc_Cons [simp]: "drop (Suc n) (x # xs) = drop n xs"
  1966 by simp
  1967 
  1968 declare take_Cons [simp del] and drop_Cons [simp del]
  1969 
  1970 lemma take_1_Cons [simp]: "take 1 (x # xs) = [x]"
  1971   unfolding One_nat_def by simp
  1972 
  1973 lemma drop_1_Cons [simp]: "drop 1 (x # xs) = xs"
  1974   unfolding One_nat_def by simp
  1975 
  1976 lemma take_Suc: "xs ~= [] ==> take (Suc n) xs = hd xs # take n (tl xs)"
  1977 by(clarsimp simp add:neq_Nil_conv)
  1978 
  1979 lemma drop_Suc: "drop (Suc n) xs = drop n (tl xs)"
  1980 by(cases xs, simp_all)
  1981 
  1982 lemma take_tl: "take n (tl xs) = tl (take (Suc n) xs)"
  1983 by (induct xs arbitrary: n) simp_all
  1984 
  1985 lemma drop_tl: "drop n (tl xs) = tl(drop n xs)"
  1986 by(induct xs arbitrary: n, simp_all add:drop_Cons drop_Suc split:nat.split)
  1987 
  1988 lemma tl_take: "tl (take n xs) = take (n - 1) (tl xs)"
  1989 by (cases n, simp, cases xs, auto)
  1990 
  1991 lemma tl_drop: "tl (drop n xs) = drop n (tl xs)"
  1992 by (simp only: drop_tl)
  1993 
  1994 lemma nth_via_drop: "drop n xs = y#ys \<Longrightarrow> xs!n = y"
  1995 apply (induct xs arbitrary: n, simp)
  1996 apply(simp add:drop_Cons nth_Cons split:nat.splits)
  1997 done
  1998 
  1999 lemma take_Suc_conv_app_nth:
  2000   "i < length xs \<Longrightarrow> take (Suc i) xs = take i xs @ [xs!i]"
  2001 apply (induct xs arbitrary: i, simp)
  2002 apply (case_tac i, auto)
  2003 done
  2004 
  2005 lemma drop_Suc_conv_tl:
  2006   "i < length xs \<Longrightarrow> (xs!i) # (drop (Suc i) xs) = drop i xs"
  2007 apply (induct xs arbitrary: i, simp)
  2008 apply (case_tac i, auto)
  2009 done
  2010 
  2011 lemma length_take [simp]: "length (take n xs) = min (length xs) n"
  2012 by (induct n arbitrary: xs) (auto, case_tac xs, auto)
  2013 
  2014 lemma length_drop [simp]: "length (drop n xs) = (length xs - n)"
  2015 by (induct n arbitrary: xs) (auto, case_tac xs, auto)
  2016 
  2017 lemma take_all [simp]: "length xs <= n ==> take n xs = xs"
  2018 by (induct n arbitrary: xs) (auto, case_tac xs, auto)
  2019 
  2020 lemma drop_all [simp]: "length xs <= n ==> drop n xs = []"
  2021 by (induct n arbitrary: xs) (auto, case_tac xs, auto)
  2022 
  2023 lemma take_append [simp]:
  2024   "take n (xs @ ys) = (take n xs @ take (n - length xs) ys)"
  2025 by (induct n arbitrary: xs) (auto, case_tac xs, auto)
  2026 
  2027 lemma drop_append [simp]:
  2028   "drop n (xs @ ys) = drop n xs @ drop (n - length xs) ys"
  2029 by (induct n arbitrary: xs) (auto, case_tac xs, auto)
  2030 
  2031 lemma take_take [simp]: "take n (take m xs) = take (min n m) xs"
  2032 apply (induct m arbitrary: xs n, auto)
  2033 apply (case_tac xs, auto)
  2034 apply (case_tac n, auto)
  2035 done
  2036 
  2037 lemma drop_drop [simp]: "drop n (drop m xs) = drop (n + m) xs"
  2038 apply (induct m arbitrary: xs, auto)
  2039 apply (case_tac xs, auto)
  2040 done
  2041 
  2042 lemma take_drop: "take n (drop m xs) = drop m (take (n + m) xs)"
  2043 apply (induct m arbitrary: xs n, auto)
  2044 apply (case_tac xs, auto)
  2045 done
  2046 
  2047 lemma drop_take: "drop n (take m xs) = take (m-n) (drop n xs)"
  2048 apply(induct xs arbitrary: m n)
  2049  apply simp
  2050 apply(simp add: take_Cons drop_Cons split:nat.split)
  2051 done
  2052 
  2053 lemma append_take_drop_id [simp]: "take n xs @ drop n xs = xs"
  2054 apply (induct n arbitrary: xs, auto)
  2055 apply (case_tac xs, auto)
  2056 done
  2057 
  2058 lemma take_eq_Nil[simp]: "(take n xs = []) = (n = 0 \<or> xs = [])"
  2059 apply(induct xs arbitrary: n)
  2060  apply simp
  2061 apply(simp add:take_Cons split:nat.split)
  2062 done
  2063 
  2064 lemma drop_eq_Nil[simp]: "(drop n xs = []) = (length xs <= n)"
  2065 apply(induct xs arbitrary: n)
  2066 apply simp
  2067 apply(simp add:drop_Cons split:nat.split)
  2068 done
  2069 
  2070 lemma take_map: "take n (map f xs) = map f (take n xs)"
  2071 apply (induct n arbitrary: xs, auto)
  2072 apply (case_tac xs, auto)
  2073 done
  2074 
  2075 lemma drop_map: "drop n (map f xs) = map f (drop n xs)"
  2076 apply (induct n arbitrary: xs, auto)
  2077 apply (case_tac xs, auto)
  2078 done
  2079 
  2080 lemma rev_take: "rev (take i xs) = drop (length xs - i) (rev xs)"
  2081 apply (induct xs arbitrary: i, auto)
  2082 apply (case_tac i, auto)
  2083 done
  2084 
  2085 lemma rev_drop: "rev (drop i xs) = take (length xs - i) (rev xs)"
  2086 apply (induct xs arbitrary: i, auto)
  2087 apply (case_tac i, auto)
  2088 done
  2089 
  2090 lemma nth_take [simp]: "i < n ==> (take n xs)!i = xs!i"
  2091 apply (induct xs arbitrary: i n, auto)
  2092 apply (case_tac n, blast)
  2093 apply (case_tac i, auto)
  2094 done
  2095 
  2096 lemma nth_drop [simp]:
  2097   "n + i <= length xs ==> (drop n xs)!i = xs!(n + i)"
  2098 apply (induct n arbitrary: xs i, auto)
  2099 apply (case_tac xs, auto)
  2100 done
  2101 
  2102 lemma butlast_take:
  2103   "n <= length xs ==> butlast (take n xs) = take (n - 1) xs"
  2104 by (simp add: butlast_conv_take min.absorb1 min.absorb2)
  2105 
  2106 lemma butlast_drop: "butlast (drop n xs) = drop n (butlast xs)"
  2107 by (simp add: butlast_conv_take drop_take add_ac)
  2108 
  2109 lemma take_butlast: "n < length xs ==> take n (butlast xs) = take n xs"
  2110 by (simp add: butlast_conv_take min.absorb1)
  2111 
  2112 lemma drop_butlast: "drop n (butlast xs) = butlast (drop n xs)"
  2113 by (simp add: butlast_conv_take drop_take add_ac)
  2114 
  2115 lemma hd_drop_conv_nth: "n < length xs \<Longrightarrow> hd(drop n xs) = xs!n"
  2116 by(simp add: hd_conv_nth)
  2117 
  2118 lemma set_take_subset_set_take:
  2119   "m <= n \<Longrightarrow> set(take m xs) <= set(take n xs)"
  2120 apply (induct xs arbitrary: m n)
  2121 apply simp
  2122 apply (case_tac n)
  2123 apply (auto simp: take_Cons)
  2124 done
  2125 
  2126 lemma set_take_subset: "set(take n xs) \<subseteq> set xs"
  2127 by(induct xs arbitrary: n)(auto simp:take_Cons split:nat.split)
  2128 
  2129 lemma set_drop_subset: "set(drop n xs) \<subseteq> set xs"
  2130 by(induct xs arbitrary: n)(auto simp:drop_Cons split:nat.split)
  2131 
  2132 lemma set_drop_subset_set_drop:
  2133   "m >= n \<Longrightarrow> set(drop m xs) <= set(drop n xs)"
  2134 apply(induct xs arbitrary: m n)
  2135 apply(auto simp:drop_Cons split:nat.split)
  2136 by (metis set_drop_subset subset_iff)
  2137 
  2138 lemma in_set_takeD: "x : set(take n xs) \<Longrightarrow> x : set xs"
  2139 using set_take_subset by fast
  2140 
  2141 lemma in_set_dropD: "x : set(drop n xs) \<Longrightarrow> x : set xs"
  2142 using set_drop_subset by fast
  2143 
  2144 lemma append_eq_conv_conj:
  2145   "(xs @ ys = zs) = (xs = take (length xs) zs \<and> ys = drop (length xs) zs)"
  2146 apply (induct xs arbitrary: zs, simp, clarsimp)
  2147 apply (case_tac zs, auto)
  2148 done
  2149 
  2150 lemma take_add: 
  2151   "take (i+j) xs = take i xs @ take j (drop i xs)"
  2152 apply (induct xs arbitrary: i, auto) 
  2153 apply (case_tac i, simp_all)
  2154 done
  2155 
  2156 lemma append_eq_append_conv_if:
  2157  "(xs\<^sub>1 @ xs\<^sub>2 = ys\<^sub>1 @ ys\<^sub>2) =
  2158   (if size xs\<^sub>1 \<le> size ys\<^sub>1
  2159    then xs\<^sub>1 = take (size xs\<^sub>1) ys\<^sub>1 \<and> xs\<^sub>2 = drop (size xs\<^sub>1) ys\<^sub>1 @ ys\<^sub>2
  2160    else take (size ys\<^sub>1) xs\<^sub>1 = ys\<^sub>1 \<and> drop (size ys\<^sub>1) xs\<^sub>1 @ xs\<^sub>2 = ys\<^sub>2)"
  2161 apply(induct xs\<^sub>1 arbitrary: ys\<^sub>1)
  2162  apply simp
  2163 apply(case_tac ys\<^sub>1)
  2164 apply simp_all
  2165 done
  2166 
  2167 lemma take_hd_drop:
  2168   "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (Suc n) xs"
  2169 apply(induct xs arbitrary: n)
  2170 apply simp
  2171 apply(simp add:drop_Cons split:nat.split)
  2172 done
  2173 
  2174 lemma id_take_nth_drop:
  2175  "i < length xs \<Longrightarrow> xs = take i xs @ xs!i # drop (Suc i) xs" 
  2176 proof -
  2177   assume si: "i < length xs"
  2178   hence "xs = take (Suc i) xs @ drop (Suc i) xs" by auto
  2179   moreover
  2180   from si have "take (Suc i) xs = take i xs @ [xs!i]"
  2181     apply (rule_tac take_Suc_conv_app_nth) by arith
  2182   ultimately show ?thesis by auto
  2183 qed
  2184   
  2185 lemma upd_conv_take_nth_drop:
  2186  "i < length xs \<Longrightarrow> xs[i:=a] = take i xs @ a # drop (Suc i) xs"
  2187 proof -
  2188   assume i: "i < length xs"
  2189   have "xs[i:=a] = (take i xs @ xs!i # drop (Suc i) xs)[i:=a]"
  2190     by(rule arg_cong[OF id_take_nth_drop[OF i]])
  2191   also have "\<dots> = take i xs @ a # drop (Suc i) xs"
  2192     using i by (simp add: list_update_append)
  2193   finally show ?thesis .
  2194 qed
  2195 
  2196 lemma nth_drop':
  2197   "i < length xs \<Longrightarrow> xs ! i # drop (Suc i) xs = drop i xs"
  2198 apply (induct i arbitrary: xs)
  2199 apply (simp add: neq_Nil_conv)
  2200 apply (erule exE)+
  2201 apply simp
  2202 apply (case_tac xs)
  2203 apply simp_all
  2204 done
  2205 
  2206 
  2207 subsubsection {* @{const takeWhile} and @{const dropWhile} *}
  2208 
  2209 lemma length_takeWhile_le: "length (takeWhile P xs) \<le> length xs"
  2210   by (induct xs) auto
  2211 
  2212 lemma takeWhile_dropWhile_id [simp]: "takeWhile P xs @ dropWhile P xs = xs"
  2213 by (induct xs) auto
  2214 
  2215 lemma takeWhile_append1 [simp]:
  2216 "[| x:set xs; ~P(x)|] ==> takeWhile P (xs @ ys) = takeWhile P xs"
  2217 by (induct xs) auto
  2218 
  2219 lemma takeWhile_append2 [simp]:
  2220 "(!!x. x : set xs ==> P x) ==> takeWhile P (xs @ ys) = xs @ takeWhile P ys"
  2221 by (induct xs) auto
  2222 
  2223 lemma takeWhile_tail: "\<not> P x ==> takeWhile P (xs @ (x#l)) = takeWhile P xs"
  2224 by (induct xs) auto
  2225 
  2226 lemma takeWhile_nth: "j < length (takeWhile P xs) \<Longrightarrow> takeWhile P xs ! j = xs ! j"
  2227 apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by auto
  2228 
  2229 lemma dropWhile_nth: "j < length (dropWhile P xs) \<Longrightarrow> dropWhile P xs ! j = xs ! (j + length (takeWhile P xs))"
  2230 apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by auto
  2231 
  2232 lemma length_dropWhile_le: "length (dropWhile P xs) \<le> length xs"
  2233 by (induct xs) auto
  2234 
  2235 lemma dropWhile_append1 [simp]:
  2236 "[| x : set xs; ~P(x)|] ==> dropWhile P (xs @ ys) = (dropWhile P xs)@ys"
  2237 by (induct xs) auto
  2238 
  2239 lemma dropWhile_append2 [simp]:
  2240 "(!!x. x:set xs ==> P(x)) ==> dropWhile P (xs @ ys) = dropWhile P ys"
  2241 by (induct xs) auto
  2242 
  2243 lemma dropWhile_append3:
  2244   "\<not> P y \<Longrightarrow>dropWhile P (xs @ y # ys) = dropWhile P xs @ y # ys"
  2245 by (induct xs) auto
  2246 
  2247 lemma dropWhile_last:
  2248   "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> last (dropWhile P xs) = last xs"
  2249 by (auto simp add: dropWhile_append3 in_set_conv_decomp)
  2250 
  2251 lemma set_dropWhileD: "x \<in> set (dropWhile P xs) \<Longrightarrow> x \<in> set xs"
  2252 by (induct xs) (auto split: split_if_asm)
  2253 
  2254 lemma set_takeWhileD: "x : set (takeWhile P xs) ==> x : set xs \<and> P x"
  2255 by (induct xs) (auto split: split_if_asm)
  2256 
  2257 lemma takeWhile_eq_all_conv[simp]:
  2258  "(takeWhile P xs = xs) = (\<forall>x \<in> set xs. P x)"
  2259 by(induct xs, auto)
  2260 
  2261 lemma dropWhile_eq_Nil_conv[simp]:
  2262  "(dropWhile P xs = []) = (\<forall>x \<in> set xs. P x)"
  2263 by(induct xs, auto)
  2264 
  2265 lemma dropWhile_eq_Cons_conv:
  2266  "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys & \<not> P y)"
  2267 by(induct xs, auto)
  2268 
  2269 lemma distinct_takeWhile[simp]: "distinct xs ==> distinct (takeWhile P xs)"
  2270 by (induct xs) (auto dest: set_takeWhileD)
  2271 
  2272 lemma distinct_dropWhile[simp]: "distinct xs ==> distinct (dropWhile P xs)"
  2273 by (induct xs) auto
  2274 
  2275 lemma takeWhile_map: "takeWhile P (map f xs) = map f (takeWhile (P \<circ> f) xs)"
  2276 by (induct xs) auto
  2277 
  2278 lemma dropWhile_map: "dropWhile P (map f xs) = map f (dropWhile (P \<circ> f) xs)"
  2279 by (induct xs) auto
  2280 
  2281 lemma takeWhile_eq_take: "takeWhile P xs = take (length (takeWhile P xs)) xs"
  2282 by (induct xs) auto
  2283 
  2284 lemma dropWhile_eq_drop: "dropWhile P xs = drop (length (takeWhile P xs)) xs"
  2285 by (induct xs) auto
  2286 
  2287 lemma hd_dropWhile:
  2288   "dropWhile P xs \<noteq> [] \<Longrightarrow> \<not> P (hd (dropWhile P xs))"
  2289 using assms by (induct xs) auto
  2290 
  2291 lemma takeWhile_eq_filter:
  2292   assumes "\<And> x. x \<in> set (dropWhile P xs) \<Longrightarrow> \<not> P x"
  2293   shows "takeWhile P xs = filter P xs"
  2294 proof -
  2295   have A: "filter P xs = filter P (takeWhile P xs @ dropWhile P xs)"
  2296     by simp
  2297   have B: "filter P (dropWhile P xs) = []"
  2298     unfolding filter_empty_conv using assms by blast
  2299   have "filter P xs = takeWhile P xs"
  2300     unfolding A filter_append B
  2301     by (auto simp add: filter_id_conv dest: set_takeWhileD)
  2302   thus ?thesis ..
  2303 qed
  2304 
  2305 lemma takeWhile_eq_take_P_nth:
  2306   "\<lbrakk> \<And> i. \<lbrakk> i < n ; i < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) ; n < length xs \<Longrightarrow> \<not> P (xs ! n) \<rbrakk> \<Longrightarrow>
  2307   takeWhile P xs = take n xs"
  2308 proof (induct xs arbitrary: n)
  2309   case (Cons x xs)
  2310   thus ?case
  2311   proof (cases n)
  2312     case (Suc n') note this[simp]
  2313     have "P x" using Cons.prems(1)[of 0] by simp
  2314     moreover have "takeWhile P xs = take n' xs"
  2315     proof (rule Cons.hyps)
  2316       case goal1 thus "P (xs ! i)" using Cons.prems(1)[of "Suc i"] by simp
  2317     next case goal2 thus ?case using Cons by auto
  2318     qed
  2319     ultimately show ?thesis by simp
  2320    qed simp
  2321 qed simp
  2322 
  2323 lemma nth_length_takeWhile:
  2324   "length (takeWhile P xs) < length xs \<Longrightarrow> \<not> P (xs ! length (takeWhile P xs))"
  2325 by (induct xs) auto
  2326 
  2327 lemma length_takeWhile_less_P_nth:
  2328   assumes all: "\<And> i. i < j \<Longrightarrow> P (xs ! i)" and "j \<le> length xs"
  2329   shows "j \<le> length (takeWhile P xs)"
  2330 proof (rule classical)
  2331   assume "\<not> ?thesis"
  2332   hence "length (takeWhile P xs) < length xs" using assms by simp
  2333   thus ?thesis using all `\<not> ?thesis` nth_length_takeWhile[of P xs] by auto
  2334 qed
  2335 
  2336 text{* The following two lemmmas could be generalized to an arbitrary
  2337 property. *}
  2338 
  2339 lemma takeWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>
  2340  takeWhile (\<lambda>y. y \<noteq> x) (rev xs) = rev (tl (dropWhile (\<lambda>y. y \<noteq> x) xs))"
  2341 by(induct xs) (auto simp: takeWhile_tail[where l="[]"])
  2342 
  2343 lemma dropWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>
  2344   dropWhile (\<lambda>y. y \<noteq> x) (rev xs) = x # rev (takeWhile (\<lambda>y. y \<noteq> x) xs)"
  2345 apply(induct xs)
  2346  apply simp
  2347 apply auto
  2348 apply(subst dropWhile_append2)
  2349 apply auto
  2350 done
  2351 
  2352 lemma takeWhile_not_last:
  2353  "distinct xs \<Longrightarrow> takeWhile (\<lambda>y. y \<noteq> last xs) xs = butlast xs"
  2354 apply(induct xs)
  2355  apply simp
  2356 apply(case_tac xs)
  2357 apply(auto)
  2358 done
  2359 
  2360 lemma takeWhile_cong [fundef_cong]:
  2361   "[| l = k; !!x. x : set l ==> P x = Q x |] 
  2362   ==> takeWhile P l = takeWhile Q k"
  2363 by (induct k arbitrary: l) (simp_all)
  2364 
  2365 lemma dropWhile_cong [fundef_cong]:
  2366   "[| l = k; !!x. x : set l ==> P x = Q x |] 
  2367   ==> dropWhile P l = dropWhile Q k"
  2368 by (induct k arbitrary: l, simp_all)
  2369 
  2370 lemma takeWhile_idem [simp]:
  2371   "takeWhile P (takeWhile P xs) = takeWhile P xs"
  2372   by (induct xs) auto
  2373 
  2374 lemma dropWhile_idem [simp]:
  2375   "dropWhile P (dropWhile P xs) = dropWhile P xs"
  2376   by (induct xs) auto
  2377 
  2378 
  2379 subsubsection {* @{const zip} *}
  2380 
  2381 lemma zip_Nil [simp]: "zip [] ys = []"
  2382 by (induct ys) auto
  2383 
  2384 lemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
  2385 by simp
  2386 
  2387 declare zip_Cons [simp del]
  2388 
  2389 lemma [code]:
  2390   "zip [] ys = []"
  2391   "zip xs [] = []"
  2392   "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
  2393   by (fact zip_Nil zip.simps(1) zip_Cons_Cons)+
  2394 
  2395 lemma zip_Cons1:
  2396  "zip (x#xs) ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x,y)#zip xs ys)"
  2397 by(auto split:list.split)
  2398 
  2399 lemma length_zip [simp]:
  2400 "length (zip xs ys) = min (length xs) (length ys)"
  2401 by (induct xs ys rule:list_induct2') auto
  2402 
  2403 lemma zip_obtain_same_length:
  2404   assumes "\<And>zs ws n. length zs = length ws \<Longrightarrow> n = min (length xs) (length ys)
  2405     \<Longrightarrow> zs = take n xs \<Longrightarrow> ws = take n ys \<Longrightarrow> P (zip zs ws)"
  2406   shows "P (zip xs ys)"
  2407 proof -
  2408   let ?n = "min (length xs) (length ys)"
  2409   have "P (zip (take ?n xs) (take ?n ys))"
  2410     by (rule assms) simp_all
  2411   moreover have "zip xs ys = zip (take ?n xs) (take ?n ys)"
  2412   proof (induct xs arbitrary: ys)
  2413     case Nil then show ?case by simp
  2414   next
  2415     case (Cons x xs) then show ?case by (cases ys) simp_all
  2416   qed
  2417   ultimately show ?thesis by simp
  2418 qed
  2419 
  2420 lemma zip_append1:
  2421 "zip (xs @ ys) zs =
  2422 zip xs (take (length xs) zs) @ zip ys (drop (length xs) zs)"
  2423 by (induct xs zs rule:list_induct2') auto
  2424 
  2425 lemma zip_append2:
  2426 "zip xs (ys @ zs) =
  2427 zip (take (length ys) xs) ys @ zip (drop (length ys) xs) zs"
  2428 by (induct xs ys rule:list_induct2') auto
  2429 
  2430 lemma zip_append [simp]:
  2431  "[| length xs = length us |] ==>
  2432 zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"
  2433 by (simp add: zip_append1)
  2434 
  2435 lemma zip_rev:
  2436 "length xs = length ys ==> zip (rev xs) (rev ys) = rev (zip xs ys)"
  2437 by (induct rule:list_induct2, simp_all)
  2438 
  2439 lemma zip_map_map:
  2440   "zip (map f xs) (map g ys) = map (\<lambda> (x, y). (f x, g y)) (zip xs ys)"
  2441 proof (induct xs arbitrary: ys)
  2442   case (Cons x xs) note Cons_x_xs = Cons.hyps
  2443   show ?case
  2444   proof (cases ys)
  2445     case (Cons y ys')
  2446     show ?thesis unfolding Cons using Cons_x_xs by simp
  2447   qed simp
  2448 qed simp
  2449 
  2450 lemma zip_map1:
  2451   "zip (map f xs) ys = map (\<lambda>(x, y). (f x, y)) (zip xs ys)"
  2452 using zip_map_map[of f xs "\<lambda>x. x" ys] by simp
  2453 
  2454 lemma zip_map2:
  2455   "zip xs (map f ys) = map (\<lambda>(x, y). (x, f y)) (zip xs ys)"
  2456 using zip_map_map[of "\<lambda>x. x" xs f ys] by simp
  2457 
  2458 lemma map_zip_map:
  2459   "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"
  2460 unfolding zip_map1 by auto
  2461 
  2462 lemma map_zip_map2:
  2463   "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"
  2464 unfolding zip_map2 by auto
  2465 
  2466 text{* Courtesy of Andreas Lochbihler: *}
  2467 lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"
  2468 by(induct xs) auto
  2469 
  2470 lemma nth_zip [simp]:
  2471 "[| i < length xs; i < length ys|] ==> (zip xs ys)!i = (xs!i, ys!i)"
  2472 apply (induct ys arbitrary: i xs, simp)
  2473 apply (case_tac xs)
  2474  apply (simp_all add: nth.simps split: nat.split)
  2475 done
  2476 
  2477 lemma set_zip:
  2478 "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"
  2479 by(simp add: set_conv_nth cong: rev_conj_cong)
  2480 
  2481 lemma zip_same: "((a,b) \<in> set (zip xs xs)) = (a \<in> set xs \<and> a = b)"
  2482 by(induct xs) auto
  2483 
  2484 lemma zip_update:
  2485   "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
  2486 by(rule sym, simp add: update_zip)
  2487 
  2488 lemma zip_replicate [simp]:
  2489   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"
  2490 apply (induct i arbitrary: j, auto)
  2491 apply (case_tac j, auto)
  2492 done
  2493 
  2494 lemma take_zip:
  2495   "take n (zip xs ys) = zip (take n xs) (take n ys)"
  2496 apply (induct n arbitrary: xs ys)
  2497  apply simp
  2498 apply (case_tac xs, simp)
  2499 apply (case_tac ys, simp_all)
  2500 done
  2501 
  2502 lemma drop_zip:
  2503   "drop n (zip xs ys) = zip (drop n xs) (drop n ys)"
  2504 apply (induct n arbitrary: xs ys)
  2505  apply simp
  2506 apply (case_tac xs, simp)
  2507 apply (case_tac ys, simp_all)
  2508 done
  2509 
  2510 lemma zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P \<circ> fst) (zip xs ys)"
  2511 proof (induct xs arbitrary: ys)
  2512   case (Cons x xs) thus ?case by (cases ys) auto
  2513 qed simp
  2514 
  2515 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"
  2516 proof (induct xs arbitrary: ys)
  2517   case (Cons x xs) thus ?case by (cases ys) auto
  2518 qed simp
  2519 
  2520 lemma set_zip_leftD:
  2521   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"
  2522 by (induct xs ys rule:list_induct2') auto
  2523 
  2524 lemma set_zip_rightD:
  2525   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"
  2526 by (induct xs ys rule:list_induct2') auto
  2527 
  2528 lemma in_set_zipE:
  2529   "(x,y) : set(zip xs ys) \<Longrightarrow> (\<lbrakk> x : set xs; y : set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
  2530 by(blast dest: set_zip_leftD set_zip_rightD)
  2531 
  2532 lemma zip_map_fst_snd:
  2533   "zip (map fst zs) (map snd zs) = zs"
  2534   by (induct zs) simp_all
  2535 
  2536 lemma zip_eq_conv:
  2537   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"
  2538   by (auto simp add: zip_map_fst_snd)
  2539 
  2540 lemma in_set_zip:
  2541   "p \<in> set (zip xs ys) \<longleftrightarrow> (\<exists>n. xs ! n = fst p \<and> ys ! n = snd p
  2542     \<and> n < length xs \<and> n < length ys)"
  2543   by (cases p) (auto simp add: set_zip)
  2544 
  2545 lemma pair_list_eqI:
  2546   assumes "map fst xs = map fst ys" and "map snd xs = map snd ys"
  2547   shows "xs = ys"
  2548 proof -
  2549   from assms(1) have "length xs = length ys" by (rule map_eq_imp_length_eq)
  2550   from this assms show ?thesis
  2551     by (induct xs ys rule: list_induct2) (simp_all add: prod_eqI)
  2552 qed
  2553 
  2554 
  2555 subsubsection {* @{const list_all2} *}
  2556 
  2557 lemma list_all2_lengthD [intro?]: 
  2558   "list_all2 P xs ys ==> length xs = length ys"
  2559 by (simp add: list_all2_iff)
  2560 
  2561 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"
  2562 by (simp add: list_all2_iff)
  2563 
  2564 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"
  2565 by (simp add: list_all2_iff)
  2566 
  2567 lemma list_all2_Cons [iff, code]:
  2568   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"
  2569 by (auto simp add: list_all2_iff)
  2570 
  2571 lemma list_all2_Cons1:
  2572 "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"
  2573 by (cases ys) auto
  2574 
  2575 lemma list_all2_Cons2:
  2576 "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"
  2577 by (cases xs) auto
  2578 
  2579 lemma list_all2_induct
  2580   [consumes 1, case_names Nil Cons, induct set: list_all2]:
  2581   assumes P: "list_all2 P xs ys"
  2582   assumes Nil: "R [] []"
  2583   assumes Cons: "\<And>x xs y ys.
  2584     \<lbrakk>P x y; list_all2 P xs ys; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"
  2585   shows "R xs ys"
  2586 using P
  2587 by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)
  2588 
  2589 lemma list_all2_rev [iff]:
  2590 "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"
  2591 by (simp add: list_all2_iff zip_rev cong: conj_cong)
  2592 
  2593 lemma list_all2_rev1:
  2594 "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"
  2595 by (subst list_all2_rev [symmetric]) simp
  2596 
  2597 lemma list_all2_append1:
  2598 "list_all2 P (xs @ ys) zs =
  2599 (EX us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>
  2600 list_all2 P xs us \<and> list_all2 P ys vs)"
  2601 apply (simp add: list_all2_iff zip_append1)
  2602 apply (rule iffI)
  2603  apply (rule_tac x = "take (length xs) zs" in exI)
  2604  apply (rule_tac x = "drop (length xs) zs" in exI)
  2605  apply (force split: nat_diff_split simp add: min_def, clarify)
  2606 apply (simp add: ball_Un)
  2607 done
  2608 
  2609 lemma list_all2_append2:
  2610 "list_all2 P xs (ys @ zs) =
  2611 (EX us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>
  2612 list_all2 P us ys \<and> list_all2 P vs zs)"
  2613 apply (simp add: list_all2_iff zip_append2)
  2614 apply (rule iffI)
  2615  apply (rule_tac x = "take (length ys) xs" in exI)
  2616  apply (rule_tac x = "drop (length ys) xs" in exI)
  2617  apply (force split: nat_diff_split simp add: min_def, clarify)
  2618 apply (simp add: ball_Un)
  2619 done
  2620 
  2621 lemma list_all2_append:
  2622   "length xs = length ys \<Longrightarrow>
  2623   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"
  2624 by (induct rule:list_induct2, simp_all)
  2625 
  2626 lemma list_all2_appendI [intro?, trans]:
  2627   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"
  2628 by (simp add: list_all2_append list_all2_lengthD)
  2629 
  2630 lemma list_all2_conv_all_nth:
  2631 "list_all2 P xs ys =
  2632 (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"
  2633 by (force simp add: list_all2_iff set_zip)
  2634 
  2635 lemma list_all2_trans:
  2636   assumes tr: "!!a b c. P1 a b ==> P2 b c ==> P3 a c"
  2637   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> list_all2 P3 as cs"
  2638         (is "!!bs cs. PROP ?Q as bs cs")
  2639 proof (induct as)
  2640   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"
  2641   show "!!cs. PROP ?Q (x # xs) bs cs"
  2642   proof (induct bs)
  2643     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"
  2644     show "PROP ?Q (x # xs) (y # ys) cs"
  2645       by (induct cs) (auto intro: tr I1 I2)
  2646   qed simp
  2647 qed simp
  2648 
  2649 lemma list_all2_all_nthI [intro?]:
  2650   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"
  2651 by (simp add: list_all2_conv_all_nth)
  2652 
  2653 lemma list_all2I:
  2654   "\<forall>x \<in> set (zip a b). split P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"
  2655 by (simp add: list_all2_iff)
  2656 
  2657 lemma list_all2_nthD:
  2658   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
  2659 by (simp add: list_all2_conv_all_nth)
  2660 
  2661 lemma list_all2_nthD2:
  2662   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
  2663 by (frule list_all2_lengthD) (auto intro: list_all2_nthD)
  2664 
  2665 lemma list_all2_map1: 
  2666   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"
  2667 by (simp add: list_all2_conv_all_nth)
  2668 
  2669 lemma list_all2_map2: 
  2670   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"
  2671 by (auto simp add: list_all2_conv_all_nth)
  2672 
  2673 lemma list_all2_refl [intro?]:
  2674   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"
  2675 by (simp add: list_all2_conv_all_nth)
  2676 
  2677 lemma list_all2_update_cong:
  2678   "\<lbrakk> list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"
  2679 by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)
  2680 
  2681 lemma list_all2_takeI [simp,intro?]:
  2682   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"
  2683 apply (induct xs arbitrary: n ys)
  2684  apply simp
  2685 apply (clarsimp simp add: list_all2_Cons1)
  2686 apply (case_tac n)
  2687 apply auto
  2688 done
  2689 
  2690 lemma list_all2_dropI [simp,intro?]:
  2691   "list_all2 P as bs \<Longrightarrow> list_all2 P (drop n as) (drop n bs)"
  2692 apply (induct as arbitrary: n bs, simp)
  2693 apply (clarsimp simp add: list_all2_Cons1)
  2694 apply (case_tac n, simp, simp)
  2695 done
  2696 
  2697 lemma list_all2_mono [intro?]:
  2698   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"
  2699 apply (induct xs arbitrary: ys, simp)
  2700 apply (case_tac ys, auto)
  2701 done
  2702 
  2703 lemma list_all2_eq:
  2704   "xs = ys \<longleftrightarrow> list_all2 (op =) xs ys"
  2705 by (induct xs ys rule: list_induct2') auto
  2706 
  2707 lemma list_eq_iff_zip_eq:
  2708   "xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x,y) \<in> set (zip xs ys). x = y)"
  2709 by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)
  2710 
  2711 
  2712 subsubsection {* @{const List.product} and @{const product_lists} *}
  2713 
  2714 lemma product_list_set:
  2715   "set (List.product xs ys) = set xs \<times> set ys"
  2716   by (induct xs) auto
  2717 
  2718 lemma length_product [simp]:
  2719   "length (List.product xs ys) = length xs * length ys"
  2720   by (induct xs) simp_all
  2721 
  2722 lemma product_nth:
  2723   assumes "n < length xs * length ys"
  2724   shows "List.product xs ys ! n = (xs ! (n div length ys), ys ! (n mod length ys))"
  2725 using assms proof (induct xs arbitrary: n)
  2726   case Nil then show ?case by simp
  2727 next
  2728   case (Cons x xs n)
  2729   then have "length ys > 0" by auto
  2730   with Cons show ?case
  2731     by (auto simp add: nth_append not_less le_mod_geq le_div_geq)
  2732 qed
  2733 
  2734 lemma in_set_product_lists_length: 
  2735   "xs \<in> set (product_lists xss) \<Longrightarrow> length xs = length xss"
  2736   by (induct xss arbitrary: xs) auto
  2737 
  2738 lemma product_lists_set:
  2739   "set (product_lists xss) = {xs. list_all2 (\<lambda>x ys. x \<in> set ys) xs xss}" (is "?L = Collect ?R")
  2740 proof (intro equalityI subsetI, unfold mem_Collect_eq)
  2741   fix xs assume "xs \<in> ?L"
  2742   then have "length xs = length xss" by (rule in_set_product_lists_length)
  2743   from this `xs \<in> ?L` show "?R xs" by (induct xs xss rule: list_induct2) auto
  2744 next
  2745   fix xs assume "?R xs"
  2746   then show "xs \<in> ?L" by induct auto
  2747 qed
  2748 
  2749 
  2750 subsubsection {* @{const fold} with natural argument order *}
  2751 
  2752 lemma fold_simps [code]: -- {* eta-expanded variant for generated code -- enables tail-recursion optimisation in Scala *}
  2753   "fold f [] s = s"
  2754   "fold f (x # xs) s = fold f xs (f x s)" 
  2755   by simp_all
  2756 
  2757 lemma fold_remove1_split:
  2758   assumes f: "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x"
  2759     and x: "x \<in> set xs"
  2760   shows "fold f xs = fold f (remove1 x xs) \<circ> f x"
  2761   using assms by (induct xs) (auto simp add: comp_assoc)
  2762 
  2763 lemma fold_cong [fundef_cong]:
  2764   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)
  2765     \<Longrightarrow> fold f xs a = fold g ys b"
  2766   by (induct ys arbitrary: a b xs) simp_all
  2767 
  2768 lemma fold_id:
  2769   assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"
  2770   shows "fold f xs = id"
  2771   using assms by (induct xs) simp_all
  2772 
  2773 lemma fold_commute:
  2774   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
  2775   shows "h \<circ> fold g xs = fold f xs \<circ> h"
  2776   using assms by (induct xs) (simp_all add: fun_eq_iff)
  2777 
  2778 lemma fold_commute_apply:
  2779   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
  2780   shows "h (fold g xs s) = fold f xs (h s)"
  2781 proof -
  2782   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)
  2783   then show ?thesis by (simp add: fun_eq_iff)
  2784 qed
  2785 
  2786 lemma fold_invariant: 
  2787   assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"
  2788     and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"
  2789   shows "P (fold f xs s)"
  2790   using assms by (induct xs arbitrary: s) simp_all
  2791 
  2792 lemma fold_append [simp]:
  2793   "fold f (xs @ ys) = fold f ys \<circ> fold f xs"
  2794   by (induct xs) simp_all
  2795 
  2796 lemma fold_map [code_unfold]:
  2797   "fold g (map f xs) = fold (g o f) xs"
  2798   by (induct xs) simp_all
  2799 
  2800 lemma fold_rev:
  2801   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
  2802   shows "fold f (rev xs) = fold f xs"
  2803 using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)
  2804 
  2805 lemma fold_Cons_rev:
  2806   "fold Cons xs = append (rev xs)"
  2807   by (induct xs) simp_all
  2808 
  2809 lemma rev_conv_fold [code]:
  2810   "rev xs = fold Cons xs []"
  2811   by (simp add: fold_Cons_rev)
  2812 
  2813 lemma fold_append_concat_rev:
  2814   "fold append xss = append (concat (rev xss))"
  2815   by (induct xss) simp_all
  2816 
  2817 text {* @{const Finite_Set.fold} and @{const fold} *}
  2818 
  2819 lemma (in comp_fun_commute) fold_set_fold_remdups:
  2820   "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
  2821   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm insert_absorb)
  2822 
  2823 lemma (in comp_fun_idem) fold_set_fold:
  2824   "Finite_Set.fold f y (set xs) = fold f xs y"
  2825   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm)
  2826 
  2827 lemma union_set_fold [code]:
  2828   "set xs \<union> A = fold Set.insert xs A"
  2829 proof -
  2830   interpret comp_fun_idem Set.insert
  2831     by (fact comp_fun_idem_insert)
  2832   show ?thesis by (simp add: union_fold_insert fold_set_fold)
  2833 qed
  2834 
  2835 lemma union_coset_filter [code]:
  2836   "List.coset xs \<union> A = List.coset (List.filter (\<lambda>x. x \<notin> A) xs)"
  2837   by auto
  2838 
  2839 lemma minus_set_fold [code]:
  2840   "A - set xs = fold Set.remove xs A"
  2841 proof -
  2842   interpret comp_fun_idem Set.remove
  2843     by (fact comp_fun_idem_remove)
  2844   show ?thesis
  2845     by (simp add: minus_fold_remove [of _ A] fold_set_fold)
  2846 qed
  2847 
  2848 lemma minus_coset_filter [code]:
  2849   "A - List.coset xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
  2850   by auto
  2851 
  2852 lemma inter_set_filter [code]:
  2853   "A \<inter> set xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
  2854   by auto
  2855 
  2856 lemma inter_coset_fold [code]:
  2857   "A \<inter> List.coset xs = fold Set.remove xs A"
  2858   by (simp add: Diff_eq [symmetric] minus_set_fold)
  2859 
  2860 lemma (in semilattice_set) set_eq_fold [code]:
  2861   "F (set (x # xs)) = fold f xs x"
  2862 proof -
  2863   interpret comp_fun_idem f
  2864     by default (simp_all add: fun_eq_iff left_commute)
  2865   show ?thesis by (simp add: eq_fold fold_set_fold)
  2866 qed
  2867 
  2868 lemma (in complete_lattice) Inf_set_fold:
  2869   "Inf (set xs) = fold inf xs top"
  2870 proof -
  2871   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2872     by (fact comp_fun_idem_inf)
  2873   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)
  2874 qed
  2875 
  2876 declare Inf_set_fold [where 'a = "'a set", code]
  2877 
  2878 lemma (in complete_lattice) Sup_set_fold:
  2879   "Sup (set xs) = fold sup xs bot"
  2880 proof -
  2881   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2882     by (fact comp_fun_idem_sup)
  2883   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)
  2884 qed
  2885 
  2886 declare Sup_set_fold [where 'a = "'a set", code]
  2887 
  2888 lemma (in complete_lattice) INF_set_fold:
  2889   "INFIMUM (set xs) f = fold (inf \<circ> f) xs top"
  2890   using Inf_set_fold [of "map f xs "] by (simp add: fold_map)
  2891 
  2892 declare INF_set_fold [code]
  2893 
  2894 lemma (in complete_lattice) SUP_set_fold:
  2895   "SUPREMUM (set xs) f = fold (sup \<circ> f) xs bot"
  2896   using Sup_set_fold [of "map f xs "] by (simp add: fold_map)
  2897 
  2898 declare SUP_set_fold [code]
  2899 
  2900 
  2901 subsubsection {* Fold variants: @{const foldr} and @{const foldl} *}
  2902 
  2903 text {* Correspondence *}
  2904 
  2905 lemma foldr_conv_fold [code_abbrev]:
  2906   "foldr f xs = fold f (rev xs)"
  2907   by (induct xs) simp_all
  2908 
  2909 lemma foldl_conv_fold:
  2910   "foldl f s xs = fold (\<lambda>x s. f s x) xs s"
  2911   by (induct xs arbitrary: s) simp_all
  2912 
  2913 lemma foldr_conv_foldl: -- {* The ``Third Duality Theorem'' in Bird \& Wadler: *}
  2914   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"
  2915   by (simp add: foldr_conv_fold foldl_conv_fold)
  2916 
  2917 lemma foldl_conv_foldr:
  2918   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"
  2919   by (simp add: foldr_conv_fold foldl_conv_fold)
  2920 
  2921 lemma foldr_fold:
  2922   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
  2923   shows "foldr f xs = fold f xs"
  2924   using assms unfolding foldr_conv_fold by (rule fold_rev)
  2925 
  2926 lemma foldr_cong [fundef_cong]:
  2927   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f x a = g x a) \<Longrightarrow> foldr f l a = foldr g k b"
  2928   by (auto simp add: foldr_conv_fold intro!: fold_cong)
  2929 
  2930 lemma foldl_cong [fundef_cong]:
  2931   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f a x = g a x) \<Longrightarrow> foldl f a l = foldl g b k"
  2932   by (auto simp add: foldl_conv_fold intro!: fold_cong)
  2933 
  2934 lemma foldr_append [simp]:
  2935   "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"
  2936   by (simp add: foldr_conv_fold)
  2937 
  2938 lemma foldl_append [simp]:
  2939   "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"
  2940   by (simp add: foldl_conv_fold)
  2941 
  2942 lemma foldr_map [code_unfold]:
  2943   "foldr g (map f xs) a = foldr (g o f) xs a"
  2944   by (simp add: foldr_conv_fold fold_map rev_map)
  2945 
  2946 lemma foldl_map [code_unfold]:
  2947   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"
  2948   by (simp add: foldl_conv_fold fold_map comp_def)
  2949 
  2950 lemma concat_conv_foldr [code]:
  2951   "concat xss = foldr append xss []"
  2952   by (simp add: fold_append_concat_rev foldr_conv_fold)
  2953 
  2954 
  2955 subsubsection {* @{const upt} *}
  2956 
  2957 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"
  2958 -- {* simp does not terminate! *}
  2959 by (induct j) auto
  2960 
  2961 lemmas upt_rec_numeral[simp] = upt_rec[of "numeral m" "numeral n"] for m n
  2962 
  2963 lemma upt_conv_Nil [simp]: "j <= i ==> [i..<j] = []"
  2964 by (subst upt_rec) simp
  2965 
  2966 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j <= i)"
  2967 by(induct j)simp_all
  2968 
  2969 lemma upt_eq_Cons_conv:
  2970  "([i..<j] = x#xs) = (i < j & i = x & [i+1..<j] = xs)"
  2971 apply(induct j arbitrary: x xs)
  2972  apply simp
  2973 apply(clarsimp simp add: append_eq_Cons_conv)
  2974 apply arith
  2975 done
  2976 
  2977 lemma upt_Suc_append: "i <= j ==> [i..<(Suc j)] = [i..<j]@[j]"
  2978 -- {* Only needed if @{text upt_Suc} is deleted from the simpset. *}
  2979 by simp
  2980 
  2981 lemma upt_conv_Cons: "i < j ==> [i..<j] = i # [Suc i..<j]"
  2982   by (simp add: upt_rec)
  2983 
  2984 lemma upt_add_eq_append: "i<=j ==> [i..<j+k] = [i..<j]@[j..<j+k]"
  2985 -- {* LOOPS as a simprule, since @{text "j <= j"}. *}
  2986 by (induct k) auto
  2987 
  2988 lemma length_upt [simp]: "length [i..<j] = j - i"
  2989 by (induct j) (auto simp add: Suc_diff_le)
  2990 
  2991 lemma nth_upt [simp]: "i + k < j ==> [i..<j] ! k = i + k"
  2992 apply (induct j)
  2993 apply (auto simp add: less_Suc_eq nth_append split: nat_diff_split)
  2994 done
  2995 
  2996 
  2997 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"
  2998 by(simp add:upt_conv_Cons)
  2999 
  3000 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"
  3001 apply(cases j)
  3002  apply simp
  3003 by(simp add:upt_Suc_append)
  3004 
  3005 lemma take_upt [simp]: "i+m <= n ==> take m [i..<n] = [i..<i+m]"
  3006 apply (induct m arbitrary: i, simp)
  3007 apply (subst upt_rec)
  3008 apply (rule sym)
  3009 apply (subst upt_rec)
  3010 apply (simp del: upt.simps)
  3011 done
  3012 
  3013 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"
  3014 apply(induct j)
  3015 apply auto
  3016 done
  3017 
  3018 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"
  3019 by (induct n) auto
  3020 
  3021 lemma map_add_upt: "map (\<lambda>i. i + n) [0..<m] = [n..<m + n]"
  3022   by (induct m) simp_all
  3023 
  3024 lemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"
  3025 apply (induct n m  arbitrary: i rule: diff_induct)
  3026 prefer 3 apply (subst map_Suc_upt[symmetric])
  3027 apply (auto simp add: less_diff_conv)
  3028 done
  3029 
  3030 lemma map_decr_upt:
  3031   "map (\<lambda>n. n - Suc 0) [Suc m..<Suc n] = [m..<n]"
  3032   by (induct n) simp_all
  3033 
  3034 lemma nth_take_lemma:
  3035   "k <= length xs ==> k <= length ys ==>
  3036      (!!i. i < k --> xs!i = ys!i) ==> take k xs = take k ys"
  3037 apply (atomize, induct k arbitrary: xs ys)
  3038 apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib, clarify)
  3039 txt {* Both lists must be non-empty *}
  3040 apply (case_tac xs, simp)
  3041 apply (case_tac ys, clarify)
  3042  apply (simp (no_asm_use))
  3043 apply clarify
  3044 txt {* prenexing's needed, not miniscoping *}
  3045 apply (simp (no_asm_use) add: all_simps [symmetric] del: all_simps)
  3046 apply blast
  3047 done
  3048 
  3049 lemma nth_equalityI:
  3050  "[| length xs = length ys; ALL i < length xs. xs!i = ys!i |] ==> xs = ys"
  3051   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all
  3052 
  3053 lemma map_nth:
  3054   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"
  3055   by (rule nth_equalityI, auto)
  3056 
  3057 (* needs nth_equalityI *)
  3058 lemma list_all2_antisym:
  3059   "\<lbrakk> (\<And>x y. \<lbrakk>P x y; Q y x\<rbrakk> \<Longrightarrow> x = y); list_all2 P xs ys; list_all2 Q ys xs \<rbrakk> 
  3060   \<Longrightarrow> xs = ys"
  3061   apply (simp add: list_all2_conv_all_nth) 
  3062   apply (rule nth_equalityI, blast, simp)
  3063   done
  3064 
  3065 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) ==> xs = ys"
  3066 -- {* The famous take-lemma. *}
  3067 apply (drule_tac x = "max (length xs) (length ys)" in spec)
  3068 apply (simp add: le_max_iff_disj)
  3069 done
  3070 
  3071 
  3072 lemma take_Cons':
  3073      "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"
  3074 by (cases n) simp_all
  3075 
  3076 lemma drop_Cons':
  3077      "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"
  3078 by (cases n) simp_all
  3079 
  3080 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"
  3081 by (cases n) simp_all
  3082 
  3083 lemma take_Cons_numeral [simp]:
  3084   "take (numeral v) (x # xs) = x # take (numeral v - 1) xs"
  3085 by (simp add: take_Cons')
  3086 
  3087 lemma drop_Cons_numeral [simp]:
  3088   "drop (numeral v) (x # xs) = drop (numeral v - 1) xs"
  3089 by (simp add: drop_Cons')
  3090 
  3091 lemma nth_Cons_numeral [simp]:
  3092   "(x # xs) ! numeral v = xs ! (numeral v - 1)"
  3093 by (simp add: nth_Cons')
  3094 
  3095 
  3096 subsubsection {* @{text upto}: interval-list on @{typ int} *}
  3097 
  3098 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where
  3099   "upto i j = (if i \<le> j then i # [i+1..j] else [])"
  3100 by auto
  3101 termination
  3102 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto
  3103 
  3104 declare upto.simps[simp del]
  3105 
  3106 lemmas upto_rec_numeral [simp] =
  3107   upto.simps[of "numeral m" "numeral n"]
  3108   upto.simps[of "numeral m" "- numeral n"]
  3109   upto.simps[of "- numeral m" "numeral n"]
  3110   upto.simps[of "- numeral m" "- numeral n"] for m n
  3111 
  3112 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
  3113 by(simp add: upto.simps)
  3114 
  3115 lemma upto_rec1: "i \<le> j \<Longrightarrow> [i..j] = i#[i+1..j]"
  3116 by(simp add: upto.simps)
  3117 
  3118 lemma upto_rec2: "i \<le> j \<Longrightarrow> [i..j] = [i..j - 1]@[j]"
  3119 proof(induct "nat(j-i)" arbitrary: i j)
  3120   case 0 thus ?case by(simp add: upto.simps)
  3121 next
  3122   case (Suc n)
  3123   hence "n = nat (j - (i + 1))" "i < j" by linarith+
  3124   from this(2) Suc.hyps(1)[OF this(1)] Suc(2,3) upto_rec1 show ?case by simp
  3125 qed
  3126 
  3127 lemma set_upto[simp]: "set[i..j] = {i..j}"
  3128 proof(induct i j rule:upto.induct)
  3129   case (1 i j)
  3130   from this show ?case
  3131     unfolding upto.simps[of i j] by auto
  3132 qed
  3133 
  3134 text{* Tail recursive version for code generation: *}
  3135 
  3136 definition upto_aux :: "int \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list" where
  3137   "upto_aux i j js = [i..j] @ js"
  3138 
  3139 lemma upto_aux_rec [code]:
  3140   "upto_aux i j js = (if j<i then js else upto_aux i (j - 1) (j#js))"
  3141   by (simp add: upto_aux_def upto_rec2)
  3142 
  3143 lemma upto_code[code]: "[i..j] = upto_aux i j []"
  3144 by(simp add: upto_aux_def)
  3145 
  3146 
  3147 subsubsection {* @{const distinct} and @{const remdups} and @{const remdups_adj} *}
  3148 
  3149 lemma distinct_tl:
  3150   "distinct xs \<Longrightarrow> distinct (tl xs)"
  3151   by (cases xs) simp_all
  3152 
  3153 lemma distinct_append [simp]:
  3154 "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"
  3155 by (induct xs) auto
  3156 
  3157 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"
  3158 by(induct xs) auto
  3159 
  3160 lemma set_remdups [simp]: "set (remdups xs) = set xs"
  3161 by (induct xs) (auto simp add: insert_absorb)
  3162 
  3163 lemma distinct_remdups [iff]: "distinct (remdups xs)"
  3164 by (induct xs) auto
  3165 
  3166 lemma distinct_remdups_id: "distinct xs ==> remdups xs = xs"
  3167 by (induct xs, auto)
  3168 
  3169 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"
  3170 by (metis distinct_remdups distinct_remdups_id)
  3171 
  3172 lemma finite_distinct_list: "finite A \<Longrightarrow> EX xs. set xs = A & distinct xs"
  3173 by (metis distinct_remdups finite_list set_remdups)
  3174 
  3175 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"
  3176 by (induct x, auto)
  3177 
  3178 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"
  3179 by (induct x, auto)
  3180 
  3181 lemma length_remdups_leq[iff]: "length(remdups xs) <= length xs"
  3182 by (induct xs) auto
  3183 
  3184 lemma length_remdups_eq[iff]:
  3185   "(length (remdups xs) = length xs) = (remdups xs = xs)"
  3186 apply(induct xs)
  3187  apply auto
  3188 apply(subgoal_tac "length (remdups xs) <= length xs")
  3189  apply arith
  3190 apply(rule length_remdups_leq)
  3191 done
  3192 
  3193 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"
  3194 apply(induct xs)
  3195 apply auto
  3196 done
  3197 
  3198 lemma distinct_map:
  3199   "distinct(map f xs) = (distinct xs & inj_on f (set xs))"
  3200 by (induct xs) auto
  3201 
  3202 lemma distinct_filter [simp]: "distinct xs ==> distinct (filter P xs)"
  3203 by (induct xs) auto
  3204 
  3205 lemma distinct_upt[simp]: "distinct[i..<j]"
  3206 by (induct j) auto
  3207 
  3208 lemma distinct_upto[simp]: "distinct[i..j]"
  3209 apply(induct i j rule:upto.induct)
  3210 apply(subst upto.simps)
  3211 apply(simp)
  3212 done
  3213 
  3214 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"
  3215 apply(induct xs arbitrary: i)
  3216  apply simp
  3217 apply (case_tac i)
  3218  apply simp_all
  3219 apply(blast dest:in_set_takeD)
  3220 done
  3221 
  3222 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"
  3223 apply(induct xs arbitrary: i)
  3224  apply simp
  3225 apply (case_tac i)
  3226  apply simp_all
  3227 done
  3228 
  3229 lemma distinct_list_update:
  3230 assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"
  3231 shows "distinct (xs[i:=a])"
  3232 proof (cases "i < length xs")
  3233   case True
  3234   with a have "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"
  3235     apply (drule_tac id_take_nth_drop) by simp
  3236   with d True show ?thesis
  3237     apply (simp add: upd_conv_take_nth_drop)
  3238     apply (drule subst [OF id_take_nth_drop]) apply assumption
  3239     apply simp apply (cases "a = xs!i") apply simp by blast
  3240 next
  3241   case False with d show ?thesis by auto
  3242 qed
  3243 
  3244 lemma distinct_concat:
  3245   assumes "distinct xs"
  3246   and "\<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys"
  3247   and "\<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}"
  3248   shows "distinct (concat xs)"
  3249   using assms by (induct xs) auto
  3250 
  3251 text {* It is best to avoid this indexed version of distinct, but
  3252 sometimes it is useful. *}
  3253 
  3254 lemma distinct_conv_nth:
  3255 "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j --> xs!i \<noteq> xs!j)"
  3256 apply (induct xs, simp, simp)
  3257 apply (rule iffI, clarsimp)
  3258  apply (case_tac i)
  3259 apply (case_tac j, simp)
  3260 apply (simp add: set_conv_nth)
  3261  apply (case_tac j)
  3262 apply (clarsimp simp add: set_conv_nth, simp)
  3263 apply (rule conjI)
  3264  apply (clarsimp simp add: set_conv_nth)
  3265  apply (erule_tac x = 0 in allE, simp)
  3266  apply (erule_tac x = "Suc i" in allE, simp, clarsimp)
  3267 apply (erule_tac x = "Suc i" in allE, simp)
  3268 apply (erule_tac x = "Suc j" in allE, simp)
  3269 done
  3270 
  3271 lemma nth_eq_iff_index_eq:
  3272  "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"
  3273 by(auto simp: distinct_conv_nth)
  3274 
  3275 lemma set_update_distinct: "\<lbrakk> distinct xs;  n < length xs \<rbrakk> \<Longrightarrow>
  3276   set(xs[n := x]) = insert x (set xs - {xs!n})"
  3277 by(auto simp: set_eq_iff in_set_conv_nth nth_list_update nth_eq_iff_index_eq)
  3278 
  3279 lemma distinct_card: "distinct xs ==> card (set xs) = size xs"
  3280 by (induct xs) auto
  3281 
  3282 lemma card_distinct: "card (set xs) = size xs ==> distinct xs"
  3283 proof (induct xs)
  3284   case Nil thus ?case by simp
  3285 next
  3286   case (Cons x xs)
  3287   show ?case
  3288   proof (cases "x \<in> set xs")
  3289     case False with Cons show ?thesis by simp
  3290   next
  3291     case True with Cons.prems
  3292     have "card (set xs) = Suc (length xs)"
  3293       by (simp add: card_insert_if split: split_if_asm)
  3294     moreover have "card (set xs) \<le> length xs" by (rule card_length)
  3295     ultimately have False by simp
  3296     thus ?thesis ..
  3297   qed
  3298 qed
  3299 
  3300 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"
  3301 by (induct xs) (auto)
  3302 
  3303 lemma not_distinct_decomp: "~ distinct ws ==> EX xs ys zs y. ws = xs@[y]@ys@[y]@zs"
  3304 apply (induct n == "length ws" arbitrary:ws) apply simp
  3305 apply(case_tac ws) apply simp
  3306 apply (simp split:split_if_asm)
  3307 apply (metis Cons_eq_appendI eq_Nil_appendI split_list)
  3308 done
  3309 
  3310 lemma not_distinct_conv_prefix:
  3311   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"
  3312   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")
  3313 proof
  3314   assume "?L" then show "?R"
  3315   proof (induct "length as" arbitrary: as rule: less_induct)
  3316     case less
  3317     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"
  3318       using not_distinct_decomp[OF less.prems] by auto
  3319     show ?case
  3320     proof (cases "distinct (xs @ y # ys)")
  3321       case True
  3322       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)
  3323       then show ?thesis by blast
  3324     next
  3325       case False
  3326       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"
  3327         by atomize_elim auto
  3328       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)
  3329       then show ?thesis by blast
  3330     qed
  3331   qed
  3332 qed (auto simp: dec_def)
  3333 
  3334 lemma distinct_product:
  3335   assumes "distinct xs" and "distinct ys"
  3336   shows "distinct (List.product xs ys)"
  3337   using assms by (induct xs)
  3338     (auto intro: inj_onI simp add: product_list_set distinct_map)
  3339 
  3340 lemma distinct_product_lists:
  3341   assumes "\<forall>xs \<in> set xss. distinct xs"
  3342   shows "distinct (product_lists xss)"
  3343 using assms proof (induction xss)
  3344   case (Cons xs xss) note * = this
  3345   then show ?case
  3346   proof (cases "product_lists xss")
  3347     case Nil then show ?thesis by (induct xs) simp_all
  3348   next
  3349     case (Cons ps pss) with * show ?thesis 
  3350       by (auto intro!: inj_onI distinct_concat simp add: distinct_map)
  3351   qed
  3352 qed simp
  3353 
  3354 lemma length_remdups_concat:
  3355   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"
  3356   by (simp add: distinct_card [symmetric])
  3357 
  3358 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"
  3359 proof -
  3360   have xs: "concat[xs] = xs" by simp
  3361   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp
  3362 qed
  3363 
  3364 lemma remdups_remdups:
  3365   "remdups (remdups xs) = remdups xs"
  3366   by (induct xs) simp_all
  3367 
  3368 lemma distinct_butlast:
  3369   assumes "distinct xs"
  3370   shows "distinct (butlast xs)"
  3371 proof (cases "xs = []")
  3372   case False
  3373     from `xs \<noteq> []` obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
  3374     with `distinct xs` show ?thesis by simp
  3375 qed (auto)
  3376 
  3377 lemma remdups_map_remdups:
  3378   "remdups (map f (remdups xs)) = remdups (map f xs)"
  3379   by (induct xs) simp_all
  3380 
  3381 lemma distinct_zipI1:
  3382   assumes "distinct xs"
  3383   shows "distinct (zip xs ys)"
  3384 proof (rule zip_obtain_same_length)
  3385   fix xs' :: "'a list" and ys' :: "'b list" and n
  3386   assume "length xs' = length ys'"
  3387   assume "xs' = take n xs"
  3388   with assms have "distinct xs'" by simp
  3389   with `length xs' = length ys'` show "distinct (zip xs' ys')"
  3390     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
  3391 qed
  3392 
  3393 lemma distinct_zipI2:
  3394   assumes "distinct ys"
  3395   shows "distinct (zip xs ys)"
  3396 proof (rule zip_obtain_same_length)
  3397   fix xs' :: "'b list" and ys' :: "'a list" and n
  3398   assume "length xs' = length ys'"
  3399   assume "ys' = take n ys"
  3400   with assms have "distinct ys'" by simp
  3401   with `length xs' = length ys'` show "distinct (zip xs' ys')"
  3402     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
  3403 qed
  3404 
  3405 lemma set_take_disj_set_drop_if_distinct:
  3406   "distinct vs \<Longrightarrow> i \<le> j \<Longrightarrow> set (take i vs) \<inter> set (drop j vs) = {}"
  3407 by (auto simp: in_set_conv_nth distinct_conv_nth)
  3408 
  3409 (* The next two lemmas help Sledgehammer. *)
  3410 
  3411 lemma distinct_singleton: "distinct [x]" by simp
  3412 
  3413 lemma distinct_length_2_or_more:
  3414 "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"
  3415 by force
  3416 
  3417 lemma remdups_adj_Cons: "remdups_adj (x # xs) =
  3418   (case remdups_adj xs of [] \<Rightarrow> [x] | y # xs \<Rightarrow> if x = y then y # xs else x # y # xs)"
  3419   by (induct xs arbitrary: x) (auto split: list.splits)
  3420 
  3421 lemma remdups_adj_append_two: 
  3422   "remdups_adj (xs @ [x,y]) = remdups_adj (xs @ [x]) @ (if x = y then [] else [y])"
  3423   by (induct xs rule: remdups_adj.induct, simp_all)
  3424 
  3425 lemma remdups_adj_rev[simp]: "remdups_adj (rev xs) = rev (remdups_adj xs)"
  3426   by (induct xs rule: remdups_adj.induct, simp_all add: remdups_adj_append_two)
  3427 
  3428 lemma remdups_adj_length[simp]: "length (remdups_adj xs) \<le> length xs"
  3429   by (induct xs rule: remdups_adj.induct, auto)
  3430 
  3431 lemma remdups_adj_length_ge1[simp]: "xs \<noteq> [] \<Longrightarrow> length (remdups_adj xs) \<ge> Suc 0"
  3432   by (induct xs rule: remdups_adj.induct, simp_all)
  3433 
  3434 lemma remdups_adj_Nil_iff[simp]: "remdups_adj xs = [] \<longleftrightarrow> xs = []"
  3435   by (induct xs rule: remdups_adj.induct, simp_all)
  3436 
  3437 lemma remdups_adj_set[simp]: "set (remdups_adj xs) = set xs"
  3438   by (induct xs rule: remdups_adj.induct, simp_all)
  3439 
  3440 lemma remdups_adj_Cons_alt[simp]: "x # tl (remdups_adj (x # xs)) = remdups_adj (x # xs)"
  3441     by (induct xs rule: remdups_adj.induct, auto)
  3442 
  3443 lemma remdups_adj_distinct: "distinct xs \<Longrightarrow> remdups_adj xs = xs"
  3444     by (induct xs rule: remdups_adj.induct, simp_all)
  3445 
  3446 lemma remdups_adj_append: 
  3447   "remdups_adj (xs\<^sub>1 @ x # xs\<^sub>2) = remdups_adj (xs\<^sub>1 @ [x]) @ tl (remdups_adj (x # xs\<^sub>2))"
  3448   by (induct xs\<^sub>1 rule: remdups_adj.induct, simp_all)
  3449 
  3450 lemma remdups_adj_singleton:
  3451   "remdups_adj xs = [x] \<Longrightarrow> xs = replicate (length xs) x"
  3452   by (induct xs rule: remdups_adj.induct, auto split: split_if_asm)
  3453 
  3454 lemma remdups_adj_map_injective:
  3455   assumes "inj f"
  3456   shows "remdups_adj (map f xs) = map f (remdups_adj xs)"
  3457   by (induct xs rule: remdups_adj.induct, 
  3458       auto simp add: injD[OF assms])
  3459 
  3460 
  3461 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}
  3462 
  3463 lemma (in monoid_add) listsum_simps [simp]:
  3464   "listsum [] = 0"
  3465   "listsum (x # xs) = x + listsum xs"
  3466   by (simp_all add: listsum_def)
  3467 
  3468 lemma (in monoid_add) listsum_append [simp]:
  3469   "listsum (xs @ ys) = listsum xs + listsum ys"
  3470   by (induct xs) (simp_all add: add.assoc)
  3471 
  3472 lemma (in comm_monoid_add) listsum_rev [simp]:
  3473   "listsum (rev xs) = listsum xs"
  3474   by (simp add: listsum_def foldr_fold fold_rev fun_eq_iff add_ac)
  3475 
  3476 lemma (in monoid_add) fold_plus_listsum_rev:
  3477   "fold plus xs = plus (listsum (rev xs))"
  3478 proof
  3479   fix x
  3480   have "fold plus xs x = fold plus xs (x + 0)" by simp
  3481   also have "\<dots> = fold plus (x # xs) 0" by simp
  3482   also have "\<dots> = foldr plus (rev xs @ [x]) 0" by (simp add: foldr_conv_fold)
  3483   also have "\<dots> = listsum (rev xs @ [x])" by (simp add: listsum_def)
  3484   also have "\<dots> = listsum (rev xs) + listsum [x]" by simp
  3485   finally show "fold plus xs x = listsum (rev xs) + x" by simp
  3486 qed
  3487 
  3488 text{* Some syntactic sugar for summing a function over a list: *}
  3489 
  3490 syntax
  3491   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)
  3492 syntax (xsymbols)
  3493   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
  3494 syntax (HTML output)
  3495   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
  3496 
  3497 translations -- {* Beware of argument permutation! *}
  3498   "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)"
  3499   "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"
  3500 
  3501 lemma (in comm_monoid_add) listsum_map_remove1:
  3502   "x \<in> set xs \<Longrightarrow> listsum (map f xs) = f x + listsum (map f (remove1 x xs))"
  3503   by (induct xs) (auto simp add: ac_simps)
  3504 
  3505 lemma (in monoid_add) size_list_conv_listsum:
  3506   "size_list f xs = listsum (map f xs) + size xs"
  3507   by (induct xs) auto
  3508 
  3509 lemma (in monoid_add) length_concat:
  3510   "length (concat xss) = listsum (map length xss)"
  3511   by (induct xss) simp_all
  3512 
  3513 lemma (in monoid_add) length_product_lists:
  3514   "length (product_lists xss) = foldr op * (map length xss) 1"
  3515 proof (induct xss)
  3516   case (Cons xs xss) then show ?case by (induct xs) (auto simp: length_concat o_def)
  3517 qed simp
  3518 
  3519 lemma (in monoid_add) listsum_map_filter:
  3520   assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"
  3521   shows "listsum (map f (filter P xs)) = listsum (map f xs)"
  3522   using assms by (induct xs) auto
  3523 
  3524 lemma (in comm_monoid_add) distinct_listsum_conv_Setsum:
  3525   "distinct xs \<Longrightarrow> listsum xs = Setsum (set xs)"
  3526   by (induct xs) simp_all
  3527 
  3528 lemma listsum_eq_0_nat_iff_nat [simp]:
  3529   "listsum ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"
  3530   by (induct ns) simp_all
  3531 
  3532 lemma member_le_listsum_nat:
  3533   "(n :: nat) \<in> set ns \<Longrightarrow> n \<le> listsum ns"
  3534   by (induct ns) auto
  3535 
  3536 lemma elem_le_listsum_nat:
  3537   "k < size ns \<Longrightarrow> ns ! k \<le> listsum (ns::nat list)"
  3538   by (rule member_le_listsum_nat) simp
  3539 
  3540 lemma listsum_update_nat:
  3541   "k < size ns \<Longrightarrow> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"
  3542 apply(induct ns arbitrary:k)
  3543  apply (auto split:nat.split)
  3544 apply(drule elem_le_listsum_nat)
  3545 apply arith
  3546 done
  3547 
  3548 lemma (in monoid_add) listsum_triv:
  3549   "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"
  3550   by (induct xs) (simp_all add: distrib_right)
  3551 
  3552 lemma (in monoid_add) listsum_0 [simp]:
  3553   "(\<Sum>x\<leftarrow>xs. 0) = 0"
  3554   by (induct xs) (simp_all add: distrib_right)
  3555 
  3556 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}
  3557 lemma (in ab_group_add) uminus_listsum_map:
  3558   "- listsum (map f xs) = listsum (map (uminus \<circ> f) xs)"
  3559   by (induct xs) simp_all
  3560 
  3561 lemma (in comm_monoid_add) listsum_addf:
  3562   "(\<Sum>x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)"
  3563   by (induct xs) (simp_all add: algebra_simps)
  3564 
  3565 lemma (in ab_group_add) listsum_subtractf:
  3566   "(\<Sum>x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)"
  3567   by (induct xs) (simp_all add: algebra_simps)
  3568 
  3569 lemma (in semiring_0) listsum_const_mult:
  3570   "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"
  3571   by (induct xs) (simp_all add: algebra_simps)
  3572 
  3573 lemma (in semiring_0) listsum_mult_const:
  3574   "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"
  3575   by (induct xs) (simp_all add: algebra_simps)
  3576 
  3577 lemma (in ordered_ab_group_add_abs) listsum_abs:
  3578   "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"
  3579   by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])
  3580 
  3581 lemma listsum_mono:
  3582   fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"
  3583   shows "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Sum>x\<leftarrow>xs. f x) \<le> (\<Sum>x\<leftarrow>xs. g x)"
  3584   by (induct xs) (simp, simp add: add_mono)
  3585 
  3586 lemma (in monoid_add) listsum_distinct_conv_setsum_set:
  3587   "distinct xs \<Longrightarrow> listsum (map f xs) = setsum f (set xs)"
  3588   by (induct xs) simp_all
  3589 
  3590 lemma (in monoid_add) interv_listsum_conv_setsum_set_nat:
  3591   "listsum (map f [m..<n]) = setsum f (set [m..<n])"
  3592   by (simp add: listsum_distinct_conv_setsum_set)
  3593 
  3594 lemma (in monoid_add) interv_listsum_conv_setsum_set_int:
  3595   "listsum (map f [k..l]) = setsum f (set [k..l])"
  3596   by (simp add: listsum_distinct_conv_setsum_set)
  3597 
  3598 text {* General equivalence between @{const listsum} and @{const setsum} *}
  3599 lemma (in monoid_add) listsum_setsum_nth:
  3600   "listsum xs = (\<Sum> i = 0 ..< length xs. xs ! i)"
  3601   using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)
  3602 
  3603 
  3604 subsubsection {* @{const insert} *}
  3605 
  3606 lemma in_set_insert [simp]:
  3607   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"
  3608   by (simp add: List.insert_def)
  3609 
  3610 lemma not_in_set_insert [simp]:
  3611   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"
  3612   by (simp add: List.insert_def)
  3613 
  3614 lemma insert_Nil [simp]:
  3615   "List.insert x [] = [x]"
  3616   by simp
  3617 
  3618 lemma set_insert [simp]:
  3619   "set (List.insert x xs) = insert x (set xs)"
  3620   by (auto simp add: List.insert_def)
  3621 
  3622 lemma distinct_insert [simp]:
  3623   "distinct (List.insert x xs) = distinct xs"
  3624   by (simp add: List.insert_def)
  3625 
  3626 lemma insert_remdups:
  3627   "List.insert x (remdups xs) = remdups (List.insert x xs)"
  3628   by (simp add: List.insert_def)
  3629 
  3630 
  3631 subsubsection {* @{const List.union} *}
  3632 
  3633 text{* This is all one should need to know about union: *}
  3634 lemma set_union[simp]: "set (List.union xs ys) = set xs \<union> set ys"
  3635 unfolding List.union_def
  3636 by(induct xs arbitrary: ys) simp_all
  3637 
  3638 lemma distinct_union[simp]: "distinct(List.union xs ys) = distinct ys"
  3639 unfolding List.union_def
  3640 by(induct xs arbitrary: ys) simp_all
  3641 
  3642 
  3643 subsubsection {* @{const List.find} *}
  3644 
  3645 lemma find_None_iff: "List.find P xs = None \<longleftrightarrow> \<not> (\<exists>x. x \<in> set xs \<and> P x)"
  3646 proof (induction xs)
  3647   case Nil thus ?case by simp
  3648 next
  3649   case (Cons x xs) thus ?case by (fastforce split: if_splits)
  3650 qed
  3651 
  3652 lemma find_Some_iff:
  3653   "List.find P xs = Some x \<longleftrightarrow>
  3654   (\<exists>i<length xs. P (xs!i) \<and> x = xs!i \<and> (\<forall>j<i. \<not> P (xs!j)))"
  3655 proof (induction xs)
  3656   case Nil thus ?case by simp
  3657 next
  3658   case (Cons x xs) thus ?case
  3659     apply(auto simp: nth_Cons' split: if_splits)
  3660     using diff_Suc_1[unfolded One_nat_def] less_Suc_eq_0_disj by fastforce
  3661 qed
  3662 
  3663 lemma find_cong[fundef_cong]:
  3664   assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x" 
  3665   shows "List.find P xs = List.find Q ys"
  3666 proof (cases "List.find P xs")
  3667   case None thus ?thesis by (metis find_None_iff assms)
  3668 next
  3669   case (Some x)
  3670   hence "List.find Q ys = Some x" using assms
  3671     by (auto simp add: find_Some_iff)
  3672   thus ?thesis using Some by auto
  3673 qed
  3674 
  3675 lemma find_dropWhile:
  3676   "List.find P xs = (case dropWhile (Not \<circ> P) xs
  3677    of [] \<Rightarrow> None
  3678     | x # _ \<Rightarrow> Some x)"
  3679   by (induct xs) simp_all
  3680 
  3681 
  3682 subsubsection {* @{const List.extract} *}
  3683 
  3684 lemma extract_None_iff: "List.extract P xs = None \<longleftrightarrow> \<not> (\<exists> x\<in>set xs. P x)"
  3685 by(auto simp: extract_def dropWhile_eq_Cons_conv split: list.splits)
  3686   (metis in_set_conv_decomp)
  3687 
  3688 lemma extract_SomeE:
  3689  "List.extract P xs = Some (ys, y, zs) \<Longrightarrow>
  3690   xs = ys @ y # zs \<and> P y \<and> \<not> (\<exists> y \<in> set ys. P y)" 
  3691 by(auto simp: extract_def dropWhile_eq_Cons_conv split: list.splits)
  3692 
  3693 lemma extract_Some_iff:
  3694   "List.extract P xs = Some (ys, y, zs) \<longleftrightarrow>
  3695    xs = ys @ y # zs \<and> P y \<and> \<not> (\<exists> y \<in> set ys. P y)" 
  3696 by(auto simp: extract_def dropWhile_eq_Cons_conv dest: set_takeWhileD split: list.splits)
  3697 
  3698 lemma extract_Nil_code[code]: "List.extract P [] = None"
  3699 by(simp add: extract_def)
  3700 
  3701 lemma extract_Cons_code[code]:
  3702   "List.extract P (x # xs) = (if P x then Some ([], x, xs) else
  3703    (case List.extract P xs of
  3704       None \<Rightarrow> None |
  3705       Some (ys, y, zs) \<Rightarrow> Some (x#ys, y, zs)))"
  3706 by(auto simp add: extract_def comp_def split: list.splits)
  3707   (metis dropWhile_eq_Nil_conv list.distinct(1))
  3708 
  3709 
  3710 subsubsection {* @{const remove1} *}
  3711 
  3712 lemma remove1_append:
  3713   "remove1 x (xs @ ys) =
  3714   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"
  3715 by (induct xs) auto
  3716 
  3717 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"
  3718 by (induct zs) auto
  3719 
  3720 lemma in_set_remove1[simp]:
  3721   "a \<noteq> b \<Longrightarrow> a : set(remove1 b xs) = (a : set xs)"
  3722 apply (induct xs)
  3723 apply auto
  3724 done
  3725 
  3726 lemma set_remove1_subset: "set(remove1 x xs) <= set xs"
  3727 apply(induct xs)
  3728  apply simp
  3729 apply simp
  3730 apply blast
  3731 done
  3732 
  3733 lemma set_remove1_eq [simp]: "distinct xs ==> set(remove1 x xs) = set xs - {x}"
  3734 apply(induct xs)
  3735  apply simp
  3736 apply simp
  3737 apply blast
  3738 done
  3739 
  3740 lemma length_remove1:
  3741   "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"
  3742 apply (induct xs)
  3743  apply (auto dest!:length_pos_if_in_set)
  3744 done
  3745 
  3746 lemma remove1_filter_not[simp]:
  3747   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"
  3748 by(induct xs) auto
  3749 
  3750 lemma filter_remove1:
  3751   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"
  3752 by (induct xs) auto
  3753 
  3754 lemma notin_set_remove1[simp]: "x ~: set xs ==> x ~: set(remove1 y xs)"
  3755 apply(insert set_remove1_subset)
  3756 apply fast
  3757 done
  3758 
  3759 lemma distinct_remove1[simp]: "distinct xs ==> distinct(remove1 x xs)"
  3760 by (induct xs) simp_all
  3761 
  3762 lemma remove1_remdups:
  3763   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"
  3764   by (induct xs) simp_all
  3765 
  3766 lemma remove1_idem:
  3767   assumes "x \<notin> set xs"
  3768   shows "remove1 x xs = xs"
  3769   using assms by (induct xs) simp_all
  3770 
  3771 
  3772 subsubsection {* @{const removeAll} *}
  3773 
  3774 lemma removeAll_filter_not_eq:
  3775   "removeAll x = filter (\<lambda>y. x \<noteq> y)"
  3776 proof
  3777   fix xs
  3778   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"
  3779     by (induct xs) auto
  3780 qed
  3781 
  3782 lemma removeAll_append[simp]:
  3783   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"
  3784 by (induct xs) auto
  3785 
  3786 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"
  3787 by (induct xs) auto
  3788 
  3789 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"
  3790 by (induct xs) auto
  3791 
  3792 (* Needs count:: 'a \<Rightarrow> 'a list \<Rightarrow> nat
  3793 lemma length_removeAll:
  3794   "length(removeAll x xs) = length xs - count x xs"
  3795 *)
  3796 
  3797 lemma removeAll_filter_not[simp]:
  3798   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"
  3799 by(induct xs) auto
  3800 
  3801 lemma distinct_removeAll:
  3802   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"
  3803   by (simp add: removeAll_filter_not_eq)
  3804 
  3805 lemma distinct_remove1_removeAll:
  3806   "distinct xs ==> remove1 x xs = removeAll x xs"
  3807 by (induct xs) simp_all
  3808 
  3809 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>
  3810   map f (removeAll x xs) = removeAll (f x) (map f xs)"
  3811 by (induct xs) (simp_all add:inj_on_def)
  3812 
  3813 lemma map_removeAll_inj: "inj f \<Longrightarrow>
  3814   map f (removeAll x xs) = removeAll (f x) (map f xs)"
  3815 by (rule map_removeAll_inj_on, erule subset_inj_on, rule subset_UNIV)
  3816 
  3817 
  3818 subsubsection {* @{const replicate} *}
  3819 
  3820 lemma length_replicate [simp]: "length (replicate n x) = n"
  3821 by (induct n) auto
  3822 
  3823 lemma Ex_list_of_length: "\<exists>xs. length xs = n"
  3824 by (rule exI[of _ "replicate n undefined"]) simp
  3825 
  3826 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"
  3827 by (induct n) auto
  3828 
  3829 lemma map_replicate_const:
  3830   "map (\<lambda> x. k) lst = replicate (length lst) k"
  3831   by (induct lst) auto
  3832 
  3833 lemma replicate_app_Cons_same:
  3834 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"
  3835 by (induct n) auto
  3836 
  3837 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"
  3838 apply (induct n, simp)
  3839 apply (simp add: replicate_app_Cons_same)
  3840 done
  3841 
  3842 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"
  3843 by (induct n) auto
  3844 
  3845 text{* Courtesy of Matthias Daum: *}
  3846 lemma append_replicate_commute:
  3847   "replicate n x @ replicate k x = replicate k x @ replicate n x"
  3848 apply (simp add: replicate_add [THEN sym])
  3849 apply (simp add: add_commute)
  3850 done
  3851 
  3852 text{* Courtesy of Andreas Lochbihler: *}
  3853 lemma filter_replicate:
  3854   "filter P (replicate n x) = (if P x then replicate n x else [])"
  3855 by(induct n) auto
  3856 
  3857 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"
  3858 by (induct n) auto
  3859 
  3860 lemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"
  3861 by (induct n) auto
  3862 
  3863 lemma last_replicate [simp]: "n \<noteq> 0 ==> last (replicate n x) = x"
  3864 by (atomize (full), induct n) auto
  3865 
  3866 lemma nth_replicate[simp]: "i < n ==> (replicate n x)!i = x"
  3867 apply (induct n arbitrary: i, simp)
  3868 apply (simp add: nth_Cons split: nat.split)
  3869 done
  3870 
  3871 text{* Courtesy of Matthias Daum (2 lemmas): *}
  3872 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"
  3873 apply (case_tac "k \<le> i")
  3874  apply  (simp add: min_def)
  3875 apply (drule not_leE)
  3876 apply (simp add: min_def)
  3877 apply (subgoal_tac "replicate k x = replicate i x @ replicate (k - i) x")
  3878  apply  simp
  3879 apply (simp add: replicate_add [symmetric])
  3880 done
  3881 
  3882 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"
  3883 apply (induct k arbitrary: i)
  3884  apply simp
  3885 apply clarsimp
  3886 apply (case_tac i)
  3887  apply simp
  3888 apply clarsimp
  3889 done
  3890 
  3891 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"
  3892 by (induct n) auto
  3893 
  3894 lemma set_replicate [simp]: "n \<noteq> 0 ==> set (replicate n x) = {x}"
  3895 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)
  3896 
  3897 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"
  3898 by auto
  3899 
  3900 lemma in_set_replicate[simp]: "(x : set (replicate n y)) = (x = y & n \<noteq> 0)"
  3901 by (simp add: set_replicate_conv_if)
  3902 
  3903 lemma Ball_set_replicate[simp]:
  3904   "(ALL x : set(replicate n a). P x) = (P a | n=0)"
  3905 by(simp add: set_replicate_conv_if)
  3906 
  3907 lemma Bex_set_replicate[simp]:
  3908   "(EX x : set(replicate n a). P x) = (P a & n\<noteq>0)"
  3909 by(simp add: set_replicate_conv_if)
  3910 
  3911 lemma replicate_append_same:
  3912   "replicate i x @ [x] = x # replicate i x"
  3913   by (induct i) simp_all
  3914 
  3915 lemma map_replicate_trivial:
  3916   "map (\<lambda>i. x) [0..<i] = replicate i x"
  3917   by (induct i) (simp_all add: replicate_append_same)
  3918 
  3919 lemma concat_replicate_trivial[simp]:
  3920   "concat (replicate i []) = []"
  3921   by (induct i) (auto simp add: map_replicate_const)
  3922 
  3923 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"
  3924 by (induct n) auto
  3925 
  3926 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"
  3927 by (induct n) auto
  3928 
  3929 lemma replicate_eq_replicate[simp]:
  3930   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n & (m\<noteq>0 \<longrightarrow> x=y))"
  3931 apply(induct m arbitrary: n)
  3932  apply simp
  3933 apply(induct_tac n)
  3934 apply auto
  3935 done
  3936 
  3937 lemma replicate_length_filter:
  3938   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"
  3939   by (induct xs) auto
  3940 
  3941 lemma comm_append_are_replicate:
  3942   fixes xs ys :: "'a list"
  3943   assumes "xs \<noteq> []" "ys \<noteq> []"
  3944   assumes "xs @ ys = ys @ xs"
  3945   shows "\<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"
  3946   using assms
  3947 proof (induct "length (xs @ ys)" arbitrary: xs ys rule: less_induct)
  3948   case less
  3949 
  3950   def xs' \<equiv> "if (length xs \<le> length ys) then xs else ys"
  3951     and ys' \<equiv> "if (length xs \<le> length ys) then ys else xs"
  3952   then have
  3953     prems': "length xs' \<le> length ys'"
  3954             "xs' @ ys' = ys' @ xs'"
  3955       and "xs' \<noteq> []"
  3956       and len: "length (xs @ ys) = length (xs' @ ys')"
  3957     using less by (auto intro: less.hyps)
  3958 
  3959   from prems'
  3960   obtain ws where "ys' = xs' @ ws"
  3961     by (auto simp: append_eq_append_conv2)
  3962 
  3963   have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ys'"
  3964   proof (cases "ws = []")
  3965     case True
  3966     then have "concat (replicate 1 xs') = xs'"
  3967       and "concat (replicate 1 xs') = ys'"
  3968       using `ys' = xs' @ ws` by auto
  3969     then show ?thesis by blast
  3970   next
  3971     case False
  3972     from `ys' = xs' @ ws` and `xs' @ ys' = ys' @ xs'`
  3973     have "xs' @ ws = ws @ xs'" by simp
  3974     then have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ws"
  3975       using False and `xs' \<noteq> []` and `ys' = xs' @ ws` and len
  3976       by (intro less.hyps) auto
  3977     then obtain m n zs where *: "concat (replicate m zs) = xs'"
  3978       and "concat (replicate n zs) = ws" by blast
  3979     then have "concat (replicate (m + n) zs) = ys'"
  3980       using `ys' = xs' @ ws`
  3981       by (simp add: replicate_add)
  3982     with * show ?thesis by blast
  3983   qed
  3984   then show ?case
  3985     using xs'_def ys'_def by meson
  3986 qed
  3987 
  3988 lemma comm_append_is_replicate:
  3989   fixes xs ys :: "'a list"
  3990   assumes "xs \<noteq> []" "ys \<noteq> []"
  3991   assumes "xs @ ys = ys @ xs"
  3992   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"
  3993 
  3994 proof -
  3995   obtain m n zs where "concat (replicate m zs) = xs"
  3996     and "concat (replicate n zs) = ys"
  3997     using comm_append_are_replicate[of xs ys, OF assms] by blast
  3998   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"
  3999     using `xs \<noteq> []` and `ys \<noteq> []`
  4000     by (auto simp: replicate_add)
  4001   then show ?thesis by blast
  4002 qed
  4003 
  4004 lemma Cons_replicate_eq:
  4005   "x # xs = replicate n y \<longleftrightarrow> x = y \<and> n > 0 \<and> xs = replicate (n - 1) x"
  4006   by (induct n) auto
  4007 
  4008 lemma replicate_length_same:
  4009   "(\<forall>y\<in>set xs. y = x) \<Longrightarrow> replicate (length xs) x = xs"
  4010   by (induct xs) simp_all
  4011 
  4012 lemma foldr_replicate [simp]:
  4013   "foldr f (replicate n x) = f x ^^ n"
  4014   by (induct n) (simp_all)
  4015 
  4016 lemma fold_replicate [simp]:
  4017   "fold f (replicate n x) = f x ^^ n"
  4018   by (subst foldr_fold [symmetric]) simp_all
  4019 
  4020 
  4021 subsubsection {* @{const enumerate} *}
  4022 
  4023 lemma enumerate_simps [simp, code]:
  4024   "enumerate n [] = []"
  4025   "enumerate n (x # xs) = (n, x) # enumerate (Suc n) xs"
  4026   apply (auto simp add: enumerate_eq_zip not_le)
  4027   apply (cases "n < n + length xs")
  4028   apply (auto simp add: upt_conv_Cons)
  4029   done
  4030 
  4031 lemma length_enumerate [simp]:
  4032   "length (enumerate n xs) = length xs"
  4033   by (simp add: enumerate_eq_zip)
  4034 
  4035 lemma map_fst_enumerate [simp]:
  4036   "map fst (enumerate n xs) = [n..<n + length xs]"
  4037   by (simp add: enumerate_eq_zip)
  4038 
  4039 lemma map_snd_enumerate [simp]:
  4040   "map snd (enumerate n xs) = xs"
  4041   by (simp add: enumerate_eq_zip)
  4042   
  4043 lemma in_set_enumerate_eq:
  4044   "p \<in> set (enumerate n xs) \<longleftrightarrow> n \<le> fst p \<and> fst p < length xs + n \<and> nth xs (fst p - n) = snd p"
  4045 proof -
  4046   { fix m
  4047     assume "n \<le> m"
  4048     moreover assume "m < length xs + n"
  4049     ultimately have "[n..<n + length xs] ! (m - n) = m \<and>
  4050       xs ! (m - n) = xs ! (m - n) \<and> m - n < length xs" by auto
  4051     then have "\<exists>q. [n..<n + length xs] ! q = m \<and>
  4052         xs ! q = xs ! (m - n) \<and> q < length xs" ..
  4053   } then show ?thesis by (cases p) (auto simp add: enumerate_eq_zip in_set_zip)
  4054 qed
  4055 
  4056 lemma nth_enumerate_eq:
  4057   assumes "m < length xs"
  4058   shows "enumerate n xs ! m = (n + m, xs ! m)"
  4059   using assms by (simp add: enumerate_eq_zip)
  4060 
  4061 lemma enumerate_replicate_eq:
  4062   "enumerate n (replicate m a) = map (\<lambda>q. (q, a)) [n..<n + m]"
  4063   by (rule pair_list_eqI)
  4064     (simp_all add: enumerate_eq_zip comp_def map_replicate_const)
  4065 
  4066 lemma enumerate_Suc_eq:
  4067   "enumerate (Suc n) xs = map (apfst Suc) (enumerate n xs)"
  4068   by (rule pair_list_eqI)
  4069     (simp_all add: not_le, simp del: map_map [simp del] add: map_Suc_upt map_map [symmetric])
  4070 
  4071 lemma distinct_enumerate [simp]:
  4072   "distinct (enumerate n xs)"
  4073   by (simp add: enumerate_eq_zip distinct_zipI1)
  4074 
  4075 
  4076 subsubsection {* @{const rotate1} and @{const rotate} *}
  4077 
  4078 lemma rotate0[simp]: "rotate 0 = id"
  4079 by(simp add:rotate_def)
  4080 
  4081 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"
  4082 by(simp add:rotate_def)
  4083 
  4084 lemma rotate_add:
  4085   "rotate (m+n) = rotate m o rotate n"
  4086 by(simp add:rotate_def funpow_add)
  4087 
  4088 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"
  4089 by(simp add:rotate_add)
  4090 
  4091 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"
  4092 by(simp add:rotate_def funpow_swap1)
  4093 
  4094 lemma rotate1_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate1 xs = xs"
  4095 by(cases xs) simp_all
  4096 
  4097 lemma rotate_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate n xs = xs"
  4098 apply(induct n)
  4099  apply simp
  4100 apply (simp add:rotate_def)
  4101 done
  4102 
  4103 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"
  4104 by (cases xs) simp_all
  4105 
  4106 lemma rotate_drop_take:
  4107   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"
  4108 apply(induct n)
  4109  apply simp
  4110 apply(simp add:rotate_def)
  4111 apply(cases "xs = []")
  4112  apply (simp)
  4113 apply(case_tac "n mod length xs = 0")
  4114  apply(simp add:mod_Suc)
  4115  apply(simp add: rotate1_hd_tl drop_Suc take_Suc)
  4116 apply(simp add:mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]
  4117                 take_hd_drop linorder_not_le)
  4118 done
  4119 
  4120 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"
  4121 by(simp add:rotate_drop_take)
  4122 
  4123 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"
  4124 by(simp add:rotate_drop_take)
  4125 
  4126 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"
  4127 by (cases xs) simp_all
  4128 
  4129 lemma length_rotate[simp]: "length(rotate n xs) = length xs"
  4130 by (induct n arbitrary: xs) (simp_all add:rotate_def)
  4131 
  4132 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"
  4133 by (cases xs) auto
  4134 
  4135 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"
  4136 by (induct n) (simp_all add:rotate_def)
  4137 
  4138 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"
  4139 by(simp add:rotate_drop_take take_map drop_map)
  4140 
  4141 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"
  4142 by (cases xs) auto
  4143 
  4144 lemma set_rotate[simp]: "set(rotate n xs) = set xs"
  4145 by (induct n) (simp_all add:rotate_def)
  4146 
  4147 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"
  4148 by (cases xs) auto
  4149 
  4150 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"
  4151 by (induct n) (simp_all add:rotate_def)
  4152 
  4153 lemma rotate_rev:
  4154   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"
  4155 apply(simp add:rotate_drop_take rev_drop rev_take)
  4156 apply(cases "length xs = 0")
  4157  apply simp
  4158 apply(cases "n mod length xs = 0")
  4159  apply simp
  4160 apply(simp add:rotate_drop_take rev_drop rev_take)
  4161 done
  4162 
  4163 lemma hd_rotate_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd(rotate n xs) = xs!(n mod length xs)"
  4164 apply(simp add:rotate_drop_take hd_append hd_drop_conv_nth hd_conv_nth)
  4165 apply(subgoal_tac "length xs \<noteq> 0")
  4166  prefer 2 apply simp
  4167 using mod_less_divisor[of "length xs" n] by arith
  4168 
  4169 
  4170 subsubsection {* @{const sublist} --- a generalization of @{const nth} to sets *}
  4171 
  4172 lemma sublist_empty [simp]: "sublist xs {} = []"
  4173 by (auto simp add: sublist_def)
  4174 
  4175 lemma sublist_nil [simp]: "sublist [] A = []"
  4176 by (auto simp add: sublist_def)
  4177 
  4178 lemma length_sublist:
  4179   "length(sublist xs I) = card{i. i < length xs \<and> i : I}"
  4180 by(simp add: sublist_def length_filter_conv_card cong:conj_cong)
  4181 
  4182 lemma sublist_shift_lemma_Suc:
  4183   "map fst (filter (%p. P(Suc(snd p))) (zip xs is)) =
  4184    map fst (filter (%p. P(snd p)) (zip xs (map Suc is)))"
  4185 apply(induct xs arbitrary: "is")
  4186  apply simp
  4187 apply (case_tac "is")
  4188  apply simp
  4189 apply simp
  4190 done
  4191 
  4192 lemma sublist_shift_lemma:
  4193      "map fst [p<-zip xs [i..<i + length xs] . snd p : A] =
  4194       map fst [p<-zip xs [0..<length xs] . snd p + i : A]"
  4195 by (induct xs rule: rev_induct) (simp_all add: add_commute)
  4196 
  4197 lemma sublist_append:
  4198      "sublist (l @ l') A = sublist l A @ sublist l' {j. j + length l : A}"
  4199 apply (unfold sublist_def)
  4200 apply (induct l' rule: rev_induct, simp)
  4201 apply (simp add: upt_add_eq_append[of 0] sublist_shift_lemma)
  4202 apply (simp add: add_commute)
  4203 done
  4204 
  4205 lemma sublist_Cons:
  4206 "sublist (x # l) A = (if 0:A then [x] else []) @ sublist l {j. Suc j : A}"
  4207 apply (induct l rule: rev_induct)
  4208  apply (simp add: sublist_def)
  4209 apply (simp del: append_Cons add: append_Cons[symmetric] sublist_append)
  4210 done
  4211 
  4212 lemma set_sublist: "set(sublist xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"
  4213 apply(induct xs arbitrary: I)
  4214 apply(auto simp: sublist_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)
  4215 done
  4216 
  4217 lemma set_sublist_subset: "set(sublist xs I) \<subseteq> set xs"
  4218 by(auto simp add:set_sublist)
  4219 
  4220 lemma notin_set_sublistI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(sublist xs I)"
  4221 by(auto simp add:set_sublist)
  4222 
  4223 lemma in_set_sublistD: "x \<in> set(sublist xs I) \<Longrightarrow> x \<in> set xs"
  4224 by(auto simp add:set_sublist)
  4225 
  4226 lemma sublist_singleton [simp]: "sublist [x] A = (if 0 : A then [x] else [])"
  4227 by (simp add: sublist_Cons)
  4228 
  4229 
  4230 lemma distinct_sublistI[simp]: "distinct xs \<Longrightarrow> distinct(sublist xs I)"
  4231 apply(induct xs arbitrary: I)
  4232  apply simp
  4233 apply(auto simp add:sublist_Cons)
  4234 done
  4235 
  4236 
  4237 lemma sublist_upt_eq_take [simp]: "sublist l {..<n} = take n l"
  4238 apply (induct l rule: rev_induct, simp)
  4239 apply (simp split: nat_diff_split add: sublist_append)
  4240 done
  4241 
  4242 lemma filter_in_sublist:
  4243  "distinct xs \<Longrightarrow> filter (%x. x \<in> set(sublist xs s)) xs = sublist xs s"
  4244 proof (induct xs arbitrary: s)
  4245   case Nil thus ?case by simp
  4246 next
  4247   case (Cons a xs)
  4248   then have "!x. x: set xs \<longrightarrow> x \<noteq> a" by auto
  4249   with Cons show ?case by(simp add: sublist_Cons cong:filter_cong)
  4250 qed
  4251 
  4252 
  4253 subsubsection {* @{const sublists} and @{const List.n_lists} *}
  4254 
  4255 lemma length_sublists:
  4256   "length (sublists xs) = 2 ^ length xs"
  4257   by (induct xs) (simp_all add: Let_def)
  4258 
  4259 lemma sublists_powset:
  4260   "set ` set (sublists xs) = Pow (set xs)"
  4261 proof -
  4262   have aux: "\<And>x A. set ` Cons x ` A = insert x ` set ` A"
  4263     by (auto simp add: image_def)
  4264   have "set (map set (sublists xs)) = Pow (set xs)"
  4265     by (induct xs)
  4266       (simp_all add: aux Let_def Pow_insert Un_commute comp_def del: map_map)
  4267   then show ?thesis by simp
  4268 qed
  4269 
  4270 lemma distinct_set_sublists:
  4271   assumes "distinct xs"
  4272   shows "distinct (map set (sublists xs))"
  4273 proof (rule card_distinct)
  4274   have "finite (set xs)" by rule
  4275   then have "card (Pow (set xs)) = 2 ^ card (set xs)" by (rule card_Pow)
  4276   with assms distinct_card [of xs]
  4277     have "card (Pow (set xs)) = 2 ^ length xs" by simp
  4278   then show "card (set (map set (sublists xs))) = length (map set (sublists xs))"
  4279     by (simp add: sublists_powset length_sublists)
  4280 qed
  4281 
  4282 lemma n_lists_Nil [simp]: "List.n_lists n [] = (if n = 0 then [[]] else [])"
  4283   by (induct n) simp_all
  4284 
  4285 lemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n"
  4286   by (induct n) (auto simp add: length_concat o_def listsum_triv)
  4287 
  4288 lemma length_n_lists_elem: "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
  4289   by (induct n arbitrary: ys) auto
  4290 
  4291 lemma set_n_lists: "set (List.n_lists n xs) = {ys. length ys = n \<and> set ys \<subseteq> set xs}"
  4292 proof (rule set_eqI)
  4293   fix ys :: "'a list"
  4294   show "ys \<in> set (List.n_lists n xs) \<longleftrightarrow> ys \<in> {ys. length ys = n \<and> set ys \<subseteq> set xs}"
  4295   proof -
  4296     have "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
  4297       by (induct n arbitrary: ys) auto
  4298     moreover have "\<And>x. ys \<in> set (List.n_lists n xs) \<Longrightarrow> x \<in> set ys \<Longrightarrow> x \<in> set xs"
  4299       by (induct n arbitrary: ys) auto
  4300     moreover have "set ys \<subseteq> set xs \<Longrightarrow> ys \<in> set (List.n_lists (length ys) xs)"
  4301       by (induct ys) auto
  4302     ultimately show ?thesis by auto
  4303   qed
  4304 qed
  4305 
  4306 lemma distinct_n_lists:
  4307   assumes "distinct xs"
  4308   shows "distinct (List.n_lists n xs)"
  4309 proof (rule card_distinct)
  4310   from assms have card_length: "card (set xs) = length xs" by (rule distinct_card)
  4311   have "card (set (List.n_lists n xs)) = card (set xs) ^ n"
  4312   proof (induct n)
  4313     case 0 then show ?case by simp
  4314   next
  4315     case (Suc n)
  4316     moreover have "card (\<Union>ys\<in>set (List.n_lists n xs). (\<lambda>y. y # ys) ` set xs)
  4317       = (\<Sum>ys\<in>set (List.n_lists n xs). card ((\<lambda>y. y # ys) ` set xs))"
  4318       by (rule card_UN_disjoint) auto
  4319     moreover have "\<And>ys. card ((\<lambda>y. y # ys) ` set xs) = card (set xs)"
  4320       by (rule card_image) (simp add: inj_on_def)
  4321     ultimately show ?case by auto
  4322   qed
  4323   also have "\<dots> = length xs ^ n" by (simp add: card_length)
  4324   finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)"
  4325     by (simp add: length_n_lists)
  4326 qed
  4327 
  4328 
  4329 subsubsection {* @{const splice} *}
  4330 
  4331 lemma splice_Nil2 [simp, code]: "splice xs [] = xs"
  4332 by (cases xs) simp_all
  4333 
  4334 declare splice.simps(1,3)[code]
  4335 declare splice.simps(2)[simp del]
  4336 
  4337 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"
  4338 by (induct xs ys rule: splice.induct) auto
  4339 
  4340 
  4341 subsubsection {* Transpose *}
  4342 
  4343 function transpose where
  4344 "transpose []             = []" |
  4345 "transpose ([]     # xss) = transpose xss" |
  4346 "transpose ((x#xs) # xss) =
  4347   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"
  4348 by pat_completeness auto
  4349 
  4350 lemma transpose_aux_filter_head:
  4351   "concat (map (case_list [] (\<lambda>h t. [h])) xss) =
  4352   map (\<lambda>xs. hd xs) [ys\<leftarrow>xss . ys \<noteq> []]"
  4353   by (induct xss) (auto split: list.split)
  4354 
  4355 lemma transpose_aux_filter_tail:
  4356   "concat (map (case_list [] (\<lambda>h t. [t])) xss) =
  4357   map (\<lambda>xs. tl xs) [ys\<leftarrow>xss . ys \<noteq> []]"
  4358   by (induct xss) (auto split: list.split)
  4359 
  4360 lemma transpose_aux_max:
  4361   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =
  4362   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) [ys\<leftarrow>xss . ys\<noteq>[]] 0))"
  4363   (is "max _ ?foldB = Suc (max _ ?foldA)")
  4364 proof (cases "[ys\<leftarrow>xss . ys\<noteq>[]] = []")
  4365   case True
  4366   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"
  4367   proof (induct xss)
  4368     case (Cons x xs)
  4369     then have "x = []" by (cases x) auto
  4370     with Cons show ?case by auto
  4371   qed simp
  4372   thus ?thesis using True by simp
  4373 next
  4374   case False
  4375 
  4376   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0 - 1"
  4377     by (induct xss) auto
  4378   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0"
  4379     by (induct xss) auto
  4380 
  4381   have "0 < ?foldB"
  4382   proof -
  4383     from False
  4384     obtain z zs where zs: "[ys\<leftarrow>xss . ys \<noteq> []] = z#zs" by (auto simp: neq_Nil_conv)
  4385     hence "z \<in> set ([ys\<leftarrow>xss . ys \<noteq> []])" by auto
  4386     hence "z \<noteq> []" by auto
  4387     thus ?thesis
  4388       unfolding foldB zs
  4389       by (auto simp: max_def intro: less_le_trans)
  4390   qed
  4391   thus ?thesis
  4392     unfolding foldA foldB max_Suc_Suc[symmetric]
  4393     by simp
  4394 qed
  4395 
  4396 termination transpose
  4397   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")
  4398      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)
  4399 
  4400 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"
  4401   by (induct rule: transpose.induct) simp_all
  4402 
  4403 lemma length_transpose:
  4404   fixes xs :: "'a list list"
  4405   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"
  4406   by (induct rule: transpose.induct)
  4407     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max
  4408                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)
  4409 
  4410 lemma nth_transpose:
  4411   fixes xs :: "'a list list"
  4412   assumes "i < length (transpose xs)"
  4413   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) [ys \<leftarrow> xs. i < length ys]"
  4414 using assms proof (induct arbitrary: i rule: transpose.induct)
  4415   case (3 x xs xss)
  4416   def XS == "(x # xs) # xss"
  4417   hence [simp]: "XS \<noteq> []" by auto
  4418   thus ?case
  4419   proof (cases i)
  4420     case 0
  4421     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)
  4422   next
  4423     case (Suc j)
  4424     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp
  4425     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp
  4426     { fix x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"
  4427       by (cases x) simp_all
  4428     } note *** = this
  4429 
  4430     have j_less: "j < length (transpose (xs # concat (map (case_list [] (\<lambda>h t. [t])) xss)))"
  4431       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)
  4432 
  4433     show ?thesis
  4434       unfolding transpose.simps `i = Suc j` nth_Cons_Suc "3.hyps"[OF j_less]
  4435       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])
  4436       apply (rule list.exhaust)
  4437       by auto
  4438   qed
  4439 qed simp_all
  4440 
  4441 lemma transpose_map_map:
  4442   "transpose (map (map f) xs) = map (map f) (transpose xs)"
  4443 proof (rule nth_equalityI, safe)
  4444   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"
  4445     by (simp add: length_transpose foldr_map comp_def)
  4446   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp
  4447 
  4448   fix i assume "i < length (transpose (map (map f) xs))"
  4449   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"
  4450     by (simp add: nth_transpose filter_map comp_def)
  4451 qed
  4452 
  4453 
  4454 subsubsection {* (In)finiteness *}
  4455 
  4456 lemma finite_maxlen:
  4457   "finite (M::'a list set) ==> EX n. ALL s:M. size s < n"
  4458 proof (induct rule: finite.induct)
  4459   case emptyI show ?case by simp
  4460 next
  4461   case (insertI M xs)
  4462   then obtain n where "\<forall>s\<in>M. length s < n" by blast
  4463   hence "ALL s:insert xs M. size s < max n (size xs) + 1" by auto
  4464   thus ?case ..
  4465 qed
  4466 
  4467 lemma lists_length_Suc_eq:
  4468   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =
  4469     (\<lambda>(xs, n). n#xs) ` ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"
  4470   by (auto simp: length_Suc_conv)
  4471 
  4472 lemma
  4473   assumes "finite A"
  4474   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
  4475   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"
  4476   using `finite A`
  4477   by (induct n)
  4478      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)
  4479 
  4480 lemma finite_lists_length_le:
  4481   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
  4482  (is "finite ?S")
  4483 proof-
  4484   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto
  4485   thus ?thesis by (auto intro!: finite_lists_length_eq[OF `finite A`] simp only:)
  4486 qed
  4487 
  4488 lemma card_lists_length_le:
  4489   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"
  4490 proof -
  4491   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"
  4492     using `finite A`
  4493     by (subst card_UN_disjoint)
  4494        (auto simp add: card_lists_length_eq finite_lists_length_eq)
  4495   also have "(\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i}) = {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
  4496     by auto
  4497   finally show ?thesis by simp
  4498 qed
  4499 
  4500 lemma card_lists_distinct_length_eq:
  4501   assumes "k < card A"
  4502   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"
  4503 using assms
  4504 proof (induct k)
  4505   case 0
  4506   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto
  4507   then show ?case by simp
  4508 next
  4509   case (Suc k)
  4510   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"
  4511   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto
  4512 
  4513   from Suc have "k < card A" by simp
  4514   moreover have "finite A" using assms by (simp add: card_ge_0_finite)
  4515   moreover have "finite {xs. ?k_list k xs}"
  4516     using finite_lists_length_eq[OF `finite A`, of k]
  4517     by - (rule finite_subset, auto)
  4518   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"
  4519     by auto
  4520   moreover have "\<And>i. i \<in>Collect (?k_list k) \<Longrightarrow> card (A - set i) = card A - k"
  4521     by (simp add: card_Diff_subset distinct_card)
  4522   moreover have "{xs. ?k_list (Suc k) xs} =
  4523       (\<lambda>(xs, n). n#xs) ` \<Union>((\<lambda>xs. {xs} \<times> (A - set xs)) ` {xs. ?k_list k xs})"
  4524     by (auto simp: length_Suc_conv)
  4525   moreover
  4526   have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp
  4527   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"
  4528     by (subst setprod_insert[symmetric]) (simp add: atLeastAtMost_insertL)+
  4529   ultimately show ?case
  4530     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)
  4531 qed
  4532 
  4533 lemma infinite_UNIV_listI: "~ finite(UNIV::'a list set)"
  4534 apply (rule notI)
  4535 apply (drule finite_maxlen)
  4536 apply clarsimp
  4537 apply (erule_tac x = "replicate n undefined" in allE)
  4538 by simp
  4539 
  4540 
  4541 subsection {* Sorting *}
  4542 
  4543 text{* Currently it is not shown that @{const sort} returns a
  4544 permutation of its input because the nicest proof is via multisets,
  4545 which are not yet available. Alternatively one could define a function
  4546 that counts the number of occurrences of an element in a list and use
  4547 that instead of multisets to state the correctness property. *}
  4548 
  4549 context linorder
  4550 begin
  4551 
  4552 lemma set_insort_key:
  4553   "set (insort_key f x xs) = insert x (set xs)"
  4554   by (induct xs) auto
  4555 
  4556 lemma length_insort [simp]:
  4557   "length (insort_key f x xs) = Suc (length xs)"
  4558   by (induct xs) simp_all
  4559 
  4560 lemma insort_key_left_comm:
  4561   assumes "f x \<noteq> f y"
  4562   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"
  4563   by (induct xs) (auto simp add: assms dest: antisym)
  4564 
  4565 lemma insort_left_comm:
  4566   "insort x (insort y xs) = insort y (insort x xs)"
  4567   by (cases "x = y") (auto intro: insort_key_left_comm)
  4568 
  4569 lemma comp_fun_commute_insort:
  4570   "comp_fun_commute insort"
  4571 proof
  4572 qed (simp add: insort_left_comm fun_eq_iff)
  4573 
  4574 lemma sort_key_simps [simp]:
  4575   "sort_key f [] = []"
  4576   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"
  4577   by (simp_all add: sort_key_def)
  4578 
  4579 lemma (in linorder) sort_key_conv_fold:
  4580   assumes "inj_on f (set xs)"
  4581   shows "sort_key f xs = fold (insort_key f) xs []"
  4582 proof -
  4583   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
  4584   proof (rule fold_rev, rule ext)
  4585     fix zs
  4586     fix x y
  4587     assume "x \<in> set xs" "y \<in> set xs"
  4588     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
  4589     have **: "x = y \<longleftrightarrow> y = x" by auto
  4590     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
  4591       by (induct zs) (auto intro: * simp add: **)
  4592   qed
  4593   then show ?thesis by (simp add: sort_key_def foldr_conv_fold)
  4594 qed
  4595 
  4596 lemma (in linorder) sort_conv_fold:
  4597   "sort xs = fold insort xs []"
  4598   by (rule sort_key_conv_fold) simp
  4599 
  4600 lemma length_sort[simp]: "length (sort_key f xs) = length xs"
  4601 by (induct xs, auto)
  4602 
  4603 lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"
  4604 apply(induct xs arbitrary: x) apply simp
  4605 by simp (blast intro: order_trans)
  4606 
  4607 lemma sorted_tl:
  4608   "sorted xs \<Longrightarrow> sorted (tl xs)"
  4609   by (cases xs) (simp_all add: sorted_Cons)
  4610 
  4611 lemma sorted_append:
  4612   "sorted (xs@ys) = (sorted xs & sorted ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"
  4613 by (induct xs) (auto simp add:sorted_Cons)
  4614 
  4615 lemma sorted_nth_mono:
  4616   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"
  4617 by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)
  4618 
  4619 lemma sorted_rev_nth_mono:
  4620   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"
  4621 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]
  4622       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]
  4623 by auto
  4624 
  4625 lemma sorted_nth_monoI:
  4626   "(\<And> i j. \<lbrakk> i \<le> j ; j < length xs \<rbrakk> \<Longrightarrow> xs ! i \<le> xs ! j) \<Longrightarrow> sorted xs"
  4627 proof (induct xs)
  4628   case (Cons x xs)
  4629   have "sorted xs"
  4630   proof (rule Cons.hyps)
  4631     fix i j assume "i \<le> j" and "j < length xs"
  4632     with Cons.prems[of "Suc i" "Suc j"]
  4633     show "xs ! i \<le> xs ! j" by auto
  4634   qed
  4635   moreover
  4636   {
  4637     fix y assume "y \<in> set xs"
  4638     then obtain j where "j < length xs" and "xs ! j = y"
  4639       unfolding in_set_conv_nth by blast
  4640     with Cons.prems[of 0 "Suc j"]
  4641     have "x \<le> y"
  4642       by auto
  4643   }
  4644   ultimately
  4645   show ?case
  4646     unfolding sorted_Cons by auto
  4647 qed simp
  4648 
  4649 lemma sorted_equals_nth_mono:
  4650   "sorted xs = (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"
  4651 by (auto intro: sorted_nth_monoI sorted_nth_mono)
  4652 
  4653 lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"
  4654 by (induct xs) auto
  4655 
  4656 lemma set_sort[simp]: "set(sort_key f xs) = set xs"
  4657 by (induct xs) (simp_all add:set_insort)
  4658 
  4659 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"
  4660 by(induct xs)(auto simp:set_insort)
  4661 
  4662 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"
  4663   by (induct xs) (simp_all add: distinct_insort)
  4664 
  4665 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"
  4666   by (induct xs) (auto simp:sorted_Cons set_insort)
  4667 
  4668 lemma sorted_insort: "sorted (insort x xs) = sorted xs"
  4669   using sorted_insort_key [where f="\<lambda>x. x"] by simp
  4670 
  4671 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"
  4672   by (induct xs) (auto simp:sorted_insort_key)
  4673 
  4674 theorem sorted_sort [simp]: "sorted (sort xs)"
  4675   using sorted_sort_key [where f="\<lambda>x. x"] by simp
  4676 
  4677 lemma sorted_butlast:
  4678   assumes "xs \<noteq> []" and "sorted xs"
  4679   shows "sorted (butlast xs)"
  4680 proof -
  4681   from `xs \<noteq> []` obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
  4682   with `sorted xs` show ?thesis by (simp add: sorted_append)
  4683 qed
  4684   
  4685 lemma insort_not_Nil [simp]:
  4686   "insort_key f a xs \<noteq> []"
  4687   by (induct xs) simp_all
  4688 
  4689 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
  4690 by (cases xs) auto
  4691 
  4692 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"
  4693   by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)
  4694 
  4695 lemma sorted_map_remove1:
  4696   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"
  4697   by (induct xs) (auto simp add: sorted_Cons)
  4698 
  4699 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"
  4700   using sorted_map_remove1 [of "\<lambda>x. x"] by simp
  4701 
  4702 lemma insort_key_remove1:
  4703   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"
  4704   shows "insort_key f a (remove1 a xs) = xs"
  4705 using assms proof (induct xs)
  4706   case (Cons x xs)
  4707   then show ?case
  4708   proof (cases "x = a")
  4709     case False
  4710     then have "f x \<noteq> f a" using Cons.prems by auto
  4711     then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons)
  4712     with `f x \<noteq> f a` show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons)
  4713   qed (auto simp: sorted_Cons insort_is_Cons)
  4714 qed simp
  4715 
  4716 lemma insort_remove1:
  4717   assumes "a \<in> set xs" and "sorted xs"
  4718   shows "insort a (remove1 a xs) = xs"
  4719 proof (rule insort_key_remove1)
  4720   from `a \<in> set xs` show "a \<in> set xs" .
  4721   from `sorted xs` show "sorted (map (\<lambda>x. x) xs)" by simp
  4722   from `a \<in> set xs` have "a \<in> set (filter (op = a) xs)" by auto
  4723   then have "set (filter (op = a) xs) \<noteq> {}" by auto
  4724   then have "filter (op = a) xs \<noteq> []" by (auto simp only: set_empty)
  4725   then have "length (filter (op = a) xs) > 0" by simp
  4726   then obtain n where n: "Suc n = length (filter (op = a) xs)"
  4727     by (cases "length (filter (op = a) xs)") simp_all
  4728   moreover have "replicate (Suc n) a = a # replicate n a"
  4729     by simp
  4730   ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)
  4731 qed
  4732 
  4733 lemma sorted_remdups[simp]:
  4734   "sorted l \<Longrightarrow> sorted (remdups l)"
  4735 by (induct l) (auto simp: sorted_Cons)
  4736 
  4737 lemma sorted_remdups_adj[simp]:
  4738   "sorted xs \<Longrightarrow> sorted (remdups_adj xs)"
  4739 by (induct xs rule: remdups_adj.induct, simp_all split: split_if_asm add: sorted_Cons)
  4740 
  4741 lemma sorted_distinct_set_unique:
  4742 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"
  4743 shows "xs = ys"
  4744 proof -
  4745   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  4746   from assms show ?thesis
  4747   proof(induct rule:list_induct2[OF 1])
  4748     case 1 show ?case by simp
  4749   next
  4750     case 2 thus ?case by (simp add: sorted_Cons)
  4751        (metis Diff_insert_absorb antisym insertE insert_iff)
  4752   qed
  4753 qed
  4754 
  4755 lemma map_sorted_distinct_set_unique:
  4756   assumes "inj_on f (set xs \<union> set ys)"
  4757   assumes "sorted (map f xs)" "distinct (map f xs)"
  4758     "sorted (map f ys)" "distinct (map f ys)"
  4759   assumes "set xs = set ys"
  4760   shows "xs = ys"
  4761 proof -
  4762   from assms have "map f xs = map f ys"
  4763     by (simp add: sorted_distinct_set_unique)
  4764   with `inj_on f (set xs \<union> set ys)` show "xs = ys"
  4765     by (blast intro: map_inj_on)
  4766 qed
  4767 
  4768 lemma finite_sorted_distinct_unique:
  4769 shows "finite A \<Longrightarrow> EX! xs. set xs = A & sorted xs & distinct xs"
  4770 apply(drule finite_distinct_list)
  4771 apply clarify
  4772 apply(rule_tac a="sort xs" in ex1I)
  4773 apply (auto simp: sorted_distinct_set_unique)
  4774 done
  4775 
  4776 lemma
  4777   assumes "sorted xs"
  4778   shows sorted_take: "sorted (take n xs)"
  4779   and sorted_drop: "sorted (drop n xs)"
  4780 proof -
  4781   from assms have "sorted (take n xs @ drop n xs)" by simp
  4782   then show "sorted (take n xs)" and "sorted (drop n xs)"
  4783     unfolding sorted_append by simp_all
  4784 qed
  4785 
  4786 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"
  4787   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)
  4788 
  4789 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"
  4790   by (subst takeWhile_eq_take) (auto dest: sorted_take)
  4791 
  4792 lemma sorted_filter:
  4793   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"
  4794   by (induct xs) (simp_all add: sorted_Cons)
  4795 
  4796 lemma foldr_max_sorted:
  4797   assumes "sorted (rev xs)"
  4798   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"
  4799   using assms
  4800 proof (induct xs)
  4801   case (Cons x xs)
  4802   then have "sorted (rev xs)" using sorted_append by auto
  4803   with Cons show ?case
  4804     by (cases xs) (auto simp add: sorted_append max_def)
  4805 qed simp
  4806 
  4807 lemma filter_equals_takeWhile_sorted_rev:
  4808   assumes sorted: "sorted (rev (map f xs))"
  4809   shows "[x \<leftarrow> xs. t < f x] = takeWhile (\<lambda> x. t < f x) xs"
  4810     (is "filter ?P xs = ?tW")
  4811 proof (rule takeWhile_eq_filter[symmetric])
  4812   let "?dW" = "dropWhile ?P xs"
  4813   fix x assume "x \<in> set ?dW"
  4814   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"
  4815     unfolding in_set_conv_nth by auto
  4816   hence "length ?tW + i < length (?tW @ ?dW)"
  4817     unfolding length_append by simp
  4818   hence i': "length (map f ?tW) + i < length (map f xs)" by simp
  4819   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>
  4820         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"
  4821     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]
  4822     unfolding map_append[symmetric] by simp
  4823   hence "f x \<le> f (?dW ! 0)"
  4824     unfolding nth_append_length_plus nth_i
  4825     using i preorder_class.le_less_trans[OF le0 i] by simp
  4826   also have "... \<le> t"
  4827     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]
  4828     using hd_conv_nth[of "?dW"] by simp
  4829   finally show "\<not> t < f x" by simp
  4830 qed
  4831 
  4832 lemma insort_insert_key_triv:
  4833   "f x \<in> f ` set xs \<Longrightarrow> insort_insert_key f x xs = xs"
  4834   by (simp add: insort_insert_key_def)
  4835 
  4836 lemma insort_insert_triv:
  4837   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"
  4838   using insort_insert_key_triv [of "\<lambda>x. x"] by simp
  4839 
  4840 lemma insort_insert_insort_key:
  4841   "f x \<notin> f ` set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"
  4842   by (simp add: insort_insert_key_def)
  4843 
  4844 lemma insort_insert_insort:
  4845   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"
  4846   using insort_insert_insort_key [of "\<lambda>x. x"] by simp
  4847 
  4848 lemma set_insort_insert:
  4849   "set (insort_insert x xs) = insert x (set xs)"
  4850   by (auto simp add: insort_insert_key_def set_insort)
  4851 
  4852 lemma distinct_insort_insert:
  4853   assumes "distinct xs"
  4854   shows "distinct (insort_insert_key f x xs)"
  4855   using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)
  4856 
  4857 lemma sorted_insort_insert_key:
  4858   assumes "sorted (map f xs)"
  4859   shows "sorted (map f (insort_insert_key f x xs))"
  4860   using assms by (simp add: insort_insert_key_def sorted_insort_key)
  4861 
  4862 lemma sorted_insort_insert:
  4863   assumes "sorted xs"
  4864   shows "sorted (insort_insert x xs)"
  4865   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp
  4866 
  4867 lemma filter_insort_triv:
  4868   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
  4869   by (induct xs) simp_all
  4870 
  4871 lemma filter_insort:
  4872   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
  4873   using assms by (induct xs)
  4874     (auto simp add: sorted_Cons, subst insort_is_Cons, auto)
  4875 
  4876 lemma filter_sort:
  4877   "filter P (sort_key f xs) = sort_key f (filter P xs)"
  4878   by (induct xs) (simp_all add: filter_insort_triv filter_insort)
  4879 
  4880 lemma sorted_map_same:
  4881   "sorted (map f [x\<leftarrow>xs. f x = g xs])"
  4882 proof (induct xs arbitrary: g)
  4883   case Nil then show ?case by simp
  4884 next
  4885   case (Cons x xs)
  4886   then have "sorted (map f [y\<leftarrow>xs . f y = (\<lambda>xs. f x) xs])" .
  4887   moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g \<circ> Cons x) xs])" .
  4888   ultimately show ?case by (simp_all add: sorted_Cons)
  4889 qed
  4890 
  4891 lemma sorted_same:
  4892   "sorted [x\<leftarrow>xs. x = g xs]"
  4893   using sorted_map_same [of "\<lambda>x. x"] by simp
  4894 
  4895 lemma remove1_insort [simp]:
  4896   "remove1 x (insort x xs) = xs"
  4897   by (induct xs) simp_all
  4898 
  4899 end
  4900 
  4901 lemma sorted_upt[simp]: "sorted[i..<j]"
  4902 by (induct j) (simp_all add:sorted_append)
  4903 
  4904 lemma sorted_upto[simp]: "sorted[i..j]"
  4905 apply(induct i j rule:upto.induct)
  4906 apply(subst upto.simps)
  4907 apply(simp add:sorted_Cons)
  4908 done
  4909 
  4910 lemma sorted_find_Min:
  4911   assumes "sorted xs"
  4912   assumes "\<exists>x \<in> set xs. P x"
  4913   shows "List.find P xs = Some (Min {x\<in>set xs. P x})"
  4914 using assms proof (induct xs rule: sorted.induct)
  4915   case Nil then show ?case by simp
  4916 next
  4917   case (Cons xs x) show ?case proof (cases "P x")
  4918     case True with Cons show ?thesis by (auto intro: Min_eqI [symmetric])
  4919   next
  4920     case False then have "{y. (y = x \<or> y \<in> set xs) \<and> P y} = {y \<in> set xs. P y}"
  4921       by auto
  4922     with Cons False show ?thesis by simp_all
  4923   qed
  4924 qed
  4925 
  4926 
  4927 subsubsection {* @{const transpose} on sorted lists *}
  4928 
  4929 lemma sorted_transpose[simp]:
  4930   shows "sorted (rev (map length (transpose xs)))"
  4931   by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose
  4932     length_filter_conv_card intro: card_mono)
  4933 
  4934 lemma transpose_max_length:
  4935   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x \<noteq> []]"
  4936   (is "?L = ?R")
  4937 proof (cases "transpose xs = []")
  4938   case False
  4939   have "?L = foldr max (map length (transpose xs)) 0"
  4940     by (simp add: foldr_map comp_def)
  4941   also have "... = length (transpose xs ! 0)"
  4942     using False sorted_transpose by (simp add: foldr_max_sorted)
  4943   finally show ?thesis
  4944     using False by (simp add: nth_transpose)
  4945 next
  4946   case True
  4947   hence "[x \<leftarrow> xs. x \<noteq> []] = []"
  4948     by (auto intro!: filter_False simp: transpose_empty)
  4949   thus ?thesis by (simp add: transpose_empty True)
  4950 qed
  4951 
  4952 lemma length_transpose_sorted:
  4953   fixes xs :: "'a list list"
  4954   assumes sorted: "sorted (rev (map length xs))"
  4955   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"
  4956 proof (cases "xs = []")
  4957   case False
  4958   thus ?thesis
  4959     using foldr_max_sorted[OF sorted] False
  4960     unfolding length_transpose foldr_map comp_def
  4961     by simp
  4962 qed simp
  4963 
  4964 lemma nth_nth_transpose_sorted[simp]:
  4965   fixes xs :: "'a list list"
  4966   assumes sorted: "sorted (rev (map length xs))"
  4967   and i: "i < length (transpose xs)"
  4968   and j: "j < length [ys \<leftarrow> xs. i < length ys]"
  4969   shows "transpose xs ! i ! j = xs ! j  ! i"
  4970   using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]
  4971     nth_transpose[OF i] nth_map[OF j]
  4972   by (simp add: takeWhile_nth)
  4973 
  4974 lemma transpose_column_length:
  4975   fixes xs :: "'a list list"
  4976   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
  4977   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"
  4978 proof -
  4979   have "xs \<noteq> []" using `i < length xs` by auto
  4980   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]
  4981   { fix j assume "j \<le> i"
  4982     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this `i < length xs`]
  4983   } note sortedE = this[consumes 1]
  4984 
  4985   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}
  4986     = {..< length (xs ! i)}"
  4987   proof safe
  4988     fix j
  4989     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"
  4990     with this(2) nth_transpose[OF this(1)]
  4991     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp
  4992     from nth_mem[OF this] takeWhile_nth[OF this]
  4993     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)
  4994   next
  4995     fix j assume "j < length (xs ! i)"
  4996     thus "j < length (transpose xs)"
  4997       using foldr_max_sorted[OF sorted] `xs \<noteq> []` sortedE[OF le0]
  4998       by (auto simp: length_transpose comp_def foldr_map)
  4999 
  5000     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"
  5001       using `i < length xs` `j < length (xs ! i)` less_Suc_eq_le
  5002       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)
  5003     with nth_transpose[OF `j < length (transpose xs)`]
  5004     show "i < length (transpose xs ! j)" by simp
  5005   qed
  5006   thus ?thesis by (simp add: length_filter_conv_card)
  5007 qed
  5008 
  5009 lemma transpose_column:
  5010   fixes xs :: "'a list list"
  5011   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
  5012   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))
  5013     = xs ! i" (is "?R = _")
  5014 proof (rule nth_equalityI, safe)
  5015   show length: "length ?R = length (xs ! i)"
  5016     using transpose_column_length[OF assms] by simp
  5017 
  5018   fix j assume j: "j < length ?R"
  5019   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]
  5020   from j have j_less: "j < length (xs ! i)" using length by simp
  5021   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"
  5022   proof (rule length_takeWhile_less_P_nth)
  5023     show "Suc i \<le> length xs" using `i < length xs` by simp
  5024     fix k assume "k < Suc i"
  5025     hence "k \<le> i" by auto
  5026     with sorted_rev_nth_mono[OF sorted this] `i < length xs`
  5027     have "length (xs ! i) \<le> length (xs ! k)" by simp
  5028     thus "Suc j \<le> length (xs ! k)" using j_less by simp
  5029   qed
  5030   have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]"
  5031     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]
  5032     using i_less_tW by (simp_all add: Suc_le_eq)
  5033   from j show "?R ! j = xs ! i ! j"
  5034     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]
  5035     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])
  5036 qed
  5037 
  5038 lemma transpose_transpose:
  5039   fixes xs :: "'a list list"
  5040   assumes sorted: "sorted (rev (map length xs))"
  5041   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")
  5042 proof -
  5043   have len: "length ?L = length ?R"
  5044     unfolding length_transpose transpose_max_length
  5045     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]
  5046     by simp
  5047 
  5048   { fix i assume "i < length ?R"
  5049     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]
  5050     have "i < length xs" by simp
  5051   } note * = this
  5052   show ?thesis
  5053     by (rule nth_equalityI)
  5054        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)
  5055 qed
  5056 
  5057 theorem transpose_rectangle:
  5058   assumes "xs = [] \<Longrightarrow> n = 0"
  5059   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"
  5060   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"
  5061     (is "?trans = ?map")
  5062 proof (rule nth_equalityI)
  5063   have "sorted (rev (map length xs))"
  5064     by (auto simp: rev_nth rect intro!: sorted_nth_monoI)
  5065   from foldr_max_sorted[OF this] assms
  5066   show len: "length ?trans = length ?map"
  5067     by (simp_all add: length_transpose foldr_map comp_def)
  5068   moreover
  5069   { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs"
  5070       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }
  5071   ultimately show "\<forall>i < length ?trans. ?trans ! i = ?map ! i"
  5072     by (auto simp: nth_transpose intro: nth_equalityI)
  5073 qed
  5074 
  5075 
  5076 subsubsection {* @{text sorted_list_of_set} *}
  5077 
  5078 text{* This function maps (finite) linearly ordered sets to sorted
  5079 lists. Warning: in most cases it is not a good idea to convert from
  5080 sets to lists but one should convert in the other direction (via
  5081 @{const set}). *}
  5082 
  5083 subsubsection {* @{text sorted_list_of_set} *}
  5084 
  5085 text{* This function maps (finite) linearly ordered sets to sorted
  5086 lists. Warning: in most cases it is not a good idea to convert from
  5087 sets to lists but one should convert in the other direction (via
  5088 @{const set}). *}
  5089 
  5090 context linorder
  5091 begin
  5092 
  5093 definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
  5094   "sorted_list_of_set = folding.F insort []"
  5095 
  5096 sublocale sorted_list_of_set!: folding insort Nil
  5097 where
  5098   "folding.F insort [] = sorted_list_of_set"
  5099 proof -
  5100   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
  5101   show "folding insort" by default (fact comp_fun_commute)
  5102   show "folding.F insort [] = sorted_list_of_set" by (simp only: sorted_list_of_set_def)
  5103 qed
  5104 
  5105 lemma sorted_list_of_set_empty:
  5106   "sorted_list_of_set {} = []"
  5107   by (fact sorted_list_of_set.empty)
  5108 
  5109 lemma sorted_list_of_set_insert [simp]:
  5110   "finite A \<Longrightarrow> sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"
  5111   by (fact sorted_list_of_set.insert_remove)
  5112 
  5113 lemma sorted_list_of_set_eq_Nil_iff [simp]:
  5114   "finite A \<Longrightarrow> sorted_list_of_set A = [] \<longleftrightarrow> A = {}"
  5115   by (auto simp: sorted_list_of_set.remove)
  5116 
  5117 lemma sorted_list_of_set [simp]:
  5118   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A) 
  5119     \<and> distinct (sorted_list_of_set A)"
  5120   by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)
  5121 
  5122 lemma distinct_sorted_list_of_set:
  5123   "distinct (sorted_list_of_set A)"
  5124   using sorted_list_of_set by (cases "finite A") auto
  5125 
  5126 lemma sorted_list_of_set_sort_remdups [code]:
  5127   "sorted_list_of_set (set xs) = sort (remdups xs)"
  5128 proof -
  5129   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
  5130   show ?thesis by (simp add: sorted_list_of_set.eq_fold sort_conv_fold fold_set_fold_remdups)
  5131 qed
  5132 
  5133 lemma sorted_list_of_set_remove:
  5134   assumes "finite A"
  5135   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"
  5136 proof (cases "x \<in> A")
  5137   case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp
  5138   with False show ?thesis by (simp add: remove1_idem)
  5139 next
  5140   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)
  5141   with assms show ?thesis by simp
  5142 qed
  5143 
  5144 end
  5145 
  5146 lemma sorted_list_of_set_range [simp]:
  5147   "sorted_list_of_set {m..<n} = [m..<n]"
  5148   by (rule sorted_distinct_set_unique) simp_all
  5149 
  5150 
  5151 subsubsection {* @{text lists}: the list-forming operator over sets *}
  5152 
  5153 inductive_set
  5154   lists :: "'a set => 'a list set"
  5155   for A :: "'a set"
  5156 where
  5157     Nil [intro!, simp]: "[]: lists A"
  5158   | Cons [intro!, simp]: "[| a: A; l: lists A|] ==> a#l : lists A"
  5159 
  5160 inductive_cases listsE [elim!]: "x#l : lists A"
  5161 inductive_cases listspE [elim!]: "listsp A (x # l)"
  5162 
  5163 inductive_simps listsp_simps[code]:
  5164   "listsp A []"
  5165   "listsp A (x # xs)"
  5166 
  5167 lemma listsp_mono [mono]: "A \<le> B ==> listsp A \<le> listsp B"
  5168 by (rule predicate1I, erule listsp.induct, blast+)
  5169 
  5170 lemmas lists_mono = listsp_mono [to_set]
  5171 
  5172 lemma listsp_infI:
  5173   assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using l
  5174 by induct blast+
  5175 
  5176 lemmas lists_IntI = listsp_infI [to_set]
  5177 
  5178 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"
  5179 proof (rule mono_inf [where f=listsp, THEN order_antisym])
  5180   show "mono listsp" by (simp add: mono_def listsp_mono)
  5181   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI)
  5182 qed
  5183 
  5184 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]
  5185 
  5186 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]
  5187 
  5188 lemma Cons_in_lists_iff[simp]: "x#xs : lists A \<longleftrightarrow> x:A \<and> xs : lists A"
  5189 by auto
  5190 
  5191 lemma append_in_listsp_conv [iff]:
  5192      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"
  5193 by (induct xs) auto
  5194 
  5195 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]
  5196 
  5197 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"
  5198 -- {* eliminate @{text listsp} in favour of @{text set} *}
  5199 by (induct xs) auto
  5200 
  5201 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]
  5202 
  5203 lemma in_listspD [dest!]: "listsp A xs ==> \<forall>x\<in>set xs. A x"
  5204 by (rule in_listsp_conv_set [THEN iffD1])
  5205 
  5206 lemmas in_listsD [dest!] = in_listspD [to_set]
  5207 
  5208 lemma in_listspI [intro!]: "\<forall>x\<in>set xs. A x ==> listsp A xs"
  5209 by (rule in_listsp_conv_set [THEN iffD2])
  5210 
  5211 lemmas in_listsI [intro!] = in_listspI [to_set]
  5212 
  5213 lemma lists_eq_set: "lists A = {xs. set xs <= A}"
  5214 by auto
  5215 
  5216 lemma lists_empty [simp]: "lists {} = {[]}"
  5217 by auto
  5218 
  5219 lemma lists_UNIV [simp]: "lists UNIV = UNIV"
  5220 by auto
  5221 
  5222 lemma lists_image: "lists (f`A) = map f ` lists A"
  5223 proof -
  5224   { fix xs have "\<forall>x\<in>set xs. x \<in> f ` A \<Longrightarrow> xs \<in> map f ` lists A"
  5225       by (induct xs) (auto simp del: list.map simp add: list.map[symmetric] intro!: imageI) }
  5226   then show ?thesis by auto
  5227 qed
  5228 
  5229 subsubsection {* Inductive definition for membership *}
  5230 
  5231 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  5232 where
  5233     elem:  "ListMem x (x # xs)"
  5234   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"
  5235 
  5236 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"
  5237 apply (rule iffI)
  5238  apply (induct set: ListMem)
  5239   apply auto
  5240 apply (induct xs)
  5241  apply (auto intro: ListMem.intros)
  5242 done
  5243 
  5244 
  5245 subsubsection {* Lists as Cartesian products *}
  5246 
  5247 text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from
  5248 @{term A} and tail drawn from @{term Xs}.*}
  5249 
  5250 definition set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where
  5251 "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"
  5252 
  5253 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])`A"
  5254 by (auto simp add: set_Cons_def)
  5255 
  5256 text{*Yields the set of lists, all of the same length as the argument and
  5257 with elements drawn from the corresponding element of the argument.*}
  5258 
  5259 primrec listset :: "'a set list \<Rightarrow> 'a list set" where
  5260 "listset [] = {[]}" |
  5261 "listset (A # As) = set_Cons A (listset As)"
  5262 
  5263 
  5264 subsection {* Relations on Lists *}
  5265 
  5266 subsubsection {* Length Lexicographic Ordering *}
  5267 
  5268 text{*These orderings preserve well-foundedness: shorter lists 
  5269   precede longer lists. These ordering are not used in dictionaries.*}
  5270         
  5271 primrec -- {*The lexicographic ordering for lists of the specified length*}
  5272   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where
  5273 "lexn r 0 = {}" |
  5274 "lexn r (Suc n) =
  5275   (map_prod (%(x, xs). x#xs) (%(x, xs). x#xs) ` (r <*lex*> lexn r n)) Int
  5276   {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"
  5277 
  5278 definition lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5279 "lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}
  5280 
  5281 definition lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where
  5282 "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"
  5283         -- {*Compares lists by their length and then lexicographically*}
  5284 
  5285 lemma wf_lexn: "wf r ==> wf (lexn r n)"
  5286 apply (induct n, simp, simp)
  5287 apply(rule wf_subset)
  5288  prefer 2 apply (rule Int_lower1)
  5289 apply(rule wf_map_prod_image)
  5290  prefer 2 apply (rule inj_onI, auto)
  5291 done
  5292 
  5293 lemma lexn_length:
  5294   "(xs, ys) : lexn r n ==> length xs = n \<and> length ys = n"
  5295 by (induct n arbitrary: xs ys) auto
  5296 
  5297 lemma wf_lex [intro!]: "wf r ==> wf (lex r)"
  5298 apply (unfold lex_def)
  5299 apply (rule wf_UN)
  5300 apply (blast intro: wf_lexn, clarify)
  5301 apply (rename_tac m n)
  5302 apply (subgoal_tac "m \<noteq> n")
  5303  prefer 2 apply blast
  5304 apply (blast dest: lexn_length not_sym)
  5305 done
  5306 
  5307 lemma lexn_conv:
  5308   "lexn r n =
  5309     {(xs,ys). length xs = n \<and> length ys = n \<and>
  5310     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y):r)}"
  5311 apply (induct n, simp)
  5312 apply (simp add: image_Collect lex_prod_def, safe, blast)
  5313  apply (rule_tac x = "ab # xys" in exI, simp)
  5314 apply (case_tac xys, simp_all, blast)
  5315 done
  5316 
  5317 lemma lex_conv:
  5318   "lex r =
  5319     {(xs,ys). length xs = length ys \<and>
  5320     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y):r)}"
  5321 by (force simp add: lex_def lexn_conv)
  5322 
  5323 lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"
  5324 by (unfold lenlex_def) blast
  5325 
  5326 lemma lenlex_conv:
  5327     "lenlex r = {(xs,ys). length xs < length ys |
  5328                  length xs = length ys \<and> (xs, ys) : lex r}"
  5329 by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)
  5330 
  5331 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"
  5332 by (simp add: lex_conv)
  5333 
  5334 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"
  5335 by (simp add:lex_conv)
  5336 
  5337 lemma Cons_in_lex [simp]:
  5338     "((x # xs, y # ys) : lex r) =
  5339       ((x, y) : r \<and> length xs = length ys | x = y \<and> (xs, ys) : lex r)"
  5340 apply (simp add: lex_conv)
  5341 apply (rule iffI)
  5342  prefer 2 apply (blast intro: Cons_eq_appendI, clarify)
  5343 apply (case_tac xys, simp, simp)
  5344 apply blast
  5345 done
  5346 
  5347 
  5348 subsubsection {* Lexicographic Ordering *}
  5349 
  5350 text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".
  5351     This ordering does \emph{not} preserve well-foundedness.
  5352      Author: N. Voelker, March 2005. *} 
  5353 
  5354 definition lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5355 "lexord r = {(x,y). \<exists> a v. y = x @ a # v \<or>
  5356             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"
  5357 
  5358 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"
  5359 by (unfold lexord_def, induct_tac y, auto) 
  5360 
  5361 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"
  5362 by (unfold lexord_def, induct_tac x, auto)
  5363 
  5364 lemma lexord_cons_cons[simp]:
  5365      "((a # x, b # y) \<in> lexord r) = ((a,b)\<in> r | (a = b & (x,y)\<in> lexord r))"
  5366   apply (unfold lexord_def, safe, simp_all)
  5367   apply (case_tac u, simp, simp)
  5368   apply (case_tac u, simp, clarsimp, blast, blast, clarsimp)
  5369   apply (erule_tac x="b # u" in allE)
  5370   by force
  5371 
  5372 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons
  5373 
  5374 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"
  5375 by (induct_tac x, auto)  
  5376 
  5377 lemma lexord_append_left_rightI:
  5378      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"
  5379 by (induct_tac u, auto)
  5380 
  5381 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"
  5382 by (induct x, auto)
  5383 
  5384 lemma lexord_append_leftD:
  5385      "\<lbrakk> (x @ u, x @ v) \<in> lexord r; (! a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"
  5386 by (erule rev_mp, induct_tac x, auto)
  5387 
  5388 lemma lexord_take_index_conv: 
  5389    "((x,y) : lexord r) = 
  5390     ((length x < length y \<and> take (length x) y = x) \<or> 
  5391      (\<exists>i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) \<in> r))"
  5392   apply (unfold lexord_def Let_def, clarsimp) 
  5393   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)
  5394   apply auto 
  5395   apply (rule_tac x="hd (drop (length x) y)" in exI)
  5396   apply (rule_tac x="tl (drop (length x) y)" in exI)
  5397   apply (erule subst, simp add: min_def) 
  5398   apply (rule_tac x ="length u" in exI, simp) 
  5399   apply (rule_tac x ="take i x" in exI) 
  5400   apply (rule_tac x ="x ! i" in exI) 
  5401   apply (rule_tac x ="y ! i" in exI, safe) 
  5402   apply (rule_tac x="drop (Suc i) x" in exI)
  5403   apply (drule sym, simp add: drop_Suc_conv_tl) 
  5404   apply (rule_tac x="drop (Suc i) y" in exI)
  5405   by (simp add: drop_Suc_conv_tl) 
  5406 
  5407 -- {* lexord is extension of partial ordering List.lex *} 
  5408 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"
  5409   apply (rule_tac x = y in spec) 
  5410   apply (induct_tac x, clarsimp) 
  5411   by (clarify, case_tac x, simp, force)
  5412 
  5413 lemma lexord_irreflexive: "ALL x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"
  5414 by (induct xs) auto
  5415 
  5416 text{* By Ren\'e Thiemann: *}
  5417 lemma lexord_partial_trans: 
  5418   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)
  5419    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"
  5420 proof (induct xs arbitrary: ys zs)
  5421   case Nil
  5422   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)
  5423 next
  5424   case (Cons x xs yys zzs)
  5425   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def
  5426     by (cases yys, auto)
  5427   note Cons = Cons[unfolded yys]
  5428   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto
  5429   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def
  5430     by (cases zzs, auto)
  5431   note Cons = Cons[unfolded zzs]
  5432   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto
  5433   {
  5434     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"
  5435     from Cons(1)[OF _ this] Cons(2)
  5436     have "(xs,zs) \<in> lexord r" by auto
  5437   } note ind1 = this
  5438   {
  5439     assume "(x,y) \<in> r" and "(y,z) \<in> r"
  5440     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto
  5441   } note ind2 = this
  5442   from one two ind1 ind2
  5443   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast
  5444   thus ?case unfolding zzs by auto
  5445 qed
  5446 
  5447 lemma lexord_trans: 
  5448     "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"
  5449 by(auto simp: trans_def intro:lexord_partial_trans)
  5450 
  5451 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"
  5452 by (rule transI, drule lexord_trans, blast) 
  5453 
  5454 lemma lexord_linear: "(! a b. (a,b)\<in> r | a = b | (b,a) \<in> r) \<Longrightarrow> (x,y) : lexord r | x = y | (y,x) : lexord r"
  5455   apply (rule_tac x = y in spec) 
  5456   apply (induct_tac x, rule allI) 
  5457   apply (case_tac x, simp, simp) 
  5458   apply (rule allI, case_tac x, simp, simp) 
  5459   by blast
  5460 
  5461 lemma lexord_irrefl:
  5462   "irrefl R \<Longrightarrow> irrefl (lexord R)"
  5463   by (simp add: irrefl_def lexord_irreflexive)
  5464   
  5465 lemma lexord_asym:
  5466   assumes "asym R"
  5467   shows "asym (lexord R)"
  5468 proof
  5469   from assms obtain "irrefl R" by (blast elim: asym.cases)
  5470   then show "irrefl (lexord R)" by (rule lexord_irrefl)
  5471 next
  5472   fix xs ys
  5473   assume "(xs, ys) \<in> lexord R"
  5474   then show "(ys, xs) \<notin> lexord R"
  5475   proof (induct xs arbitrary: ys)
  5476     case Nil
  5477     then show ?case by simp
  5478   next
  5479     case (Cons x xs)
  5480     then obtain z zs where ys: "ys = z # zs" by (cases ys) auto
  5481     with assms Cons show ?case by (auto elim: asym.cases)
  5482   qed
  5483 qed
  5484    
  5485 lemma lexord_asymmetric:
  5486   assumes "asym R"
  5487   assumes hyp: "(a, b) \<in> lexord R"
  5488   shows "(b, a) \<notin> lexord R"
  5489 proof -
  5490   from `asym R` have "asym (lexord R)" by (rule lexord_asym)
  5491   then show ?thesis by (rule asym.cases) (auto simp add: hyp)
  5492 qed
  5493 
  5494 
  5495 text {*
  5496   Predicate version of lexicographic order integrated with Isabelle's order type classes.
  5497   Author: Andreas Lochbihler
  5498 *}
  5499 
  5500 context ord begin
  5501 
  5502 inductive lexordp :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  5503 where
  5504   Nil: "lexordp [] (y # ys)"
  5505 | Cons: "x < y \<Longrightarrow> lexordp (x # xs) (y # ys)"
  5506 | Cons_eq:
  5507   "\<lbrakk> \<not> x < y; \<not> y < x; lexordp xs ys \<rbrakk> \<Longrightarrow> lexordp (x # xs) (y # ys)"
  5508 
  5509 lemma lexordp_simps [simp]:
  5510   "lexordp [] ys = (ys \<noteq> [])"
  5511   "lexordp xs [] = False"
  5512   "lexordp (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp xs ys"
  5513 by(subst lexordp.simps, fastforce simp add: neq_Nil_conv)+
  5514 
  5515 inductive lexordp_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  5516   Nil: "lexordp_eq [] ys"
  5517 | Cons: "x < y \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
  5518 | Cons_eq: "\<lbrakk> \<not> x < y; \<not> y < x; lexordp_eq xs ys \<rbrakk> \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
  5519 
  5520 lemma lexordp_eq_simps [simp]:
  5521   "lexordp_eq [] ys = True"
  5522   "lexordp_eq xs [] \<longleftrightarrow> xs = []"
  5523   "lexordp_eq (x # xs) [] = False"
  5524   "lexordp_eq (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp_eq xs ys"
  5525 by(subst lexordp_eq.simps, fastforce)+
  5526 
  5527 lemma lexordp_append_rightI: "ys \<noteq> Nil \<Longrightarrow> lexordp xs (xs @ ys)"
  5528 by(induct xs)(auto simp add: neq_Nil_conv)
  5529 
  5530 lemma lexordp_append_left_rightI: "x < y \<Longrightarrow> lexordp (us @ x # xs) (us @ y # ys)"
  5531 by(induct us) auto
  5532 
  5533 lemma lexordp_eq_refl: "lexordp_eq xs xs"
  5534 by(induct xs) simp_all
  5535 
  5536 lemma lexordp_append_leftI: "lexordp us vs \<Longrightarrow> lexordp (xs @ us) (xs @ vs)"
  5537 by(induct xs) auto
  5538 
  5539 lemma lexordp_append_leftD: "\<lbrakk> lexordp (xs @ us) (xs @ vs); \<forall>a. \<not> a < a \<rbrakk> \<Longrightarrow> lexordp us vs"
  5540 by(induct xs) auto
  5541 
  5542 lemma lexordp_irreflexive: 
  5543   assumes irrefl: "\<forall>x. \<not> x < x"
  5544   shows "\<not> lexordp xs xs"
  5545 proof
  5546   assume "lexordp xs xs"
  5547   thus False by(induct xs ys\<equiv>xs)(simp_all add: irrefl)
  5548 qed
  5549 
  5550 lemma lexordp_into_lexordp_eq:
  5551   assumes "lexordp xs ys"
  5552   shows "lexordp_eq xs ys"
  5553 using assms by induct simp_all
  5554 
  5555 end
  5556 
  5557 declare ord.lexordp_simps [simp, code]
  5558 declare ord.lexordp_eq_simps [code, simp]
  5559 
  5560 lemma lexord_code [code, code_unfold]: "lexordp = ord.lexordp less"
  5561 unfolding lexordp_def ord.lexordp_def ..
  5562 
  5563 context order begin
  5564 
  5565 lemma lexordp_antisym:
  5566   assumes "lexordp xs ys" "lexordp ys xs"
  5567   shows False
  5568 using assms by induct auto
  5569 
  5570 lemma lexordp_irreflexive': "\<not> lexordp xs xs"
  5571 by(rule lexordp_irreflexive) simp
  5572 
  5573 end
  5574 
  5575 context linorder begin
  5576 
  5577 lemma lexordp_cases [consumes 1, case_names Nil Cons Cons_eq, cases pred: lexordp]:
  5578   assumes "lexordp xs ys"
  5579   obtains (Nil) y ys' where "xs = []" "ys = y # ys'"
  5580   | (Cons) x xs' y ys' where "xs = x # xs'" "ys = y # ys'" "x < y"
  5581   | (Cons_eq) x xs' ys' where "xs = x # xs'" "ys = x # ys'" "lexordp xs' ys'"
  5582 using assms by cases (fastforce simp add: not_less_iff_gr_or_eq)+
  5583 
  5584 lemma lexordp_induct [consumes 1, case_names Nil Cons Cons_eq, induct pred: lexordp]:
  5585   assumes major: "lexordp xs ys"
  5586   and Nil: "\<And>y ys. P [] (y # ys)"
  5587   and Cons: "\<And>x xs y ys. x < y \<Longrightarrow> P (x # xs) (y # ys)"
  5588   and Cons_eq: "\<And>x xs ys. \<lbrakk> lexordp xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x # xs) (x # ys)"
  5589   shows "P xs ys"
  5590 using major by induct (simp_all add: Nil Cons not_less_iff_gr_or_eq Cons_eq)
  5591 
  5592 lemma lexordp_iff:
  5593   "lexordp xs ys \<longleftrightarrow> (\<exists>x vs. ys = xs @ x # vs) \<or> (\<exists>us a b vs ws. a < b \<and> xs = us @ a # vs \<and> ys = us @ b # ws)"
  5594   (is "?lhs = ?rhs")
  5595 proof
  5596   assume ?lhs thus ?rhs
  5597   proof induct
  5598     case Cons_eq thus ?case by simp (metis append.simps(2))
  5599   qed(fastforce intro: disjI2 del: disjCI intro: exI[where x="[]"])+
  5600 next
  5601   assume ?rhs thus ?lhs
  5602     by(auto intro: lexordp_append_leftI[where us="[]", simplified] lexordp_append_leftI)
  5603 qed
  5604 
  5605 lemma lexordp_conv_lexord:
  5606   "lexordp xs ys \<longleftrightarrow> (xs, ys) \<in> lexord {(x, y). x < y}"
  5607 by(simp add: lexordp_iff lexord_def)
  5608 
  5609 lemma lexordp_eq_antisym: 
  5610   assumes "lexordp_eq xs ys" "lexordp_eq ys xs" 
  5611   shows "xs = ys"
  5612 using assms by induct simp_all
  5613 
  5614 lemma lexordp_eq_trans:
  5615   assumes "lexordp_eq xs ys" and "lexordp_eq ys zs"
  5616   shows "lexordp_eq xs zs"
  5617 using assms
  5618 apply(induct arbitrary: zs)
  5619 apply(case_tac [2-3] zs)
  5620 apply auto
  5621 done
  5622 
  5623 lemma lexordp_trans:
  5624   assumes "lexordp xs ys" "lexordp ys zs"
  5625   shows "lexordp xs zs"
  5626 using assms
  5627 apply(induct arbitrary: zs)
  5628 apply(case_tac [2-3] zs)
  5629 apply auto
  5630 done
  5631 
  5632 lemma lexordp_linear: "lexordp xs ys \<or> xs = ys \<or> lexordp ys xs"
  5633 proof(induct xs arbitrary: ys)
  5634   case Nil thus ?case by(cases ys) simp_all
  5635 next
  5636   case Cons thus ?case by(cases ys) auto
  5637 qed
  5638 
  5639 lemma lexordp_conv_lexordp_eq: "lexordp xs ys \<longleftrightarrow> lexordp_eq xs ys \<and> \<not> lexordp_eq ys xs"
  5640   (is "?lhs \<longleftrightarrow> ?rhs")
  5641 proof
  5642   assume ?lhs
  5643   moreover hence "\<not> lexordp_eq ys xs" by induct simp_all
  5644   ultimately show ?rhs by(simp add: lexordp_into_lexordp_eq)
  5645 next
  5646   assume ?rhs
  5647   hence "lexordp_eq xs ys" "\<not> lexordp_eq ys xs" by simp_all
  5648   thus ?lhs by induct simp_all
  5649 qed
  5650 
  5651 lemma lexordp_eq_conv_lexord: "lexordp_eq xs ys \<longleftrightarrow> xs = ys \<or> lexordp xs ys"
  5652 by(auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl dest: lexordp_eq_antisym)
  5653 
  5654 lemma lexordp_eq_linear: "lexordp_eq xs ys \<or> lexordp_eq ys xs"
  5655 apply(induct xs arbitrary: ys)
  5656 apply(case_tac [!] ys)
  5657 apply auto
  5658 done
  5659 
  5660 lemma lexordp_linorder: "class.linorder lexordp_eq lexordp"
  5661 by unfold_locales(auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl lexordp_eq_antisym intro: lexordp_eq_trans del: disjCI intro: lexordp_eq_linear)
  5662 
  5663 end
  5664 
  5665 subsubsection {* Lexicographic combination of measure functions *}
  5666 
  5667 text {* These are useful for termination proofs *}
  5668 
  5669 definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"
  5670 
  5671 lemma wf_measures[simp]: "wf (measures fs)"
  5672 unfolding measures_def
  5673 by blast
  5674 
  5675 lemma in_measures[simp]: 
  5676   "(x, y) \<in> measures [] = False"
  5677   "(x, y) \<in> measures (f # fs)
  5678          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"  
  5679 unfolding measures_def
  5680 by auto
  5681 
  5682 lemma measures_less: "f x < f y ==> (x, y) \<in> measures (f#fs)"
  5683 by simp
  5684 
  5685 lemma measures_lesseq: "f x <= f y ==> (x, y) \<in> measures fs ==> (x, y) \<in> measures (f#fs)"
  5686 by auto
  5687 
  5688 
  5689 subsubsection {* Lifting Relations to Lists: one element *}
  5690 
  5691 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5692 "listrel1 r = {(xs,ys).
  5693    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"
  5694 
  5695 lemma listrel1I:
  5696   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>
  5697   (xs, ys) \<in> listrel1 r"
  5698 unfolding listrel1_def by auto
  5699 
  5700 lemma listrel1E:
  5701   "\<lbrakk> (xs, ys) \<in> listrel1 r;
  5702      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P
  5703    \<rbrakk> \<Longrightarrow> P"
  5704 unfolding listrel1_def by auto
  5705 
  5706 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"
  5707 unfolding listrel1_def by blast
  5708 
  5709 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"
  5710 unfolding listrel1_def by blast
  5711 
  5712 lemma Cons_listrel1_Cons [iff]:
  5713   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>
  5714    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"
  5715 by (simp add: listrel1_def Cons_eq_append_conv) (blast)
  5716 
  5717 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"
  5718 by fast
  5719 
  5720 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"
  5721 by fast
  5722 
  5723 lemma append_listrel1I:
  5724   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r
  5725     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"
  5726 unfolding listrel1_def
  5727 by auto (blast intro: append_eq_appendI)+
  5728 
  5729 lemma Cons_listrel1E1[elim!]:
  5730   assumes "(x # xs, ys) \<in> listrel1 r"
  5731     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
  5732     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"
  5733   shows R
  5734 using assms by (cases ys) blast+
  5735 
  5736 lemma Cons_listrel1E2[elim!]:
  5737   assumes "(xs, y # ys) \<in> listrel1 r"
  5738     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
  5739     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"
  5740   shows R
  5741 using assms by (cases xs) blast+
  5742 
  5743 lemma snoc_listrel1_snoc_iff:
  5744   "(xs @ [x], ys @ [y]) \<in> listrel1 r
  5745     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")
  5746 proof
  5747   assume ?L thus ?R
  5748     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)
  5749 next
  5750   assume ?R then show ?L unfolding listrel1_def by force
  5751 qed
  5752 
  5753 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"
  5754 unfolding listrel1_def by auto
  5755 
  5756 lemma listrel1_mono:
  5757   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"
  5758 unfolding listrel1_def by blast
  5759 
  5760 
  5761 lemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"
  5762 unfolding listrel1_def by blast
  5763 
  5764 lemma in_listrel1_converse:
  5765   "(x,y) : listrel1 (r^-1) \<longleftrightarrow> (x,y) : (listrel1 r)^-1"
  5766 unfolding listrel1_def by blast
  5767 
  5768 lemma listrel1_iff_update:
  5769   "(xs,ys) \<in> (listrel1 r)
  5770    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")
  5771 proof
  5772   assume "?L"
  5773   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"
  5774     unfolding listrel1_def by auto
  5775   then have "ys = xs[length u := y]" and "length u < length xs"
  5776     and "(xs ! length u, y) \<in> r" by auto
  5777   then show "?R" by auto
  5778 next
  5779   assume "?R"
  5780   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"
  5781     by auto
  5782   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"
  5783     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)
  5784   then show "?L" by (auto simp: listrel1_def)
  5785 qed
  5786 
  5787 
  5788 text{* Accessible part and wellfoundedness: *}
  5789 
  5790 lemma Cons_acc_listrel1I [intro!]:
  5791   "x \<in> Wellfounded.acc r \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> Wellfounded.acc (listrel1 r)"
  5792 apply (induct arbitrary: xs set: Wellfounded.acc)
  5793 apply (erule thin_rl)
  5794 apply (erule acc_induct)
  5795 apply (rule accI)
  5796 apply (blast)
  5797 done
  5798 
  5799 lemma lists_accD: "xs \<in> lists (Wellfounded.acc r) \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r)"
  5800 apply (induct set: lists)
  5801  apply (rule accI)
  5802  apply simp
  5803 apply (rule accI)
  5804 apply (fast dest: acc_downward)
  5805 done
  5806 
  5807 lemma lists_accI: "xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> xs \<in> lists (Wellfounded.acc r)"
  5808 apply (induct set: Wellfounded.acc)
  5809 apply clarify
  5810 apply (rule accI)
  5811 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)
  5812 done
  5813 
  5814 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"
  5815 by (auto simp: wf_acc_iff
  5816       intro: lists_accD lists_accI[THEN Cons_in_lists_iff[THEN iffD1, THEN conjunct1]])
  5817 
  5818 subsubsection {* Lifting Relations to Lists: all elements *}
  5819 
  5820 inductive_set
  5821   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"
  5822   for r :: "('a \<times> 'b) set"
  5823 where
  5824     Nil:  "([],[]) \<in> listrel r"
  5825   | Cons: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (x#xs, y#ys) \<in> listrel r"
  5826 
  5827 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"
  5828 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"
  5829 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"
  5830 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"
  5831 
  5832 
  5833 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"
  5834 by(induct rule: listrel.induct) auto
  5835 
  5836 lemma listrel_iff_zip [code_unfold]: "(xs,ys) : listrel r \<longleftrightarrow>
  5837   length xs = length ys & (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")
  5838 proof
  5839   assume ?L thus ?R by induct (auto intro: listrel_eq_len)
  5840 next
  5841   assume ?R thus ?L
  5842     apply (clarify)
  5843     by (induct rule: list_induct2) (auto intro: listrel.intros)
  5844 qed
  5845 
  5846 lemma listrel_iff_nth: "(xs,ys) : listrel r \<longleftrightarrow>
  5847   length xs = length ys & (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")
  5848 by (auto simp add: all_set_conv_all_nth listrel_iff_zip)
  5849 
  5850 
  5851 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"
  5852 apply clarify  
  5853 apply (erule listrel.induct)
  5854 apply (blast intro: listrel.intros)+
  5855 done
  5856 
  5857 lemma listrel_subset: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"
  5858 apply clarify 
  5859 apply (erule listrel.induct, auto) 
  5860 done
  5861 
  5862 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)" 
  5863 apply (simp add: refl_on_def listrel_subset Ball_def)
  5864 apply (rule allI) 
  5865 apply (induct_tac x) 
  5866 apply (auto intro: listrel.intros)
  5867 done
  5868 
  5869 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)" 
  5870 apply (auto simp add: sym_def)
  5871 apply (erule listrel.induct) 
  5872 apply (blast intro: listrel.intros)+
  5873 done
  5874 
  5875 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)" 
  5876 apply (simp add: trans_def)
  5877 apply (intro allI) 
  5878 apply (rule impI) 
  5879 apply (erule listrel.induct) 
  5880 apply (blast intro: listrel.intros)+
  5881 done
  5882 
  5883 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"
  5884 by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans) 
  5885 
  5886 lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"
  5887 using listrel_refl_on[of UNIV, OF refl_rtrancl]
  5888 by(auto simp: refl_on_def)
  5889 
  5890 lemma listrel_rtrancl_trans:
  5891   "\<lbrakk> (xs,ys) : listrel(r^*);  (ys,zs) : listrel(r^*) \<rbrakk>
  5892   \<Longrightarrow> (xs,zs) : listrel(r^*)"
  5893 by (metis listrel_trans trans_def trans_rtrancl)
  5894 
  5895 
  5896 lemma listrel_Nil [simp]: "listrel r `` {[]} = {[]}"
  5897 by (blast intro: listrel.intros)
  5898 
  5899 lemma listrel_Cons:
  5900      "listrel r `` {x#xs} = set_Cons (r``{x}) (listrel r `` {xs})"
  5901 by (auto simp add: set_Cons_def intro: listrel.intros)
  5902 
  5903 text {* Relating @{term listrel1}, @{term listrel} and closures: *}
  5904 
  5905 lemma listrel1_rtrancl_subset_rtrancl_listrel1:
  5906   "listrel1 (r^*) \<subseteq> (listrel1 r)^*"
  5907 proof (rule subrelI)
  5908   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r^*)"
  5909   { fix x y us vs
  5910     have "(x,y) : r^* \<Longrightarrow> (us @ x # vs, us @ y # vs) : (listrel1 r)^*"
  5911     proof(induct rule: rtrancl.induct)
  5912       case rtrancl_refl show ?case by simp
  5913     next
  5914       case rtrancl_into_rtrancl thus ?case
  5915         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)
  5916     qed }
  5917   thus "(xs,ys) \<in> (listrel1 r)^*" using 1 by(blast elim: listrel1E)
  5918 qed
  5919 
  5920 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)^* \<Longrightarrow> length x = length y"
  5921 by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)
  5922 
  5923 lemma rtrancl_listrel1_ConsI1:
  5924   "(xs,ys) : (listrel1 r)^* \<Longrightarrow> (x#xs,x#ys) : (listrel1 r)^*"
  5925 apply(induct rule: rtrancl.induct)
  5926  apply simp
  5927 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)
  5928 
  5929 lemma rtrancl_listrel1_ConsI2:
  5930   "(x,y) \<in> r^* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)^*
  5931   \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)^*"
  5932   by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1 
  5933     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])
  5934 
  5935 lemma listrel1_subset_listrel:
  5936   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"
  5937 by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)
  5938 
  5939 lemma listrel_reflcl_if_listrel1:
  5940   "(xs,ys) : listrel1 r \<Longrightarrow> (xs,ys) : listrel(r^*)"
  5941 by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)
  5942 
  5943 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"
  5944 proof
  5945   { fix x y assume "(x,y) \<in> listrel (r^*)"
  5946     then have "(x,y) \<in> (listrel1 r)^*"
  5947     by induct (auto intro: rtrancl_listrel1_ConsI2) }
  5948   then show "listrel (r^*) \<subseteq> (listrel1 r)^*"
  5949     by (rule subrelI)
  5950 next
  5951   show "listrel (r^*) \<supseteq> (listrel1 r)^*"
  5952   proof(rule subrelI)
  5953     fix xs ys assume "(xs,ys) \<in> (listrel1 r)^*"
  5954     then show "(xs,ys) \<in> listrel (r^*)"
  5955     proof induct
  5956       case base show ?case by(auto simp add: listrel_iff_zip set_zip)
  5957     next
  5958       case (step ys zs)
  5959       thus ?case by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)
  5960     qed
  5961   qed
  5962 qed
  5963 
  5964 lemma rtrancl_listrel1_if_listrel:
  5965   "(xs,ys) : listrel r \<Longrightarrow> (xs,ys) : (listrel1 r)^*"
  5966 by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)
  5967 
  5968 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)^*"
  5969 by(fast intro:rtrancl_listrel1_if_listrel)
  5970 
  5971 
  5972 subsection {* Size function *}
  5973 
  5974 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (size_list f)"
  5975 by (rule is_measure_trivial)
  5976 
  5977 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (size_option f)"
  5978 by (rule is_measure_trivial)
  5979 
  5980 lemma size_list_estimation[termination_simp]: 
  5981   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < size_list f xs"
  5982 by (induct xs) auto
  5983 
  5984 lemma size_list_estimation'[termination_simp]: 
  5985   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_list f xs"
  5986 by (induct xs) auto
  5987 
  5988 lemma size_list_map[simp]: "size_list f (map g xs) = size_list (f o g) xs"
  5989 by (induct xs) auto
  5990 
  5991 lemma size_list_append[simp]: "size_list f (xs @ ys) = size_list f xs + size_list f ys"
  5992 by (induct xs, auto)
  5993 
  5994 lemma size_list_pointwise[termination_simp]: 
  5995   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> size_list f xs \<le> size_list g xs"
  5996 by (induct xs) force+
  5997 
  5998 
  5999 subsection {* Monad operation *}
  6000 
  6001 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
  6002 "bind xs f = concat (map f xs)"
  6003 
  6004 hide_const (open) bind
  6005 
  6006 lemma bind_simps [simp]:
  6007   "List.bind [] f = []"
  6008   "List.bind (x # xs) f = f x @ List.bind xs f"
  6009   by (simp_all add: bind_def)
  6010 
  6011 
  6012 subsection {* Transfer *}
  6013 
  6014 definition embed_list :: "nat list \<Rightarrow> int list" where
  6015 "embed_list l = map int l"
  6016 
  6017 definition nat_list :: "int list \<Rightarrow> bool" where
  6018 "nat_list l = nat_set (set l)"
  6019 
  6020 definition return_list :: "int list \<Rightarrow> nat list" where
  6021 "return_list l = map nat l"
  6022 
  6023 lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>
  6024     embed_list (return_list l) = l"
  6025   unfolding embed_list_def return_list_def nat_list_def nat_set_def
  6026   apply (induct l)
  6027   apply auto
  6028 done
  6029 
  6030 lemma transfer_nat_int_list_functions:
  6031   "l @ m = return_list (embed_list l @ embed_list m)"
  6032   "[] = return_list []"
  6033   unfolding return_list_def embed_list_def
  6034   apply auto
  6035   apply (induct l, auto)
  6036   apply (induct m, auto)
  6037 done
  6038 
  6039 (*
  6040 lemma transfer_nat_int_fold1: "fold f l x =
  6041     fold (%x. f (nat x)) (embed_list l) x";
  6042 *)
  6043 
  6044 
  6045 subsection {* Code generation *}
  6046 
  6047 text{* Optional tail recursive version of @{const map}. Can avoid
  6048 stack overflow in some target languages. *}
  6049 
  6050 fun map_tailrec_rev ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  6051 "map_tailrec_rev f [] bs = bs" |
  6052 "map_tailrec_rev f (a#as) bs = map_tailrec_rev f as (f a # bs)"
  6053 
  6054 lemma map_tailrec_rev:
  6055   "map_tailrec_rev f as bs = rev(map f as) @ bs"
  6056 by(induction as arbitrary: bs) simp_all
  6057 
  6058 definition map_tailrec :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  6059 "map_tailrec f as = rev (map_tailrec_rev f as [])"
  6060 
  6061 text{* Code equation: *}
  6062 lemma map_eq_map_tailrec: "map = map_tailrec"
  6063 by(simp add: fun_eq_iff map_tailrec_def map_tailrec_rev)
  6064 
  6065 
  6066 subsubsection {* Counterparts for set-related operations *}
  6067 
  6068 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
  6069 [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"
  6070 
  6071 text {*
  6072   Use @{text member} only for generating executable code.  Otherwise use
  6073   @{prop "x \<in> set xs"} instead --- it is much easier to reason about.
  6074 *}
  6075 
  6076 lemma member_rec [code]:
  6077   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"
  6078   "member [] y \<longleftrightarrow> False"
  6079   by (auto simp add: member_def)
  6080 
  6081 lemma in_set_member (* FIXME delete candidate *):
  6082   "x \<in> set xs \<longleftrightarrow> member xs x"
  6083   by (simp add: member_def)
  6084 
  6085 abbreviation "list_all == pred_list"
  6086 
  6087 lemma list_all_iff [code_abbrev]: "list_all P xs \<longleftrightarrow> Ball (set xs) P"
  6088 unfolding pred_list_def ..
  6089 
  6090 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  6091 list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"
  6092 
  6093 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  6094 list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"
  6095 
  6096 text {*
  6097   Usually you should prefer @{text "\<forall>x\<in>set xs"}, @{text "\<exists>x\<in>set xs"}
  6098   and @{text "\<exists>!x. x\<in>set xs \<and> _"} over @{const list_all}, @{const list_ex}
  6099   and @{const list_ex1} in specifications.
  6100 *}
  6101 
  6102 lemma list_all_simps [code]:
  6103   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"
  6104   "list_all P [] \<longleftrightarrow> True"
  6105   by (simp_all add: list_all_iff)
  6106 
  6107 lemma list_ex_simps [simp, code]:
  6108   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"
  6109   "list_ex P [] \<longleftrightarrow> False"
  6110   by (simp_all add: list_ex_iff)
  6111 
  6112 lemma list_ex1_simps [simp, code]:
  6113   "list_ex1 P [] = False"
  6114   "list_ex1 P (x # xs) = (if P x then list_all (\<lambda>y. \<not> P y \<or> x = y) xs else list_ex1 P xs)"
  6115   by (auto simp add: list_ex1_iff list_all_iff)
  6116 
  6117 lemma Ball_set_list_all: (* FIXME delete candidate *)
  6118   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
  6119   by (simp add: list_all_iff)
  6120 
  6121 lemma Bex_set_list_ex: (* FIXME delete candidate *)
  6122   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
  6123   by (simp add: list_ex_iff)
  6124 
  6125 lemma list_all_append [simp]:
  6126   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"
  6127   by (auto simp add: list_all_iff)
  6128 
  6129 lemma list_ex_append [simp]:
  6130   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"
  6131   by (auto simp add: list_ex_iff)
  6132 
  6133 lemma list_all_rev [simp]:
  6134   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"
  6135   by (simp add: list_all_iff)
  6136 
  6137 lemma list_ex_rev [simp]:
  6138   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"
  6139   by (simp add: list_ex_iff)
  6140 
  6141 lemma list_all_length:
  6142   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"
  6143   by (auto simp add: list_all_iff set_conv_nth)
  6144 
  6145 lemma list_ex_length:
  6146   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"
  6147   by (auto simp add: list_ex_iff set_conv_nth)
  6148 
  6149 lemma list_all_cong [fundef_cong]:
  6150   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_all f xs = list_all g ys"
  6151   by (simp add: list_all_iff)
  6152 
  6153 lemma list_ex_cong [fundef_cong]:
  6154   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"
  6155 by (simp add: list_ex_iff)
  6156 
  6157 definition can_select :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  6158 [code_abbrev]: "can_select P A = (\<exists>!x\<in>A. P x)"
  6159 
  6160 lemma can_select_set_list_ex1 [code]:
  6161   "can_select P (set A) = list_ex1 P A"
  6162   by (simp add: list_ex1_iff can_select_def)
  6163 
  6164 
  6165 text {* Executable checks for relations on sets *}
  6166 
  6167 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  6168 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"
  6169 
  6170 lemma [code_unfold]:
  6171   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"
  6172 unfolding listrel1p_def by auto
  6173 
  6174 lemma [code]:
  6175   "listrel1p r [] xs = False"
  6176   "listrel1p r xs [] =  False"
  6177   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>
  6178      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"
  6179 by (simp add: listrel1p_def)+
  6180 
  6181 definition
  6182   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  6183   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"
  6184 
  6185 lemma [code_unfold]:
  6186   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"
  6187 unfolding lexordp_def by auto
  6188 
  6189 lemma [code]:
  6190   "lexordp r xs [] = False"
  6191   "lexordp r [] (y#ys) = True"
  6192   "lexordp r (x # xs) (y # ys) = (r x y | (x = y & lexordp r xs ys))"
  6193 unfolding lexordp_def by auto
  6194 
  6195 text {* Bounded quantification and summation over nats. *}
  6196 
  6197 lemma atMost_upto [code_unfold]:
  6198   "{..n} = set [0..<Suc n]"
  6199   by auto
  6200 
  6201 lemma atLeast_upt [code_unfold]:
  6202   "{..<n} = set [0..<n]"
  6203   by auto
  6204 
  6205 lemma greaterThanLessThan_upt [code_unfold]:
  6206   "{n<..<m} = set [Suc n..<m]"
  6207   by auto
  6208 
  6209 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]
  6210 
  6211 lemma greaterThanAtMost_upt [code_unfold]:
  6212   "{n<..m} = set [Suc n..<Suc m]"
  6213   by auto
  6214 
  6215 lemma atLeastAtMost_upt [code_unfold]:
  6216   "{n..m} = set [n..<Suc m]"
  6217   by auto
  6218 
  6219 lemma all_nat_less_eq [code_unfold]:
  6220   "(\<forall>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"
  6221   by auto
  6222 
  6223 lemma ex_nat_less_eq [code_unfold]:
  6224   "(\<exists>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"
  6225   by auto
  6226 
  6227 lemma all_nat_less [code_unfold]:
  6228   "(\<forall>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"
  6229   by auto
  6230 
  6231 lemma ex_nat_less [code_unfold]:
  6232   "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"
  6233   by auto
  6234 
  6235 lemma setsum_set_upt_conv_listsum_nat [code_unfold]:
  6236   "setsum f (set [m..<n]) = listsum (map f [m..<n])"
  6237   by (simp add: interv_listsum_conv_setsum_set_nat)
  6238 
  6239 text{* Bounded @{text LEAST} operator: *}
  6240 
  6241 definition "Bleast S P = (LEAST x. x \<in> S \<and> P x)"
  6242 
  6243 definition "abort_Bleast S P = (LEAST x. x \<in> S \<and> P x)"
  6244 
  6245 declare [[code abort: abort_Bleast]]
  6246 
  6247 lemma Bleast_code [code]:
  6248  "Bleast (set xs) P = (case filter P (sort xs) of
  6249     x#xs \<Rightarrow> x |
  6250     [] \<Rightarrow> abort_Bleast (set xs) P)"
  6251 proof (cases "filter P (sort xs)")
  6252   case Nil thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
  6253 next
  6254   case (Cons x ys)
  6255   have "(LEAST x. x \<in> set xs \<and> P x) = x"
  6256   proof (rule Least_equality)
  6257     show "x \<in> set xs \<and> P x"
  6258       by (metis Cons Cons_eq_filter_iff in_set_conv_decomp set_sort)
  6259     next
  6260       fix y assume "y : set xs \<and> P y"
  6261       hence "y : set (filter P xs)" by auto
  6262       thus "x \<le> y"
  6263         by (metis Cons eq_iff filter_sort set_ConsD set_sort sorted_Cons sorted_sort)
  6264   qed
  6265   thus ?thesis using Cons by (simp add: Bleast_def)
  6266 qed
  6267 
  6268 declare Bleast_def[symmetric, code_unfold]
  6269 
  6270 text {* Summation over ints. *}
  6271 
  6272 lemma greaterThanLessThan_upto [code_unfold]:
  6273   "{i<..<j::int} = set [i+1..j - 1]"
  6274 by auto
  6275 
  6276 lemma atLeastLessThan_upto [code_unfold]:
  6277   "{i..<j::int} = set [i..j - 1]"
  6278 by auto
  6279 
  6280 lemma greaterThanAtMost_upto [code_unfold]:
  6281   "{i<..j::int} = set [i+1..j]"
  6282 by auto
  6283 
  6284 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]
  6285 
  6286 lemma setsum_set_upto_conv_listsum_int [code_unfold]:
  6287   "setsum f (set [i..j::int]) = listsum (map f [i..j])"
  6288   by (simp add: interv_listsum_conv_setsum_set_int)
  6289 
  6290 
  6291 subsubsection {* Optimizing by rewriting *}
  6292 
  6293 definition null :: "'a list \<Rightarrow> bool" where
  6294   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"
  6295 
  6296 text {*
  6297   Efficient emptyness check is implemented by @{const null}.
  6298 *}
  6299 
  6300 lemma null_rec [code]:
  6301   "null (x # xs) \<longleftrightarrow> False"
  6302   "null [] \<longleftrightarrow> True"
  6303   by (simp_all add: null_def)
  6304 
  6305 lemma eq_Nil_null: (* FIXME delete candidate *)
  6306   "xs = [] \<longleftrightarrow> null xs"
  6307   by (simp add: null_def)
  6308 
  6309 lemma equal_Nil_null [code_unfold]:
  6310   "HOL.equal xs [] \<longleftrightarrow> null xs"
  6311   "HOL.equal [] = null"
  6312   by (auto simp add: equal null_def)
  6313 
  6314 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  6315   [code_abbrev]: "maps f xs = concat (map f xs)"
  6316 
  6317 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  6318   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"
  6319 
  6320 text {*
  6321   Operations @{const maps} and @{const map_filter} avoid
  6322   intermediate lists on execution -- do not use for proving.
  6323 *}
  6324 
  6325 lemma maps_simps [code]:
  6326   "maps f (x # xs) = f x @ maps f xs"
  6327   "maps f [] = []"
  6328   by (simp_all add: maps_def)
  6329 
  6330 lemma map_filter_simps [code]:
  6331   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"
  6332   "map_filter f [] = []"
  6333   by (simp_all add: map_filter_def split: option.split)
  6334 
  6335 lemma concat_map_maps: (* FIXME delete candidate *)
  6336   "concat (map f xs) = maps f xs"
  6337   by (simp add: maps_def)
  6338 
  6339 lemma map_filter_map_filter [code_unfold]:
  6340   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"
  6341   by (simp add: map_filter_def)
  6342 
  6343 text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}
  6344 and similiarly for @{text"\<exists>"}. *}
  6345 
  6346 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  6347   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"
  6348 
  6349 lemma [code]:
  6350   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"
  6351 proof -
  6352   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"
  6353   proof -
  6354     fix n
  6355     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"
  6356     then show "P n" by (cases "n = i") simp_all