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