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