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