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