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