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