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