src/HOL/List.thy
author wenzelm
Wed Apr 10 21:20:35 2013 +0200 (2013-04-10)
changeset 51692 ecd34f863242
parent 51678 1e33b81c328a
child 51717 9e7d1c139569
permissions -rw-r--r--
tuned pretty layout: avoid nested Pretty.string_of, which merely happens to work with Isabelle/jEdit since formatting is delegated to Scala side;
declare command "print_case_translations" where it is actually defined;
     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, Case_Translation.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.set_eq_fold [code]
  2787 declare Max.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 set_insort_key:
  4342   "set (insort_key f x xs) = insert x (set xs)"
  4343   by (induct xs) auto
  4344 
  4345 lemma length_insort [simp]:
  4346   "length (insort_key f x xs) = Suc (length xs)"
  4347   by (induct xs) simp_all
  4348 
  4349 lemma insort_key_left_comm:
  4350   assumes "f x \<noteq> f y"
  4351   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"
  4352   by (induct xs) (auto simp add: assms dest: antisym)
  4353 
  4354 lemma insort_left_comm:
  4355   "insort x (insort y xs) = insort y (insort x xs)"
  4356   by (cases "x = y") (auto intro: insort_key_left_comm)
  4357 
  4358 lemma comp_fun_commute_insort:
  4359   "comp_fun_commute insort"
  4360 proof
  4361 qed (simp add: insort_left_comm fun_eq_iff)
  4362 
  4363 lemma sort_key_simps [simp]:
  4364   "sort_key f [] = []"
  4365   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"
  4366   by (simp_all add: sort_key_def)
  4367 
  4368 lemma (in linorder) sort_key_conv_fold:
  4369   assumes "inj_on f (set xs)"
  4370   shows "sort_key f xs = fold (insort_key f) xs []"
  4371 proof -
  4372   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
  4373   proof (rule fold_rev, rule ext)
  4374     fix zs
  4375     fix x y
  4376     assume "x \<in> set xs" "y \<in> set xs"
  4377     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
  4378     have **: "x = y \<longleftrightarrow> y = x" by auto
  4379     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
  4380       by (induct zs) (auto intro: * simp add: **)
  4381   qed
  4382   then show ?thesis by (simp add: sort_key_def foldr_conv_fold)
  4383 qed
  4384 
  4385 lemma (in linorder) sort_conv_fold:
  4386   "sort xs = fold insort xs []"
  4387   by (rule sort_key_conv_fold) simp
  4388 
  4389 lemma length_sort[simp]: "length (sort_key f xs) = length xs"
  4390 by (induct xs, auto)
  4391 
  4392 lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"
  4393 apply(induct xs arbitrary: x) apply simp
  4394 by simp (blast intro: order_trans)
  4395 
  4396 lemma sorted_tl:
  4397   "sorted xs \<Longrightarrow> sorted (tl xs)"
  4398   by (cases xs) (simp_all add: sorted_Cons)
  4399 
  4400 lemma sorted_append:
  4401   "sorted (xs@ys) = (sorted xs & sorted ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"
  4402 by (induct xs) (auto simp add:sorted_Cons)
  4403 
  4404 lemma sorted_nth_mono:
  4405   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"
  4406 by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)
  4407 
  4408 lemma sorted_rev_nth_mono:
  4409   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"
  4410 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]
  4411       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]
  4412 by auto
  4413 
  4414 lemma sorted_nth_monoI:
  4415   "(\<And> i j. \<lbrakk> i \<le> j ; j < length xs \<rbrakk> \<Longrightarrow> xs ! i \<le> xs ! j) \<Longrightarrow> sorted xs"
  4416 proof (induct xs)
  4417   case (Cons x xs)
  4418   have "sorted xs"
  4419   proof (rule Cons.hyps)
  4420     fix i j assume "i \<le> j" and "j < length xs"
  4421     with Cons.prems[of "Suc i" "Suc j"]
  4422     show "xs ! i \<le> xs ! j" by auto
  4423   qed
  4424   moreover
  4425   {
  4426     fix y assume "y \<in> set xs"
  4427     then obtain j where "j < length xs" and "xs ! j = y"
  4428       unfolding in_set_conv_nth by blast
  4429     with Cons.prems[of 0 "Suc j"]
  4430     have "x \<le> y"
  4431       by auto
  4432   }
  4433   ultimately
  4434   show ?case
  4435     unfolding sorted_Cons by auto
  4436 qed simp
  4437 
  4438 lemma sorted_equals_nth_mono:
  4439   "sorted xs = (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"
  4440 by (auto intro: sorted_nth_monoI sorted_nth_mono)
  4441 
  4442 lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"
  4443 by (induct xs) auto
  4444 
  4445 lemma set_sort[simp]: "set(sort_key f xs) = set xs"
  4446 by (induct xs) (simp_all add:set_insort)
  4447 
  4448 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"
  4449 by(induct xs)(auto simp:set_insort)
  4450 
  4451 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"
  4452   by (induct xs) (simp_all add: distinct_insort)
  4453 
  4454 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"
  4455   by (induct xs) (auto simp:sorted_Cons set_insort)
  4456 
  4457 lemma sorted_insort: "sorted (insort x xs) = sorted xs"
  4458   using sorted_insort_key [where f="\<lambda>x. x"] by simp
  4459 
  4460 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"
  4461   by (induct xs) (auto simp:sorted_insort_key)
  4462 
  4463 theorem sorted_sort [simp]: "sorted (sort xs)"
  4464   using sorted_sort_key [where f="\<lambda>x. x"] by simp
  4465 
  4466 lemma sorted_butlast:
  4467   assumes "xs \<noteq> []" and "sorted xs"
  4468   shows "sorted (butlast xs)"
  4469 proof -
  4470   from `xs \<noteq> []` obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
  4471   with `sorted xs` show ?thesis by (simp add: sorted_append)
  4472 qed
  4473   
  4474 lemma insort_not_Nil [simp]:
  4475   "insort_key f a xs \<noteq> []"
  4476   by (induct xs) simp_all
  4477 
  4478 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
  4479 by (cases xs) auto
  4480 
  4481 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"
  4482   by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)
  4483 
  4484 lemma sorted_map_remove1:
  4485   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"
  4486   by (induct xs) (auto simp add: sorted_Cons)
  4487 
  4488 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"
  4489   using sorted_map_remove1 [of "\<lambda>x. x"] by simp
  4490 
  4491 lemma insort_key_remove1:
  4492   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"
  4493   shows "insort_key f a (remove1 a xs) = xs"
  4494 using assms proof (induct xs)
  4495   case (Cons x xs)
  4496   then show ?case
  4497   proof (cases "x = a")
  4498     case False
  4499     then have "f x \<noteq> f a" using Cons.prems by auto
  4500     then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons)
  4501     with `f x \<noteq> f a` show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons)
  4502   qed (auto simp: sorted_Cons insort_is_Cons)
  4503 qed simp
  4504 
  4505 lemma insort_remove1:
  4506   assumes "a \<in> set xs" and "sorted xs"
  4507   shows "insort a (remove1 a xs) = xs"
  4508 proof (rule insort_key_remove1)
  4509   from `a \<in> set xs` show "a \<in> set xs" .
  4510   from `sorted xs` show "sorted (map (\<lambda>x. x) xs)" by simp
  4511   from `a \<in> set xs` have "a \<in> set (filter (op = a) xs)" by auto
  4512   then have "set (filter (op = a) xs) \<noteq> {}" by auto
  4513   then have "filter (op = a) xs \<noteq> []" by (auto simp only: set_empty)
  4514   then have "length (filter (op = a) xs) > 0" by simp
  4515   then obtain n where n: "Suc n = length (filter (op = a) xs)"
  4516     by (cases "length (filter (op = a) xs)") simp_all
  4517   moreover have "replicate (Suc n) a = a # replicate n a"
  4518     by simp
  4519   ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)
  4520 qed
  4521 
  4522 lemma sorted_remdups[simp]:
  4523   "sorted l \<Longrightarrow> sorted (remdups l)"
  4524 by (induct l) (auto simp: sorted_Cons)
  4525 
  4526 lemma sorted_distinct_set_unique:
  4527 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"
  4528 shows "xs = ys"
  4529 proof -
  4530   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  4531   from assms show ?thesis
  4532   proof(induct rule:list_induct2[OF 1])
  4533     case 1 show ?case by simp
  4534   next
  4535     case 2 thus ?case by (simp add:sorted_Cons)
  4536        (metis Diff_insert_absorb antisym insertE insert_iff)
  4537   qed
  4538 qed
  4539 
  4540 lemma map_sorted_distinct_set_unique:
  4541   assumes "inj_on f (set xs \<union> set ys)"
  4542   assumes "sorted (map f xs)" "distinct (map f xs)"
  4543     "sorted (map f ys)" "distinct (map f ys)"
  4544   assumes "set xs = set ys"
  4545   shows "xs = ys"
  4546 proof -
  4547   from assms have "map f xs = map f ys"
  4548     by (simp add: sorted_distinct_set_unique)
  4549   moreover with `inj_on f (set xs \<union> set ys)` show "xs = ys"
  4550     by (blast intro: map_inj_on)
  4551 qed
  4552 
  4553 lemma finite_sorted_distinct_unique:
  4554 shows "finite A \<Longrightarrow> EX! xs. set xs = A & sorted xs & distinct xs"
  4555 apply(drule finite_distinct_list)
  4556 apply clarify
  4557 apply(rule_tac a="sort xs" in ex1I)
  4558 apply (auto simp: sorted_distinct_set_unique)
  4559 done
  4560 
  4561 lemma
  4562   assumes "sorted xs"
  4563   shows sorted_take: "sorted (take n xs)"
  4564   and sorted_drop: "sorted (drop n xs)"
  4565 proof -
  4566   from assms have "sorted (take n xs @ drop n xs)" by simp
  4567   then show "sorted (take n xs)" and "sorted (drop n xs)"
  4568     unfolding sorted_append by simp_all
  4569 qed
  4570 
  4571 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"
  4572   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)
  4573 
  4574 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"
  4575   by (subst takeWhile_eq_take) (auto dest: sorted_take)
  4576 
  4577 lemma sorted_filter:
  4578   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"
  4579   by (induct xs) (simp_all add: sorted_Cons)
  4580 
  4581 lemma foldr_max_sorted:
  4582   assumes "sorted (rev xs)"
  4583   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"
  4584 using assms proof (induct xs)
  4585   case (Cons x xs)
  4586   moreover hence "sorted (rev xs)" using sorted_append by auto
  4587   ultimately show ?case
  4588     by (cases xs, auto simp add: sorted_append max_def)
  4589 qed simp
  4590 
  4591 lemma filter_equals_takeWhile_sorted_rev:
  4592   assumes sorted: "sorted (rev (map f xs))"
  4593   shows "[x \<leftarrow> xs. t < f x] = takeWhile (\<lambda> x. t < f x) xs"
  4594     (is "filter ?P xs = ?tW")
  4595 proof (rule takeWhile_eq_filter[symmetric])
  4596   let "?dW" = "dropWhile ?P xs"
  4597   fix x assume "x \<in> set ?dW"
  4598   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"
  4599     unfolding in_set_conv_nth by auto
  4600   hence "length ?tW + i < length (?tW @ ?dW)"
  4601     unfolding length_append by simp
  4602   hence i': "length (map f ?tW) + i < length (map f xs)" by simp
  4603   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>
  4604         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"
  4605     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]
  4606     unfolding map_append[symmetric] by simp
  4607   hence "f x \<le> f (?dW ! 0)"
  4608     unfolding nth_append_length_plus nth_i
  4609     using i preorder_class.le_less_trans[OF le0 i] by simp
  4610   also have "... \<le> t"
  4611     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]
  4612     using hd_conv_nth[of "?dW"] by simp
  4613   finally show "\<not> t < f x" by simp
  4614 qed
  4615 
  4616 lemma insort_insert_key_triv:
  4617   "f x \<in> f ` set xs \<Longrightarrow> insort_insert_key f x xs = xs"
  4618   by (simp add: insort_insert_key_def)
  4619 
  4620 lemma insort_insert_triv:
  4621   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"
  4622   using insort_insert_key_triv [of "\<lambda>x. x"] by simp
  4623 
  4624 lemma insort_insert_insort_key:
  4625   "f x \<notin> f ` set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"
  4626   by (simp add: insort_insert_key_def)
  4627 
  4628 lemma insort_insert_insort:
  4629   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"
  4630   using insort_insert_insort_key [of "\<lambda>x. x"] by simp
  4631 
  4632 lemma set_insort_insert:
  4633   "set (insort_insert x xs) = insert x (set xs)"
  4634   by (auto simp add: insort_insert_key_def set_insort)
  4635 
  4636 lemma distinct_insort_insert:
  4637   assumes "distinct xs"
  4638   shows "distinct (insort_insert_key f x xs)"
  4639   using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)
  4640 
  4641 lemma sorted_insort_insert_key:
  4642   assumes "sorted (map f xs)"
  4643   shows "sorted (map f (insort_insert_key f x xs))"
  4644   using assms by (simp add: insort_insert_key_def sorted_insort_key)
  4645 
  4646 lemma sorted_insort_insert:
  4647   assumes "sorted xs"
  4648   shows "sorted (insort_insert x xs)"
  4649   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp
  4650 
  4651 lemma filter_insort_triv:
  4652   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
  4653   by (induct xs) simp_all
  4654 
  4655 lemma filter_insort:
  4656   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
  4657   using assms by (induct xs)
  4658     (auto simp add: sorted_Cons, subst insort_is_Cons, auto)
  4659 
  4660 lemma filter_sort:
  4661   "filter P (sort_key f xs) = sort_key f (filter P xs)"
  4662   by (induct xs) (simp_all add: filter_insort_triv filter_insort)
  4663 
  4664 lemma sorted_map_same:
  4665   "sorted (map f [x\<leftarrow>xs. f x = g xs])"
  4666 proof (induct xs arbitrary: g)
  4667   case Nil then show ?case by simp
  4668 next
  4669   case (Cons x xs)
  4670   then have "sorted (map f [y\<leftarrow>xs . f y = (\<lambda>xs. f x) xs])" .
  4671   moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g \<circ> Cons x) xs])" .
  4672   ultimately show ?case by (simp_all add: sorted_Cons)
  4673 qed
  4674 
  4675 lemma sorted_same:
  4676   "sorted [x\<leftarrow>xs. x = g xs]"
  4677   using sorted_map_same [of "\<lambda>x. x"] by simp
  4678 
  4679 lemma remove1_insort [simp]:
  4680   "remove1 x (insort x xs) = xs"
  4681   by (induct xs) simp_all
  4682 
  4683 end
  4684 
  4685 lemma sorted_upt[simp]: "sorted[i..<j]"
  4686 by (induct j) (simp_all add:sorted_append)
  4687 
  4688 lemma sorted_upto[simp]: "sorted[i..j]"
  4689 apply(induct i j rule:upto.induct)
  4690 apply(subst upto.simps)
  4691 apply(simp add:sorted_Cons)
  4692 done
  4693 
  4694 
  4695 subsubsection {* @{const transpose} on sorted lists *}
  4696 
  4697 lemma sorted_transpose[simp]:
  4698   shows "sorted (rev (map length (transpose xs)))"
  4699   by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose
  4700     length_filter_conv_card intro: card_mono)
  4701 
  4702 lemma transpose_max_length:
  4703   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x \<noteq> []]"
  4704   (is "?L = ?R")
  4705 proof (cases "transpose xs = []")
  4706   case False
  4707   have "?L = foldr max (map length (transpose xs)) 0"
  4708     by (simp add: foldr_map comp_def)
  4709   also have "... = length (transpose xs ! 0)"
  4710     using False sorted_transpose by (simp add: foldr_max_sorted)
  4711   finally show ?thesis
  4712     using False by (simp add: nth_transpose)
  4713 next
  4714   case True
  4715   hence "[x \<leftarrow> xs. x \<noteq> []] = []"
  4716     by (auto intro!: filter_False simp: transpose_empty)
  4717   thus ?thesis by (simp add: transpose_empty True)
  4718 qed
  4719 
  4720 lemma length_transpose_sorted:
  4721   fixes xs :: "'a list list"
  4722   assumes sorted: "sorted (rev (map length xs))"
  4723   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"
  4724 proof (cases "xs = []")
  4725   case False
  4726   thus ?thesis
  4727     using foldr_max_sorted[OF sorted] False
  4728     unfolding length_transpose foldr_map comp_def
  4729     by simp
  4730 qed simp
  4731 
  4732 lemma nth_nth_transpose_sorted[simp]:
  4733   fixes xs :: "'a list list"
  4734   assumes sorted: "sorted (rev (map length xs))"
  4735   and i: "i < length (transpose xs)"
  4736   and j: "j < length [ys \<leftarrow> xs. i < length ys]"
  4737   shows "transpose xs ! i ! j = xs ! j  ! i"
  4738   using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]
  4739     nth_transpose[OF i] nth_map[OF j]
  4740   by (simp add: takeWhile_nth)
  4741 
  4742 lemma transpose_column_length:
  4743   fixes xs :: "'a list list"
  4744   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
  4745   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"
  4746 proof -
  4747   have "xs \<noteq> []" using `i < length xs` by auto
  4748   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]
  4749   { fix j assume "j \<le> i"
  4750     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this `i < length xs`]
  4751   } note sortedE = this[consumes 1]
  4752 
  4753   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}
  4754     = {..< length (xs ! i)}"
  4755   proof safe
  4756     fix j
  4757     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"
  4758     with this(2) nth_transpose[OF this(1)]
  4759     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp
  4760     from nth_mem[OF this] takeWhile_nth[OF this]
  4761     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)
  4762   next
  4763     fix j assume "j < length (xs ! i)"
  4764     thus "j < length (transpose xs)"
  4765       using foldr_max_sorted[OF sorted] `xs \<noteq> []` sortedE[OF le0]
  4766       by (auto simp: length_transpose comp_def foldr_map)
  4767 
  4768     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"
  4769       using `i < length xs` `j < length (xs ! i)` less_Suc_eq_le
  4770       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)
  4771     with nth_transpose[OF `j < length (transpose xs)`]
  4772     show "i < length (transpose xs ! j)" by simp
  4773   qed
  4774   thus ?thesis by (simp add: length_filter_conv_card)
  4775 qed
  4776 
  4777 lemma transpose_column:
  4778   fixes xs :: "'a list list"
  4779   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
  4780   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))
  4781     = xs ! i" (is "?R = _")
  4782 proof (rule nth_equalityI, safe)
  4783   show length: "length ?R = length (xs ! i)"
  4784     using transpose_column_length[OF assms] by simp
  4785 
  4786   fix j assume j: "j < length ?R"
  4787   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]
  4788   from j have j_less: "j < length (xs ! i)" using length by simp
  4789   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"
  4790   proof (rule length_takeWhile_less_P_nth)
  4791     show "Suc i \<le> length xs" using `i < length xs` by simp
  4792     fix k assume "k < Suc i"
  4793     hence "k \<le> i" by auto
  4794     with sorted_rev_nth_mono[OF sorted this] `i < length xs`
  4795     have "length (xs ! i) \<le> length (xs ! k)" by simp
  4796     thus "Suc j \<le> length (xs ! k)" using j_less by simp
  4797   qed
  4798   have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]"
  4799     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]
  4800     using i_less_tW by (simp_all add: Suc_le_eq)
  4801   from j show "?R ! j = xs ! i ! j"
  4802     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]
  4803     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])
  4804 qed
  4805 
  4806 lemma transpose_transpose:
  4807   fixes xs :: "'a list list"
  4808   assumes sorted: "sorted (rev (map length xs))"
  4809   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")
  4810 proof -
  4811   have len: "length ?L = length ?R"
  4812     unfolding length_transpose transpose_max_length
  4813     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]
  4814     by simp
  4815 
  4816   { fix i assume "i < length ?R"
  4817     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]
  4818     have "i < length xs" by simp
  4819   } note * = this
  4820   show ?thesis
  4821     by (rule nth_equalityI)
  4822        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)
  4823 qed
  4824 
  4825 theorem transpose_rectangle:
  4826   assumes "xs = [] \<Longrightarrow> n = 0"
  4827   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"
  4828   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"
  4829     (is "?trans = ?map")
  4830 proof (rule nth_equalityI)
  4831   have "sorted (rev (map length xs))"
  4832     by (auto simp: rev_nth rect intro!: sorted_nth_monoI)
  4833   from foldr_max_sorted[OF this] assms
  4834   show len: "length ?trans = length ?map"
  4835     by (simp_all add: length_transpose foldr_map comp_def)
  4836   moreover
  4837   { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs"
  4838       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }
  4839   ultimately show "\<forall>i < length ?trans. ?trans ! i = ?map ! i"
  4840     by (auto simp: nth_transpose intro: nth_equalityI)
  4841 qed
  4842 
  4843 
  4844 subsubsection {* @{text sorted_list_of_set} *}
  4845 
  4846 text{* This function maps (finite) linearly ordered sets to sorted
  4847 lists. Warning: in most cases it is not a good idea to convert from
  4848 sets to lists but one should convert in the other direction (via
  4849 @{const set}). *}
  4850 
  4851 subsubsection {* @{text sorted_list_of_set} *}
  4852 
  4853 text{* This function maps (finite) linearly ordered sets to sorted
  4854 lists. Warning: in most cases it is not a good idea to convert from
  4855 sets to lists but one should convert in the other direction (via
  4856 @{const set}). *}
  4857 
  4858 definition (in linorder) sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
  4859   "sorted_list_of_set = folding.F insort []"
  4860 
  4861 sublocale linorder < sorted_list_of_set!: folding insort Nil
  4862 where
  4863   "folding.F insort [] = sorted_list_of_set"
  4864 proof -
  4865   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
  4866   show "folding insort" by default (fact comp_fun_commute)
  4867   show "folding.F insort [] = sorted_list_of_set" by (simp only: sorted_list_of_set_def)
  4868 qed
  4869 
  4870 context linorder
  4871 begin
  4872 
  4873 lemma sorted_list_of_set_empty:
  4874   "sorted_list_of_set {} = []"
  4875   by (fact sorted_list_of_set.empty)
  4876 
  4877 lemma sorted_list_of_set_insert [simp]:
  4878   assumes "finite A"
  4879   shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"
  4880   using assms by (fact sorted_list_of_set.insert_remove)
  4881 
  4882 lemma sorted_list_of_set [simp]:
  4883   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A) 
  4884     \<and> distinct (sorted_list_of_set A)"
  4885   by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)
  4886 
  4887 lemma sorted_list_of_set_sort_remdups [code]:
  4888   "sorted_list_of_set (set xs) = sort (remdups xs)"
  4889 proof -
  4890   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
  4891   show ?thesis by (simp add: sorted_list_of_set.eq_fold sort_conv_fold fold_set_fold_remdups)
  4892 qed
  4893 
  4894 lemma sorted_list_of_set_remove:
  4895   assumes "finite A"
  4896   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"
  4897 proof (cases "x \<in> A")
  4898   case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp
  4899   with False show ?thesis by (simp add: remove1_idem)
  4900 next
  4901   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)
  4902   with assms show ?thesis by simp
  4903 qed
  4904 
  4905 end
  4906 
  4907 lemma sorted_list_of_set_range [simp]:
  4908   "sorted_list_of_set {m..<n} = [m..<n]"
  4909   by (rule sorted_distinct_set_unique) simp_all
  4910 
  4911 
  4912 subsubsection {* @{text lists}: the list-forming operator over sets *}
  4913 
  4914 inductive_set
  4915   lists :: "'a set => 'a list set"
  4916   for A :: "'a set"
  4917 where
  4918     Nil [intro!, simp]: "[]: lists A"
  4919   | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"
  4920 
  4921 inductive_cases listsE [elim!,no_atp]: "x#l : lists A"
  4922 inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"
  4923 
  4924 inductive_simps listsp_simps[code]:
  4925   "listsp A []"
  4926   "listsp A (x # xs)"
  4927 
  4928 lemma listsp_mono [mono]: "A \<le> B ==> listsp A \<le> listsp B"
  4929 by (rule predicate1I, erule listsp.induct, blast+)
  4930 
  4931 lemmas lists_mono = listsp_mono [to_set]
  4932 
  4933 lemma listsp_infI:
  4934   assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using l
  4935 by induct blast+
  4936 
  4937 lemmas lists_IntI = listsp_infI [to_set]
  4938 
  4939 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"
  4940 proof (rule mono_inf [where f=listsp, THEN order_antisym])
  4941   show "mono listsp" by (simp add: mono_def listsp_mono)
  4942   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI)
  4943 qed
  4944 
  4945 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]
  4946 
  4947 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]
  4948 
  4949 lemma Cons_in_lists_iff[simp]: "x#xs : lists A \<longleftrightarrow> x:A \<and> xs : lists A"
  4950 by auto
  4951 
  4952 lemma append_in_listsp_conv [iff]:
  4953      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"
  4954 by (induct xs) auto
  4955 
  4956 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]
  4957 
  4958 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"
  4959 -- {* eliminate @{text listsp} in favour of @{text set} *}
  4960 by (induct xs) auto
  4961 
  4962 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]
  4963 
  4964 lemma in_listspD [dest!,no_atp]: "listsp A xs ==> \<forall>x\<in>set xs. A x"
  4965 by (rule in_listsp_conv_set [THEN iffD1])
  4966 
  4967 lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]
  4968 
  4969 lemma in_listspI [intro!,no_atp]: "\<forall>x\<in>set xs. A x ==> listsp A xs"
  4970 by (rule in_listsp_conv_set [THEN iffD2])
  4971 
  4972 lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]
  4973 
  4974 lemma lists_eq_set: "lists A = {xs. set xs <= A}"
  4975 by auto
  4976 
  4977 lemma lists_empty [simp]: "lists {} = {[]}"
  4978 by auto
  4979 
  4980 lemma lists_UNIV [simp]: "lists UNIV = UNIV"
  4981 by auto
  4982 
  4983 lemma lists_image: "lists (f`A) = map f ` lists A"
  4984 proof -
  4985   { fix xs have "\<forall>x\<in>set xs. x \<in> f ` A \<Longrightarrow> xs \<in> map f ` lists A"
  4986       by (induct xs) (auto simp del: map.simps simp add: map.simps[symmetric] intro!: imageI) }
  4987   then show ?thesis by auto
  4988 qed
  4989 
  4990 subsubsection {* Inductive definition for membership *}
  4991 
  4992 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  4993 where
  4994     elem:  "ListMem x (x # xs)"
  4995   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"
  4996 
  4997 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"
  4998 apply (rule iffI)
  4999  apply (induct set: ListMem)
  5000   apply auto
  5001 apply (induct xs)
  5002  apply (auto intro: ListMem.intros)
  5003 done
  5004 
  5005 
  5006 subsubsection {* Lists as Cartesian products *}
  5007 
  5008 text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from
  5009 @{term A} and tail drawn from @{term Xs}.*}
  5010 
  5011 definition set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where
  5012 "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"
  5013 
  5014 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])`A"
  5015 by (auto simp add: set_Cons_def)
  5016 
  5017 text{*Yields the set of lists, all of the same length as the argument and
  5018 with elements drawn from the corresponding element of the argument.*}
  5019 
  5020 primrec listset :: "'a set list \<Rightarrow> 'a list set" where
  5021 "listset [] = {[]}" |
  5022 "listset (A # As) = set_Cons A (listset As)"
  5023 
  5024 
  5025 subsection {* Relations on Lists *}
  5026 
  5027 subsubsection {* Length Lexicographic Ordering *}
  5028 
  5029 text{*These orderings preserve well-foundedness: shorter lists 
  5030   precede longer lists. These ordering are not used in dictionaries.*}
  5031         
  5032 primrec -- {*The lexicographic ordering for lists of the specified length*}
  5033   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where
  5034 "lexn r 0 = {}" |
  5035 "lexn r (Suc n) =
  5036   (map_pair (%(x, xs). x#xs) (%(x, xs). x#xs) ` (r <*lex*> lexn r n)) Int
  5037   {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"
  5038 
  5039 definition lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5040 "lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}
  5041 
  5042 definition lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where
  5043 "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"
  5044         -- {*Compares lists by their length and then lexicographically*}
  5045 
  5046 lemma wf_lexn: "wf r ==> wf (lexn r n)"
  5047 apply (induct n, simp, simp)
  5048 apply(rule wf_subset)
  5049  prefer 2 apply (rule Int_lower1)
  5050 apply(rule wf_map_pair_image)
  5051  prefer 2 apply (rule inj_onI, auto)
  5052 done
  5053 
  5054 lemma lexn_length:
  5055   "(xs, ys) : lexn r n ==> length xs = n \<and> length ys = n"
  5056 by (induct n arbitrary: xs ys) auto
  5057 
  5058 lemma wf_lex [intro!]: "wf r ==> wf (lex r)"
  5059 apply (unfold lex_def)
  5060 apply (rule wf_UN)
  5061 apply (blast intro: wf_lexn, clarify)
  5062 apply (rename_tac m n)
  5063 apply (subgoal_tac "m \<noteq> n")
  5064  prefer 2 apply blast
  5065 apply (blast dest: lexn_length not_sym)
  5066 done
  5067 
  5068 lemma lexn_conv:
  5069   "lexn r n =
  5070     {(xs,ys). length xs = n \<and> length ys = n \<and>
  5071     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y):r)}"
  5072 apply (induct n, simp)
  5073 apply (simp add: image_Collect lex_prod_def, safe, blast)
  5074  apply (rule_tac x = "ab # xys" in exI, simp)
  5075 apply (case_tac xys, simp_all, blast)
  5076 done
  5077 
  5078 lemma lex_conv:
  5079   "lex r =
  5080     {(xs,ys). length xs = length ys \<and>
  5081     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y):r)}"
  5082 by (force simp add: lex_def lexn_conv)
  5083 
  5084 lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"
  5085 by (unfold lenlex_def) blast
  5086 
  5087 lemma lenlex_conv:
  5088     "lenlex r = {(xs,ys). length xs < length ys |
  5089                  length xs = length ys \<and> (xs, ys) : lex r}"
  5090 by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)
  5091 
  5092 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"
  5093 by (simp add: lex_conv)
  5094 
  5095 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"
  5096 by (simp add:lex_conv)
  5097 
  5098 lemma Cons_in_lex [simp]:
  5099     "((x # xs, y # ys) : lex r) =
  5100       ((x, y) : r \<and> length xs = length ys | x = y \<and> (xs, ys) : lex r)"
  5101 apply (simp add: lex_conv)
  5102 apply (rule iffI)
  5103  prefer 2 apply (blast intro: Cons_eq_appendI, clarify)
  5104 apply (case_tac xys, simp, simp)
  5105 apply blast
  5106 done
  5107 
  5108 
  5109 subsubsection {* Lexicographic Ordering *}
  5110 
  5111 text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".
  5112     This ordering does \emph{not} preserve well-foundedness.
  5113      Author: N. Voelker, March 2005. *} 
  5114 
  5115 definition lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5116 "lexord r = {(x,y). \<exists> a v. y = x @ a # v \<or>
  5117             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"
  5118 
  5119 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"
  5120 by (unfold lexord_def, induct_tac y, auto) 
  5121 
  5122 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"
  5123 by (unfold lexord_def, induct_tac x, auto)
  5124 
  5125 lemma lexord_cons_cons[simp]:
  5126      "((a # x, b # y) \<in> lexord r) = ((a,b)\<in> r | (a = b & (x,y)\<in> lexord r))"
  5127   apply (unfold lexord_def, safe, simp_all)
  5128   apply (case_tac u, simp, simp)
  5129   apply (case_tac u, simp, clarsimp, blast, blast, clarsimp)
  5130   apply (erule_tac x="b # u" in allE)
  5131   by force
  5132 
  5133 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons
  5134 
  5135 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"
  5136 by (induct_tac x, auto)  
  5137 
  5138 lemma lexord_append_left_rightI:
  5139      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"
  5140 by (induct_tac u, auto)
  5141 
  5142 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"
  5143 by (induct x, auto)
  5144 
  5145 lemma lexord_append_leftD:
  5146      "\<lbrakk> (x @ u, x @ v) \<in> lexord r; (! a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"
  5147 by (erule rev_mp, induct_tac x, auto)
  5148 
  5149 lemma lexord_take_index_conv: 
  5150    "((x,y) : lexord r) = 
  5151     ((length x < length y \<and> take (length x) y = x) \<or> 
  5152      (\<exists>i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) \<in> r))"
  5153   apply (unfold lexord_def Let_def, clarsimp) 
  5154   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)
  5155   apply auto 
  5156   apply (rule_tac x="hd (drop (length x) y)" in exI)
  5157   apply (rule_tac x="tl (drop (length x) y)" in exI)
  5158   apply (erule subst, simp add: min_def) 
  5159   apply (rule_tac x ="length u" in exI, simp) 
  5160   apply (rule_tac x ="take i x" in exI) 
  5161   apply (rule_tac x ="x ! i" in exI) 
  5162   apply (rule_tac x ="y ! i" in exI, safe) 
  5163   apply (rule_tac x="drop (Suc i) x" in exI)
  5164   apply (drule sym, simp add: drop_Suc_conv_tl) 
  5165   apply (rule_tac x="drop (Suc i) y" in exI)
  5166   by (simp add: drop_Suc_conv_tl) 
  5167 
  5168 -- {* lexord is extension of partial ordering List.lex *} 
  5169 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"
  5170   apply (rule_tac x = y in spec) 
  5171   apply (induct_tac x, clarsimp) 
  5172   by (clarify, case_tac x, simp, force)
  5173 
  5174 lemma lexord_irreflexive: "ALL x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"
  5175 by (induct xs) auto
  5176 
  5177 text{* By Ren\'e Thiemann: *}
  5178 lemma lexord_partial_trans: 
  5179   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)
  5180    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"
  5181 proof (induct xs arbitrary: ys zs)
  5182   case Nil
  5183   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)
  5184 next
  5185   case (Cons x xs yys zzs)
  5186   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def
  5187     by (cases yys, auto)
  5188   note Cons = Cons[unfolded yys]
  5189   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto
  5190   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def
  5191     by (cases zzs, auto)
  5192   note Cons = Cons[unfolded zzs]
  5193   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto
  5194   {
  5195     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"
  5196     from Cons(1)[OF _ this] Cons(2)
  5197     have "(xs,zs) \<in> lexord r" by auto
  5198   } note ind1 = this
  5199   {
  5200     assume "(x,y) \<in> r" and "(y,z) \<in> r"
  5201     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto
  5202   } note ind2 = this
  5203   from one two ind1 ind2
  5204   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast
  5205   thus ?case unfolding zzs by auto
  5206 qed
  5207 
  5208 lemma lexord_trans: 
  5209     "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"
  5210 by(auto simp: trans_def intro:lexord_partial_trans)
  5211 
  5212 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"
  5213 by (rule transI, drule lexord_trans, blast) 
  5214 
  5215 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"
  5216   apply (rule_tac x = y in spec) 
  5217   apply (induct_tac x, rule allI) 
  5218   apply (case_tac x, simp, simp) 
  5219   apply (rule allI, case_tac x, simp, simp) 
  5220   by blast
  5221 
  5222 
  5223 subsubsection {* Lexicographic combination of measure functions *}
  5224 
  5225 text {* These are useful for termination proofs *}
  5226 
  5227 definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"
  5228 
  5229 lemma wf_measures[simp]: "wf (measures fs)"
  5230 unfolding measures_def
  5231 by blast
  5232 
  5233 lemma in_measures[simp]: 
  5234   "(x, y) \<in> measures [] = False"
  5235   "(x, y) \<in> measures (f # fs)
  5236          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"  
  5237 unfolding measures_def
  5238 by auto
  5239 
  5240 lemma measures_less: "f x < f y ==> (x, y) \<in> measures (f#fs)"
  5241 by simp
  5242 
  5243 lemma measures_lesseq: "f x <= f y ==> (x, y) \<in> measures fs ==> (x, y) \<in> measures (f#fs)"
  5244 by auto
  5245 
  5246 
  5247 subsubsection {* Lifting Relations to Lists: one element *}
  5248 
  5249 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5250 "listrel1 r = {(xs,ys).
  5251    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"
  5252 
  5253 lemma listrel1I:
  5254   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>
  5255   (xs, ys) \<in> listrel1 r"
  5256 unfolding listrel1_def by auto
  5257 
  5258 lemma listrel1E:
  5259   "\<lbrakk> (xs, ys) \<in> listrel1 r;
  5260      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P
  5261    \<rbrakk> \<Longrightarrow> P"
  5262 unfolding listrel1_def by auto
  5263 
  5264 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"
  5265 unfolding listrel1_def by blast
  5266 
  5267 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"
  5268 unfolding listrel1_def by blast
  5269 
  5270 lemma Cons_listrel1_Cons [iff]:
  5271   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>
  5272    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"
  5273 by (simp add: listrel1_def Cons_eq_append_conv) (blast)
  5274 
  5275 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"
  5276 by (metis Cons_listrel1_Cons)
  5277 
  5278 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"
  5279 by (metis Cons_listrel1_Cons)
  5280 
  5281 lemma append_listrel1I:
  5282   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r
  5283     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"
  5284 unfolding listrel1_def
  5285 by auto (blast intro: append_eq_appendI)+
  5286 
  5287 lemma Cons_listrel1E1[elim!]:
  5288   assumes "(x # xs, ys) \<in> listrel1 r"
  5289     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
  5290     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"
  5291   shows R
  5292 using assms by (cases ys) blast+
  5293 
  5294 lemma Cons_listrel1E2[elim!]:
  5295   assumes "(xs, y # ys) \<in> listrel1 r"
  5296     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
  5297     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"
  5298   shows R
  5299 using assms by (cases xs) blast+
  5300 
  5301 lemma snoc_listrel1_snoc_iff:
  5302   "(xs @ [x], ys @ [y]) \<in> listrel1 r
  5303     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")
  5304 proof
  5305   assume ?L thus ?R
  5306     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)
  5307 next
  5308   assume ?R then show ?L unfolding listrel1_def by force
  5309 qed
  5310 
  5311 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"
  5312 unfolding listrel1_def by auto
  5313 
  5314 lemma listrel1_mono:
  5315   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"
  5316 unfolding listrel1_def by blast
  5317 
  5318 
  5319 lemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"
  5320 unfolding listrel1_def by blast
  5321 
  5322 lemma in_listrel1_converse:
  5323   "(x,y) : listrel1 (r^-1) \<longleftrightarrow> (x,y) : (listrel1 r)^-1"
  5324 unfolding listrel1_def by blast
  5325 
  5326 lemma listrel1_iff_update:
  5327   "(xs,ys) \<in> (listrel1 r)
  5328    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")
  5329 proof
  5330   assume "?L"
  5331   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"
  5332     unfolding listrel1_def by auto
  5333   then have "ys = xs[length u := y]" and "length u < length xs"
  5334     and "(xs ! length u, y) \<in> r" by auto
  5335   then show "?R" by auto
  5336 next
  5337   assume "?R"
  5338   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"
  5339     by auto
  5340   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"
  5341     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)
  5342   then show "?L" by (auto simp: listrel1_def)
  5343 qed
  5344 
  5345 
  5346 text{* Accessible part and wellfoundedness: *}
  5347 
  5348 lemma Cons_acc_listrel1I [intro!]:
  5349   "x \<in> acc r \<Longrightarrow> xs \<in> acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> acc (listrel1 r)"
  5350 apply (induct arbitrary: xs set: acc)
  5351 apply (erule thin_rl)
  5352 apply (erule acc_induct)
  5353 apply (rule accI)
  5354 apply (blast)
  5355 done
  5356 
  5357 lemma lists_accD: "xs \<in> lists (acc r) \<Longrightarrow> xs \<in> acc (listrel1 r)"
  5358 apply (induct set: lists)
  5359  apply (rule accI)
  5360  apply simp
  5361 apply (rule accI)
  5362 apply (fast dest: acc_downward)
  5363 done
  5364 
  5365 lemma lists_accI: "xs \<in> acc (listrel1 r) \<Longrightarrow> xs \<in> lists (acc r)"
  5366 apply (induct set: acc)
  5367 apply clarify
  5368 apply (rule accI)
  5369 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)
  5370 done
  5371 
  5372 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"
  5373 by(metis wf_acc_iff in_lists_conv_set lists_accI lists_accD Cons_in_lists_iff)
  5374 
  5375 
  5376 subsubsection {* Lifting Relations to Lists: all elements *}
  5377 
  5378 inductive_set
  5379   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"
  5380   for r :: "('a \<times> 'b) set"
  5381 where
  5382     Nil:  "([],[]) \<in> listrel r"
  5383   | Cons: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (x#xs, y#ys) \<in> listrel r"
  5384 
  5385 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"
  5386 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"
  5387 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"
  5388 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"
  5389 
  5390 
  5391 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"
  5392 by(induct rule: listrel.induct) auto
  5393 
  5394 lemma listrel_iff_zip [code_unfold]: "(xs,ys) : listrel r \<longleftrightarrow>
  5395   length xs = length ys & (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")
  5396 proof
  5397   assume ?L thus ?R by induct (auto intro: listrel_eq_len)
  5398 next
  5399   assume ?R thus ?L
  5400     apply (clarify)
  5401     by (induct rule: list_induct2) (auto intro: listrel.intros)
  5402 qed
  5403 
  5404 lemma listrel_iff_nth: "(xs,ys) : listrel r \<longleftrightarrow>
  5405   length xs = length ys & (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")
  5406 by (auto simp add: all_set_conv_all_nth listrel_iff_zip)
  5407 
  5408 
  5409 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"
  5410 apply clarify  
  5411 apply (erule listrel.induct)
  5412 apply (blast intro: listrel.intros)+
  5413 done
  5414 
  5415 lemma listrel_subset: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"
  5416 apply clarify 
  5417 apply (erule listrel.induct, auto) 
  5418 done
  5419 
  5420 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)" 
  5421 apply (simp add: refl_on_def listrel_subset Ball_def)
  5422 apply (rule allI) 
  5423 apply (induct_tac x) 
  5424 apply (auto intro: listrel.intros)
  5425 done
  5426 
  5427 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)" 
  5428 apply (auto simp add: sym_def)
  5429 apply (erule listrel.induct) 
  5430 apply (blast intro: listrel.intros)+
  5431 done
  5432 
  5433 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)" 
  5434 apply (simp add: trans_def)
  5435 apply (intro allI) 
  5436 apply (rule impI) 
  5437 apply (erule listrel.induct) 
  5438 apply (blast intro: listrel.intros)+
  5439 done
  5440 
  5441 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"
  5442 by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans) 
  5443 
  5444 lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"
  5445 using listrel_refl_on[of UNIV, OF refl_rtrancl]
  5446 by(auto simp: refl_on_def)
  5447 
  5448 lemma listrel_rtrancl_trans:
  5449   "\<lbrakk> (xs,ys) : listrel(r^*);  (ys,zs) : listrel(r^*) \<rbrakk>
  5450   \<Longrightarrow> (xs,zs) : listrel(r^*)"
  5451 by (metis listrel_trans trans_def trans_rtrancl)
  5452 
  5453 
  5454 lemma listrel_Nil [simp]: "listrel r `` {[]} = {[]}"
  5455 by (blast intro: listrel.intros)
  5456 
  5457 lemma listrel_Cons:
  5458      "listrel r `` {x#xs} = set_Cons (r``{x}) (listrel r `` {xs})"
  5459 by (auto simp add: set_Cons_def intro: listrel.intros)
  5460 
  5461 text {* Relating @{term listrel1}, @{term listrel} and closures: *}
  5462 
  5463 lemma listrel1_rtrancl_subset_rtrancl_listrel1:
  5464   "listrel1 (r^*) \<subseteq> (listrel1 r)^*"
  5465 proof (rule subrelI)
  5466   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r^*)"
  5467   { fix x y us vs
  5468     have "(x,y) : r^* \<Longrightarrow> (us @ x # vs, us @ y # vs) : (listrel1 r)^*"
  5469     proof(induct rule: rtrancl.induct)
  5470       case rtrancl_refl show ?case by simp
  5471     next
  5472       case rtrancl_into_rtrancl thus ?case
  5473         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)
  5474     qed }
  5475   thus "(xs,ys) \<in> (listrel1 r)^*" using 1 by(blast elim: listrel1E)
  5476 qed
  5477 
  5478 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)^* \<Longrightarrow> length x = length y"
  5479 by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)
  5480 
  5481 lemma rtrancl_listrel1_ConsI1:
  5482   "(xs,ys) : (listrel1 r)^* \<Longrightarrow> (x#xs,x#ys) : (listrel1 r)^*"
  5483 apply(induct rule: rtrancl.induct)
  5484  apply simp
  5485 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)
  5486 
  5487 lemma rtrancl_listrel1_ConsI2:
  5488   "(x,y) \<in> r^* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)^*
  5489   \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)^*"
  5490   by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1 
  5491     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])
  5492 
  5493 lemma listrel1_subset_listrel:
  5494   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"
  5495 by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)
  5496 
  5497 lemma listrel_reflcl_if_listrel1:
  5498   "(xs,ys) : listrel1 r \<Longrightarrow> (xs,ys) : listrel(r^*)"
  5499 by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)
  5500 
  5501 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"
  5502 proof
  5503   { fix x y assume "(x,y) \<in> listrel (r^*)"
  5504     then have "(x,y) \<in> (listrel1 r)^*"
  5505     by induct (auto intro: rtrancl_listrel1_ConsI2) }
  5506   then show "listrel (r^*) \<subseteq> (listrel1 r)^*"
  5507     by (rule subrelI)
  5508 next
  5509   show "listrel (r^*) \<supseteq> (listrel1 r)^*"
  5510   proof(rule subrelI)
  5511     fix xs ys assume "(xs,ys) \<in> (listrel1 r)^*"
  5512     then show "(xs,ys) \<in> listrel (r^*)"
  5513     proof induct
  5514       case base show ?case by(auto simp add: listrel_iff_zip set_zip)
  5515     next
  5516       case (step ys zs)
  5517       thus ?case  by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)
  5518     qed
  5519   qed
  5520 qed
  5521 
  5522 lemma rtrancl_listrel1_if_listrel:
  5523   "(xs,ys) : listrel r \<Longrightarrow> (xs,ys) : (listrel1 r)^*"
  5524 by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)
  5525 
  5526 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)^*"
  5527 by(fast intro:rtrancl_listrel1_if_listrel)
  5528 
  5529 
  5530 subsection {* Size function *}
  5531 
  5532 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"
  5533 by (rule is_measure_trivial)
  5534 
  5535 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (option_size f)"
  5536 by (rule is_measure_trivial)
  5537 
  5538 lemma list_size_estimation[termination_simp]: 
  5539   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < list_size f xs"
  5540 by (induct xs) auto
  5541 
  5542 lemma list_size_estimation'[termination_simp]: 
  5543   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> list_size f xs"
  5544 by (induct xs) auto
  5545 
  5546 lemma list_size_map[simp]: "list_size f (map g xs) = list_size (f o g) xs"
  5547 by (induct xs) auto
  5548 
  5549 lemma list_size_append[simp]: "list_size f (xs @ ys) = list_size f xs + list_size f ys"
  5550 by (induct xs, auto)
  5551 
  5552 lemma list_size_pointwise[termination_simp]: 
  5553   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"
  5554 by (induct xs) force+
  5555 
  5556 
  5557 subsection {* Monad operation *}
  5558 
  5559 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
  5560 "bind xs f = concat (map f xs)"
  5561 
  5562 hide_const (open) bind
  5563 
  5564 lemma bind_simps [simp]:
  5565   "List.bind [] f = []"
  5566   "List.bind (x # xs) f = f x @ List.bind xs f"
  5567   by (simp_all add: bind_def)
  5568 
  5569 
  5570 subsection {* Transfer *}
  5571 
  5572 definition embed_list :: "nat list \<Rightarrow> int list" where
  5573 "embed_list l = map int l"
  5574 
  5575 definition nat_list :: "int list \<Rightarrow> bool" where
  5576 "nat_list l = nat_set (set l)"
  5577 
  5578 definition return_list :: "int list \<Rightarrow> nat list" where
  5579 "return_list l = map nat l"
  5580 
  5581 lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>
  5582     embed_list (return_list l) = l"
  5583   unfolding embed_list_def return_list_def nat_list_def nat_set_def
  5584   apply (induct l)
  5585   apply auto
  5586 done
  5587 
  5588 lemma transfer_nat_int_list_functions:
  5589   "l @ m = return_list (embed_list l @ embed_list m)"
  5590   "[] = return_list []"
  5591   unfolding return_list_def embed_list_def
  5592   apply auto
  5593   apply (induct l, auto)
  5594   apply (induct m, auto)
  5595 done
  5596 
  5597 (*
  5598 lemma transfer_nat_int_fold1: "fold f l x =
  5599     fold (%x. f (nat x)) (embed_list l) x";
  5600 *)
  5601 
  5602 
  5603 subsection {* Code generation *}
  5604 
  5605 subsubsection {* Counterparts for set-related operations *}
  5606 
  5607 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
  5608 [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"
  5609 
  5610 text {*
  5611   Use @{text member} only for generating executable code.  Otherwise use
  5612   @{prop "x \<in> set xs"} instead --- it is much easier to reason about.
  5613 *}
  5614 
  5615 lemma member_rec [code]:
  5616   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"
  5617   "member [] y \<longleftrightarrow> False"
  5618   by (auto simp add: member_def)
  5619 
  5620 lemma in_set_member (* FIXME delete candidate *):
  5621   "x \<in> set xs \<longleftrightarrow> member xs x"
  5622   by (simp add: member_def)
  5623 
  5624 definition list_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  5625 list_all_iff [code_abbrev]: "list_all P xs \<longleftrightarrow> Ball (set xs) P"
  5626 
  5627 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  5628 list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"
  5629 
  5630 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  5631 list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"
  5632 
  5633 text {*
  5634   Usually you should prefer @{text "\<forall>x\<in>set xs"}, @{text "\<exists>x\<in>set xs"}
  5635   and @{text "\<exists>!x. x\<in>set xs \<and> _"} over @{const list_all}, @{const list_ex}
  5636   and @{const list_ex1} in specifications.
  5637 *}
  5638 
  5639 lemma list_all_simps [simp, code]:
  5640   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"
  5641   "list_all P [] \<longleftrightarrow> True"
  5642   by (simp_all add: list_all_iff)
  5643 
  5644 lemma list_ex_simps [simp, code]:
  5645   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"
  5646   "list_ex P [] \<longleftrightarrow> False"
  5647   by (simp_all add: list_ex_iff)
  5648 
  5649 lemma list_ex1_simps [simp, code]:
  5650   "list_ex1 P [] = False"
  5651   "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)"
  5652   by (auto simp add: list_ex1_iff list_all_iff)
  5653 
  5654 lemma Ball_set_list_all: (* FIXME delete candidate *)
  5655   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
  5656   by (simp add: list_all_iff)
  5657 
  5658 lemma Bex_set_list_ex: (* FIXME delete candidate *)
  5659   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
  5660   by (simp add: list_ex_iff)
  5661 
  5662 lemma list_all_append [simp]:
  5663   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"
  5664   by (auto simp add: list_all_iff)
  5665 
  5666 lemma list_ex_append [simp]:
  5667   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"
  5668   by (auto simp add: list_ex_iff)
  5669 
  5670 lemma list_all_rev [simp]:
  5671   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"
  5672   by (simp add: list_all_iff)
  5673 
  5674 lemma list_ex_rev [simp]:
  5675   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"
  5676   by (simp add: list_ex_iff)
  5677 
  5678 lemma list_all_length:
  5679   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"
  5680   by (auto simp add: list_all_iff set_conv_nth)
  5681 
  5682 lemma list_ex_length:
  5683   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"
  5684   by (auto simp add: list_ex_iff set_conv_nth)
  5685 
  5686 lemma list_all_cong [fundef_cong]:
  5687   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_all f xs = list_all g ys"
  5688   by (simp add: list_all_iff)
  5689 
  5690 lemma list_ex_cong [fundef_cong]:
  5691   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"
  5692 by (simp add: list_ex_iff)
  5693 
  5694 definition can_select :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  5695 [code_abbrev]: "can_select P A = (\<exists>!x\<in>A. P x)"
  5696 
  5697 lemma can_select_set_list_ex1 [code]:
  5698   "can_select P (set A) = list_ex1 P A"
  5699   by (simp add: list_ex1_iff can_select_def)
  5700 
  5701 
  5702 text {* Executable checks for relations on sets *}
  5703 
  5704 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  5705 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"
  5706 
  5707 lemma [code_unfold]:
  5708   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"
  5709 unfolding listrel1p_def by auto
  5710 
  5711 lemma [code]:
  5712   "listrel1p r [] xs = False"
  5713   "listrel1p r xs [] =  False"
  5714   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>
  5715      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"
  5716 by (simp add: listrel1p_def)+
  5717 
  5718 definition
  5719   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  5720   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"
  5721 
  5722 lemma [code_unfold]:
  5723   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"
  5724 unfolding lexordp_def by auto
  5725 
  5726 lemma [code]:
  5727   "lexordp r xs [] = False"
  5728   "lexordp r [] (y#ys) = True"
  5729   "lexordp r (x # xs) (y # ys) = (r x y | (x = y & lexordp r xs ys))"
  5730 unfolding lexordp_def by auto
  5731 
  5732 text {* Bounded quantification and summation over nats. *}
  5733 
  5734 lemma atMost_upto [code_unfold]:
  5735   "{..n} = set [0..<Suc n]"
  5736   by auto
  5737 
  5738 lemma atLeast_upt [code_unfold]:
  5739   "{..<n} = set [0..<n]"
  5740   by auto
  5741 
  5742 lemma greaterThanLessThan_upt [code_unfold]:
  5743   "{n<..<m} = set [Suc n..<m]"
  5744   by auto
  5745 
  5746 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]
  5747 
  5748 lemma greaterThanAtMost_upt [code_unfold]:
  5749   "{n<..m} = set [Suc n..<Suc m]"
  5750   by auto
  5751 
  5752 lemma atLeastAtMost_upt [code_unfold]:
  5753   "{n..m} = set [n..<Suc m]"
  5754   by auto
  5755 
  5756 lemma all_nat_less_eq [code_unfold]:
  5757   "(\<forall>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"
  5758   by auto
  5759 
  5760 lemma ex_nat_less_eq [code_unfold]:
  5761   "(\<exists>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"
  5762   by auto
  5763 
  5764 lemma all_nat_less [code_unfold]:
  5765   "(\<forall>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"
  5766   by auto
  5767 
  5768 lemma ex_nat_less [code_unfold]:
  5769   "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"
  5770   by auto
  5771 
  5772 lemma setsum_set_upt_conv_listsum_nat [code_unfold]:
  5773   "setsum f (set [m..<n]) = listsum (map f [m..<n])"
  5774   by (simp add: interv_listsum_conv_setsum_set_nat)
  5775 
  5776 text {* Summation over ints. *}
  5777 
  5778 lemma greaterThanLessThan_upto [code_unfold]:
  5779   "{i<..<j::int} = set [i+1..j - 1]"
  5780 by auto
  5781 
  5782 lemma atLeastLessThan_upto [code_unfold]:
  5783   "{i..<j::int} = set [i..j - 1]"
  5784 by auto
  5785 
  5786 lemma greaterThanAtMost_upto [code_unfold]:
  5787   "{i<..j::int} = set [i+1..j]"
  5788 by auto
  5789 
  5790 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]
  5791 
  5792 lemma setsum_set_upto_conv_listsum_int [code_unfold]:
  5793   "setsum f (set [i..j::int]) = listsum (map f [i..j])"
  5794   by (simp add: interv_listsum_conv_setsum_set_int)
  5795 
  5796 
  5797 subsubsection {* Optimizing by rewriting *}
  5798 
  5799 definition null :: "'a list \<Rightarrow> bool" where
  5800   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"
  5801 
  5802 text {*
  5803   Efficient emptyness check is implemented by @{const null}.
  5804 *}
  5805 
  5806 lemma null_rec [code]:
  5807   "null (x # xs) \<longleftrightarrow> False"
  5808   "null [] \<longleftrightarrow> True"
  5809   by (simp_all add: null_def)
  5810 
  5811 lemma eq_Nil_null: (* FIXME delete candidate *)
  5812   "xs = [] \<longleftrightarrow> null xs"
  5813   by (simp add: null_def)
  5814 
  5815 lemma equal_Nil_null [code_unfold]:
  5816   "HOL.equal xs [] \<longleftrightarrow> null xs"
  5817   by (simp add: equal eq_Nil_null)
  5818 
  5819 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  5820   [code_abbrev]: "maps f xs = concat (map f xs)"
  5821 
  5822 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  5823   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"
  5824 
  5825 text {*
  5826   Operations @{const maps} and @{const map_filter} avoid
  5827   intermediate lists on execution -- do not use for proving.
  5828 *}
  5829 
  5830 lemma maps_simps [code]:
  5831   "maps f (x # xs) = f x @ maps f xs"
  5832   "maps f [] = []"
  5833   by (simp_all add: maps_def)
  5834 
  5835 lemma map_filter_simps [code]:
  5836   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"
  5837   "map_filter f [] = []"
  5838   by (simp_all add: map_filter_def split: option.split)
  5839 
  5840 lemma concat_map_maps: (* FIXME delete candidate *)
  5841   "concat (map f xs) = maps f xs"
  5842   by (simp add: maps_def)
  5843 
  5844 lemma map_filter_map_filter [code_unfold]:
  5845   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"
  5846   by (simp add: map_filter_def)
  5847 
  5848 text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}
  5849 and similiarly for @{text"\<exists>"}. *}
  5850 
  5851 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  5852   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"
  5853 
  5854 lemma [code]:
  5855   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"
  5856 proof -
  5857   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"
  5858   proof -
  5859     fix n
  5860     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"
  5861     then show "P n" by (cases "n = i") simp_all
  5862   qed
  5863   show ?thesis by (auto simp add: all_interval_nat_def intro: *)
  5864 qed
  5865 
  5866 lemma list_all_iff_all_interval_nat [code_unfold]:
  5867   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"
  5868   by (simp add: list_all_iff all_interval_nat_def)
  5869 
  5870 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:
  5871   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"
  5872   by (simp add: list_ex_iff all_interval_nat_def)
  5873 
  5874 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  5875   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"
  5876 
  5877 lemma [code]:
  5878   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"
  5879 proof -
  5880   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"
  5881   proof -
  5882     fix k
  5883     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"
  5884     then show "P k" by (cases "k = i") simp_all
  5885   qed
  5886   show ?thesis by (auto simp add: all_interval_int_def intro: *)
  5887 qed
  5888 
  5889 lemma list_all_iff_all_interval_int [code_unfold]:
  5890   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"
  5891   by (simp add: list_all_iff all_interval_int_def)
  5892 
  5893 lemma list_ex_iff_not_all_inverval_int [code_unfold]:
  5894   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"
  5895   by (simp add: list_ex_iff all_interval_int_def)
  5896 
  5897 text {* optimized code (tail-recursive) for @{term length} *}
  5898 
  5899 definition gen_length :: "nat \<Rightarrow> 'a list \<Rightarrow> nat"
  5900 where "gen_length n xs = n + length xs"
  5901 
  5902 lemma gen_length_code [code]:
  5903   "gen_length n [] = n"
  5904   "gen_length n (x # xs) = gen_length (Suc n) xs"
  5905 by(simp_all add: gen_length_def)
  5906 
  5907 declare list.size(3-4)[code del]
  5908 
  5909 lemma length_code [code]: "length = gen_length 0"
  5910 by(simp add: gen_length_def fun_eq_iff)
  5911 
  5912 hide_const (open) member null maps map_filter all_interval_nat all_interval_int gen_length
  5913 
  5914 
  5915 subsubsection {* Pretty lists *}
  5916 
  5917 ML {*
  5918 (* Code generation for list literals. *)
  5919 
  5920 signature LIST_CODE =
  5921 sig
  5922   val implode_list: string -> string -> Code_Thingol.iterm -> Code_Thingol.iterm list option
  5923   val default_list: int * string
  5924     -> (Code_Printer.fixity -> Code_Thingol.iterm -> Pretty.T)
  5925     -> Code_Printer.fixity -> Code_Thingol.iterm -> Code_Thingol.iterm -> Pretty.T
  5926   val add_literal_list: string -> theory -> theory
  5927 end;
  5928 
  5929 structure List_Code : LIST_CODE =
  5930 struct
  5931 
  5932 open Basic_Code_Thingol;
  5933 
  5934 fun implode_list nil' cons' t =
  5935   let
  5936     fun dest_cons (IConst { name = c, ... } `$ t1 `$ t2) =
  5937           if c = cons'
  5938           then SOME (t1, t2)
  5939           else NONE
  5940       | dest_cons _ = NONE;
  5941     val (ts, t') = Code_Thingol.unfoldr dest_cons t;
  5942   in case t'
  5943    of IConst { name = c, ... } => if c = nil' then SOME ts else NONE
  5944     | _ => NONE
  5945   end;
  5946 
  5947 fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
  5948   Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (
  5949     pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
  5950     Code_Printer.str target_cons,
  5951     pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
  5952   );
  5953 
  5954 fun add_literal_list target =
  5955   let
  5956     fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =
  5957       case Option.map (cons t1) (implode_list nil' cons' t2)
  5958        of SOME ts =>
  5959             Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)
  5960         | NONE =>
  5961             default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
  5962   in Code_Target.add_const_syntax target @{const_name Cons}
  5963     (SOME (Code_Printer.complex_const_syntax (2, ([@{const_name Nil}, @{const_name Cons}], pretty))))
  5964   end
  5965 
  5966 end;
  5967 *}
  5968 
  5969 code_type list
  5970   (SML "_ list")
  5971   (OCaml "_ list")
  5972   (Haskell "![(_)]")
  5973   (Scala "List[(_)]")
  5974 
  5975 code_const Nil
  5976   (SML "[]")
  5977   (OCaml "[]")
  5978   (Haskell "[]")
  5979   (Scala "!Nil")
  5980 
  5981 code_instance list :: equal
  5982   (Haskell -)
  5983 
  5984 code_const "HOL.equal \<Colon> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  5985   (Haskell infix 4 "==")
  5986 
  5987 code_reserved SML
  5988   list
  5989 
  5990 code_reserved OCaml
  5991   list
  5992 
  5993 setup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}
  5994 
  5995 
  5996 subsubsection {* Use convenient predefined operations *}
  5997 
  5998 code_const "op @"
  5999   (SML infixr 7 "@")
  6000   (OCaml infixr 6 "@")
  6001   (Haskell infixr 5 "++")
  6002   (Scala infixl 7 "++")
  6003 
  6004 code_const map
  6005   (Haskell "map")
  6006 
  6007 code_const filter
  6008   (Haskell "filter")
  6009 
  6010 code_const concat
  6011   (Haskell "concat")
  6012 
  6013 code_const List.maps
  6014   (Haskell "concatMap")
  6015 
  6016 code_const rev
  6017   (Haskell "reverse")
  6018 
  6019 code_const zip
  6020   (Haskell "zip")
  6021 
  6022 code_const List.null
  6023   (Haskell "null")
  6024 
  6025 code_const takeWhile
  6026   (Haskell "takeWhile")
  6027 
  6028 code_const dropWhile
  6029   (Haskell "dropWhile")
  6030 
  6031 code_const list_all
  6032   (Haskell "all")
  6033 
  6034 code_const list_ex
  6035   (Haskell "any")
  6036 
  6037 
  6038 subsubsection {* Implementation of sets by lists *}
  6039 
  6040 lemma is_empty_set [code]:
  6041   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"
  6042   by (simp add: Set.is_empty_def null_def)
  6043 
  6044 lemma empty_set [code]:
  6045   "{} = set []"
  6046   by simp
  6047 
  6048 lemma UNIV_coset [code]:
  6049   "UNIV = List.coset []"
  6050   by simp
  6051 
  6052 lemma compl_set [code]:
  6053   "- set xs = List.coset xs"
  6054   by simp
  6055 
  6056 lemma compl_coset [code]:
  6057   "- List.coset xs = set xs"
  6058   by simp
  6059 
  6060 lemma [code]:
  6061   "x \<in> set xs \<longleftrightarrow> List.member xs x"
  6062   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"
  6063   by (simp_all add: member_def)
  6064 
  6065 lemma insert_code [code]:
  6066   "insert x (set xs) = set (List.insert x xs)"
  6067   "insert x (List.coset xs) = List.coset (removeAll x xs)"
  6068   by simp_all
  6069 
  6070 lemma remove_code [code]:
  6071   "Set.remove x (set xs) = set (removeAll x xs)"
  6072   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"
  6073   by (simp_all add: remove_def Compl_insert)
  6074 
  6075 lemma filter_set [code]:
  6076   "Set.filter P (set xs) = set (filter P xs)"
  6077   by auto
  6078 
  6079 lemma image_set [code]:
  6080   "image f (set xs) = set (map f xs)"
  6081   by simp
  6082 
  6083 lemma subset_code [code]:
  6084   "set xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> B)"
  6085   "A \<le> List.coset ys \<longleftrightarrow> (\<forall>y\<in>set ys. y \<notin> A)"
  6086   "List.coset [] \<le> set [] \<longleftrightarrow> False"
  6087   by auto
  6088 
  6089 text {* A frequent case – avoid intermediate sets *}
  6090 lemma [code_unfold]:
  6091   "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"
  6092   by (auto simp: list_all_iff)
  6093 
  6094 lemma Ball_set [code]:
  6095   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
  6096   by (simp add: list_all_iff)
  6097 
  6098 lemma Bex_set [code]:
  6099   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
  6100   by (simp add: list_ex_iff)
  6101 
  6102 lemma card_set [code]:
  6103   "card (set xs) = length (remdups xs)"
  6104 proof -
  6105   have "card (set (remdups xs)) = length (remdups xs)"
  6106     by (rule distinct_card) simp
  6107   then show ?thesis by simp
  6108 qed
  6109 
  6110 lemma the_elem_set [code]:
  6111   "the_elem (set [x]) = x"
  6112   by simp
  6113 
  6114 lemma Pow_set [code]:
  6115   "Pow (set []) = {{}}"
  6116   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x ` A)"
  6117   by (simp_all add: Pow_insert Let_def)
  6118 
  6119 lemma setsum_code [code]:
  6120   "setsum f (set xs) = listsum (map f (remdups xs))"
  6121 by (simp add: listsum_distinct_conv_setsum_set)
  6122 
  6123 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
  6124   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"
  6125 
  6126 lemma [code]:
  6127   "map_project f (set xs) = set (List.map_filter f xs)"
  6128   by (auto simp add: map_project_def map_filter_def image_def)
  6129 
  6130 hide_const (open) map_project
  6131 
  6132 
  6133 text {* Operations on relations *}
  6134 
  6135 lemma product_code [code]:
  6136   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"
  6137   by (auto simp add: Product_Type.product_def)
  6138 
  6139 lemma Id_on_set [code]:
  6140   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"
  6141   by (auto simp add: Id_on_def)
  6142 
  6143 lemma [code]:
  6144   "R `` S = List.map_project (%(x, y). if x : S then Some y else None) R"
  6145 unfolding map_project_def by (auto split: prod.split split_if_asm)
  6146 
  6147 lemma trancl_set_ntrancl [code]:
  6148   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"
  6149   by (simp add: finite_trancl_ntranl)
  6150 
  6151 lemma set_relcomp [code]:
  6152   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"
  6153   by (auto simp add: Bex_def)
  6154 
  6155 lemma wf_set [code]:
  6156   "wf (set xs) = acyclic (set xs)"
  6157   by (simp add: wf_iff_acyclic_if_finite)
  6158 
  6159 end
  6160