src/HOL/List.thy
author wenzelm
Mon Feb 25 12:17:50 2013 +0100 (2013-02-25)
changeset 51272 9c8d63b4b6be
parent 51173 3cbb4e95a565
child 51314 eac4bb5adbf9
permissions -rw-r--r--
prefer stateless 'ML_val' for tests;
     1 (*  Title:      HOL/List.thy
     2     Author:     Tobias Nipkow
     3 *)
     4 
     5 header {* The datatype of finite lists *}
     6 
     7 theory List
     8 imports Presburger Code_Numeral Quotient ATP
     9 begin
    10 
    11 datatype 'a list =
    12     Nil    ("[]")
    13   | Cons 'a  "'a list"    (infixr "#" 65)
    14 
    15 syntax
    16   -- {* list Enumeration *}
    17   "_list" :: "args => 'a list"    ("[(_)]")
    18 
    19 translations
    20   "[x, xs]" == "x#[xs]"
    21   "[x]" == "x#[]"
    22 
    23 
    24 subsection {* Basic list processing functions *}
    25 
    26 primrec hd :: "'a list \<Rightarrow> 'a" where
    27 "hd (x # xs) = x"
    28 
    29 primrec tl :: "'a list \<Rightarrow> 'a list" where
    30 "tl [] = []" |
    31 "tl (x # xs) = xs"
    32 
    33 primrec last :: "'a list \<Rightarrow> 'a" where
    34 "last (x # xs) = (if xs = [] then x else last xs)"
    35 
    36 primrec butlast :: "'a list \<Rightarrow> 'a list" where
    37 "butlast []= []" |
    38 "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
    39 
    40 primrec set :: "'a list \<Rightarrow> 'a set" where
    41 "set [] = {}" |
    42 "set (x # xs) = insert x (set xs)"
    43 
    44 definition coset :: "'a list \<Rightarrow> 'a set" where
    45 [simp]: "coset xs = - set xs"
    46 
    47 primrec map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
    48 "map f [] = []" |
    49 "map f (x # xs) = f x # map f xs"
    50 
    51 primrec append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
    52 append_Nil: "[] @ ys = ys" |
    53 append_Cons: "(x#xs) @ ys = x # xs @ ys"
    54 
    55 primrec rev :: "'a list \<Rightarrow> 'a list" where
    56 "rev [] = []" |
    57 "rev (x # xs) = rev xs @ [x]"
    58 
    59 primrec filter:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    60 "filter P [] = []" |
    61 "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"
    62 
    63 syntax
    64   -- {* Special syntax for filter *}
    65   "_filter" :: "[pttrn, 'a list, bool] => 'a list"    ("(1[_<-_./ _])")
    66 
    67 translations
    68   "[x<-xs . P]"== "CONST filter (%x. P) xs"
    69 
    70 syntax (xsymbols)
    71   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
    72 syntax (HTML output)
    73   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")
    74 
    75 primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
    76 fold_Nil:  "fold f [] = id" |
    77 fold_Cons: "fold f (x # xs) = fold f xs \<circ> f x"
    78 
    79 primrec foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
    80 foldr_Nil:  "foldr f [] = id" |
    81 foldr_Cons: "foldr f (x # xs) = f x \<circ> foldr f xs"
    82 
    83 primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
    84 foldl_Nil:  "foldl f a [] = a" |
    85 foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
    86 
    87 primrec concat:: "'a list list \<Rightarrow> 'a list" where
    88 "concat [] = []" |
    89 "concat (x # xs) = x @ concat xs"
    90 
    91 definition (in monoid_add) listsum :: "'a list \<Rightarrow> 'a" where
    92 "listsum xs = foldr plus xs 0"
    93 
    94 primrec drop:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    95 drop_Nil: "drop n [] = []" |
    96 drop_Cons: "drop n (x # xs) = (case n of 0 \<Rightarrow> x # xs | Suc m \<Rightarrow> drop m xs)"
    97   -- {*Warning: simpset does not contain this definition, but separate
    98        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}
    99 
   100 primrec take:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   101 take_Nil:"take n [] = []" |
   102 take_Cons: "take n (x # xs) = (case n of 0 \<Rightarrow> [] | Suc m \<Rightarrow> x # take m xs)"
   103   -- {*Warning: simpset does not contain this definition, but separate
   104        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}
   105 
   106 primrec nth :: "'a list => nat => 'a" (infixl "!" 100) where
   107 nth_Cons: "(x # xs) ! n = (case n of 0 \<Rightarrow> x | Suc k \<Rightarrow> xs ! k)"
   108   -- {*Warning: simpset does not contain this definition, but separate
   109        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}
   110 
   111 primrec list_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
   112 "list_update [] i v = []" |
   113 "list_update (x # xs) i v =
   114   (case i of 0 \<Rightarrow> v # xs | Suc j \<Rightarrow> x # list_update xs j v)"
   115 
   116 nonterminal lupdbinds and lupdbind
   117 
   118 syntax
   119   "_lupdbind":: "['a, 'a] => lupdbind"    ("(2_ :=/ _)")
   120   "" :: "lupdbind => lupdbinds"    ("_")
   121   "_lupdbinds" :: "[lupdbind, lupdbinds] => lupdbinds"    ("_,/ _")
   122   "_LUpdate" :: "['a, lupdbinds] => 'a"    ("_/[(_)]" [900,0] 900)
   123 
   124 translations
   125   "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"
   126   "xs[i:=x]" == "CONST list_update xs i x"
   127 
   128 primrec takeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   129 "takeWhile P [] = []" |
   130 "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"
   131 
   132 primrec dropWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   133 "dropWhile P [] = []" |
   134 "dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"
   135 
   136 primrec zip :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
   137 "zip xs [] = []" |
   138 zip_Cons: "zip xs (y # ys) =
   139   (case xs of [] => [] | z # zs => (z, y) # zip zs ys)"
   140   -- {*Warning: simpset does not contain this definition, but separate
   141        theorems for @{text "xs = []"} and @{text "xs = z # zs"} *}
   142 
   143 primrec product :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
   144 "product [] _ = []" |
   145 "product (x#xs) ys = map (Pair x) ys @ product xs ys"
   146 
   147 hide_const (open) product
   148 
   149 primrec upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_..</_'])") where
   150 upt_0: "[i..<0] = []" |
   151 upt_Suc: "[i..<(Suc j)] = (if i <= j then [i..<j] @ [j] else [])"
   152 
   153 definition insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   154 "insert x xs = (if x \<in> set xs then xs else x # xs)"
   155 
   156 hide_const (open) insert
   157 hide_fact (open) insert_def
   158 
   159 primrec find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
   160 "find _ [] = None" |
   161 "find P (x#xs) = (if P x then Some x else find P xs)"
   162 
   163 hide_const (open) find
   164 
   165 primrec those :: "'a option list \<Rightarrow> 'a list option"
   166 where
   167 "those [] = Some []" |
   168 "those (x # xs) = (case x of
   169   None \<Rightarrow> None
   170 | Some y \<Rightarrow> Option.map (Cons y) (those xs))"
   171 
   172 primrec remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   173 "remove1 x [] = []" |
   174 "remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"
   175 
   176 primrec removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   177 "removeAll x [] = []" |
   178 "removeAll x (y # xs) = (if x = y then removeAll x xs else y # removeAll x xs)"
   179 
   180 primrec distinct :: "'a list \<Rightarrow> bool" where
   181 "distinct [] \<longleftrightarrow> True" |
   182 "distinct (x # xs) \<longleftrightarrow> x \<notin> set xs \<and> distinct xs"
   183 
   184 primrec remdups :: "'a list \<Rightarrow> 'a list" where
   185 "remdups [] = []" |
   186 "remdups (x # xs) = (if x \<in> set xs then remdups xs else x # remdups xs)"
   187 
   188 primrec replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
   189 replicate_0: "replicate 0 x = []" |
   190 replicate_Suc: "replicate (Suc n) x = x # replicate n x"
   191 
   192 text {*
   193   Function @{text size} is overloaded for all datatypes. Users may
   194   refer to the list version as @{text length}. *}
   195 
   196 abbreviation length :: "'a list \<Rightarrow> nat" where
   197 "length \<equiv> size"
   198 
   199 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 (advanced) {*
   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, Datatype_Case.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 : simpset -> 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 Trueprop_conv cv ct =
   518   (case Thm.term_of ct of
   519     Const (@{const_name Trueprop}, _) $ _ => Conv.arg_conv cv ct
   520   | _ => raise CTERM ("Trueprop_conv", [ct]))
   521 
   522 fun eq_conv cv1 cv2 ct =
   523   (case Thm.term_of ct of
   524     Const (@{const_name HOL.eq}, _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv1) cv2 ct
   525   | _ => raise CTERM ("eq_conv", [ct]))
   526 
   527 fun conj_conv cv1 cv2 ct =
   528   (case Thm.term_of ct of
   529     Const (@{const_name HOL.conj}, _) $ _ $ _ => Conv.combination_conv (Conv.arg_conv cv1) cv2 ct
   530   | _ => raise CTERM ("conj_conv", [ct]))
   531 
   532 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)
   533 
   534 fun conjunct_assoc_conv ct =
   535   Conv.try_conv
   536     (rewr_conv' @{thm conj_assoc} then_conv conj_conv Conv.all_conv conjunct_assoc_conv) ct
   537 
   538 fun right_hand_set_comprehension_conv conv ctxt =
   539   Trueprop_conv (eq_conv Conv.all_conv
   540     (Collect_conv (all_exists_conv conv o #2) ctxt))
   541 
   542 
   543 (* term abstraction of list comprehension patterns *)
   544 
   545 datatype termlets = If | Case of (typ * int)
   546 
   547 fun simproc ss redex =
   548   let
   549     val ctxt = Simplifier.the_context ss
   550     val thy = Proof_Context.theory_of ctxt
   551     val set_Nil_I = @{thm trans} OF [@{thm set.simps(1)}, @{thm empty_def}]
   552     val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}
   553     val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}
   554     val del_refl_eq = @{lemma "(t = t & P) == P" by simp}
   555     fun mk_set T = Const (@{const_name List.set}, HOLogic.listT T --> HOLogic.mk_setT T)
   556     fun dest_set (Const (@{const_name List.set}, _) $ xs) = xs
   557     fun dest_singleton_list (Const (@{const_name List.Cons}, _)
   558           $ t $ (Const (@{const_name List.Nil}, _))) = t
   559       | dest_singleton_list t = raise TERM ("dest_singleton_list", [t])
   560     (* We check that one case returns a singleton list and all other cases
   561        return [], and return the index of the one singleton list case *)
   562     fun possible_index_of_singleton_case cases =
   563       let
   564         fun check (i, case_t) s =
   565           (case strip_abs_body case_t of
   566             (Const (@{const_name List.Nil}, _)) => s
   567           | _ => (case s of NONE => SOME i | SOME _ => NONE))
   568       in
   569         fold_index check cases NONE
   570       end
   571     (* returns (case_expr type index chosen_case) option  *)
   572     fun dest_case case_term =
   573       let
   574         val (case_const, args) = strip_comb case_term
   575       in
   576         (case try dest_Const case_const of
   577           SOME (c, T) =>
   578             (case Datatype.info_of_case thy c of
   579               SOME _ =>
   580                 (case possible_index_of_singleton_case (fst (split_last args)) of
   581                   SOME i =>
   582                     let
   583                       val (Ts, _) = strip_type T
   584                       val T' = List.last Ts
   585                     in SOME (List.last args, T', i, nth args i) end
   586                 | NONE => NONE)
   587             | NONE => NONE)
   588         | NONE => NONE)
   589       end
   590     (* returns condition continuing term option *)
   591     fun dest_if (Const (@{const_name If}, _) $ cond $ then_t $ Const (@{const_name Nil}, _)) =
   592           SOME (cond, then_t)
   593       | dest_if _ = NONE
   594     fun tac _ [] = rtac set_singleton 1 ORELSE rtac inst_Collect_mem_eq 1
   595       | tac ctxt (If :: cont) =
   596           Splitter.split_tac [@{thm split_if}] 1
   597           THEN rtac @{thm conjI} 1
   598           THEN rtac @{thm impI} 1
   599           THEN Subgoal.FOCUS (fn {prems, context, ...} =>
   600             CONVERSION (right_hand_set_comprehension_conv (K
   601               (conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv
   602                then_conv
   603                rewr_conv' @{lemma "(True & P) = P" by simp})) context) 1) ctxt 1
   604           THEN tac ctxt cont
   605           THEN rtac @{thm impI} 1
   606           THEN Subgoal.FOCUS (fn {prems, context, ...} =>
   607               CONVERSION (right_hand_set_comprehension_conv (K
   608                 (conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv
   609                  then_conv rewr_conv' @{lemma "(False & P) = False" by simp})) context) 1) ctxt 1
   610           THEN rtac set_Nil_I 1
   611       | tac ctxt (Case (T, i) :: cont) =
   612           let
   613             val info = Datatype.the_info thy (fst (dest_Type T))
   614           in
   615             (* do case distinction *)
   616             Splitter.split_tac [#split info] 1
   617             THEN EVERY (map_index (fn (i', _) =>
   618               (if i' < length (#case_rewrites info) - 1 then rtac @{thm conjI} 1 else all_tac)
   619               THEN REPEAT_DETERM (rtac @{thm allI} 1)
   620               THEN rtac @{thm impI} 1
   621               THEN (if i' = i then
   622                 (* continue recursively *)
   623                 Subgoal.FOCUS (fn {prems, context, ...} =>
   624                   CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K
   625                       ((conj_conv
   626                         (eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv
   627                           (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq (#inject info)))))
   628                         Conv.all_conv)
   629                         then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))
   630                         then_conv conjunct_assoc_conv)) context
   631                     then_conv (Trueprop_conv (eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt) =>
   632                       Conv.repeat_conv
   633                         (all_but_last_exists_conv
   634                           (K (rewr_conv'
   635                             @{lemma "(EX x. x = t & P x) = P t" by simp})) ctxt)) context)))) 1) ctxt 1
   636                 THEN tac ctxt cont
   637               else
   638                 Subgoal.FOCUS (fn {prems, context, ...} =>
   639                   CONVERSION
   640                     (right_hand_set_comprehension_conv (K
   641                       (conj_conv
   642                         ((eq_conv Conv.all_conv
   643                           (rewr_conv' (List.last prems))) then_conv
   644                           (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) (#distinct info))))
   645                         Conv.all_conv then_conv
   646                         (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv
   647                       Trueprop_conv
   648                         (eq_conv Conv.all_conv
   649                           (Collect_conv (fn (_, ctxt) =>
   650                             Conv.repeat_conv
   651                               (Conv.bottom_conv
   652                                 (K (rewr_conv'
   653                                   @{lemma "(EX x. P) = P" by simp})) ctxt)) context))) 1) ctxt 1
   654                 THEN rtac set_Nil_I 1)) (#case_rewrites info))
   655           end
   656     fun make_inner_eqs bound_vs Tis eqs t =
   657       (case dest_case t of
   658         SOME (x, T, i, cont) =>
   659           let
   660             val (vs, body) = strip_abs (Pattern.eta_long (map snd bound_vs) cont)
   661             val x' = incr_boundvars (length vs) x
   662             val eqs' = map (incr_boundvars (length vs)) eqs
   663             val (constr_name, _) = nth (the (Datatype.get_constrs thy (fst (dest_Type T)))) i
   664             val constr_t =
   665               list_comb
   666                 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))
   667             val constr_eq = Const (@{const_name HOL.eq}, T --> T --> @{typ bool}) $ constr_t $ x'
   668           in
   669             make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body
   670           end
   671       | NONE =>
   672           (case dest_if t of
   673             SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont
   674           | NONE =>
   675             if eqs = [] then NONE (* no rewriting, nothing to be done *)
   676             else
   677               let
   678                 val Type (@{type_name List.list}, [rT]) = fastype_of1 (map snd bound_vs, t)
   679                 val pat_eq =
   680                   (case try dest_singleton_list t of
   681                     SOME t' =>
   682                       Const (@{const_name HOL.eq}, rT --> rT --> @{typ bool}) $
   683                         Bound (length bound_vs) $ t'
   684                   | NONE =>
   685                       Const (@{const_name Set.member}, rT --> HOLogic.mk_setT rT --> @{typ bool}) $
   686                         Bound (length bound_vs) $ (mk_set rT $ t))
   687                 val reverse_bounds = curry subst_bounds
   688                   ((map Bound ((length bound_vs - 1) downto 0)) @ [Bound (length bound_vs)])
   689                 val eqs' = map reverse_bounds eqs
   690                 val pat_eq' = reverse_bounds pat_eq
   691                 val inner_t =
   692                   fold (fn (_, T) => fn t => HOLogic.exists_const T $ absdummy T t)
   693                     (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')
   694                 val lhs = term_of redex
   695                 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)
   696                 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))
   697               in
   698                 SOME
   699                   ((Goal.prove ctxt [] [] rewrite_rule_t
   700                     (fn {context, ...} => tac context (rev Tis))) RS @{thm eq_reflection})
   701               end))
   702   in
   703     make_inner_eqs [] [] [] (dest_set (term_of redex))
   704   end
   705 
   706 end
   707 *}
   708 
   709 simproc_setup list_to_set_comprehension ("set xs") = {* K List_to_Set_Comprehension.simproc *}
   710 
   711 code_datatype set coset
   712 
   713 hide_const (open) coset
   714 
   715 
   716 subsubsection {* @{const Nil} and @{const Cons} *}
   717 
   718 lemma not_Cons_self [simp]:
   719   "xs \<noteq> x # xs"
   720 by (induct xs) auto
   721 
   722 lemma not_Cons_self2 [simp]:
   723   "x # xs \<noteq> xs"
   724 by (rule not_Cons_self [symmetric])
   725 
   726 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"
   727 by (induct xs) auto
   728 
   729 lemma length_induct:
   730   "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"
   731 by (rule measure_induct [of length]) iprover
   732 
   733 lemma list_nonempty_induct [consumes 1, case_names single cons]:
   734   assumes "xs \<noteq> []"
   735   assumes single: "\<And>x. P [x]"
   736   assumes cons: "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)"
   737   shows "P xs"
   738 using `xs \<noteq> []` proof (induct xs)
   739   case Nil then show ?case by simp
   740 next
   741   case (Cons x xs) show ?case proof (cases xs)
   742     case Nil with single show ?thesis by simp
   743   next
   744     case Cons then have "xs \<noteq> []" by simp
   745     moreover with Cons.hyps have "P xs" .
   746     ultimately show ?thesis by (rule cons)
   747   qed
   748 qed
   749 
   750 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"
   751   by (auto intro!: inj_onI)
   752 
   753 
   754 subsubsection {* @{const length} *}
   755 
   756 text {*
   757   Needs to come before @{text "@"} because of theorem @{text
   758   append_eq_append_conv}.
   759 *}
   760 
   761 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"
   762 by (induct xs) auto
   763 
   764 lemma length_map [simp]: "length (map f xs) = length xs"
   765 by (induct xs) auto
   766 
   767 lemma length_rev [simp]: "length (rev xs) = length xs"
   768 by (induct xs) auto
   769 
   770 lemma length_tl [simp]: "length (tl xs) = length xs - 1"
   771 by (cases xs) auto
   772 
   773 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"
   774 by (induct xs) auto
   775 
   776 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"
   777 by (induct xs) auto
   778 
   779 lemma length_pos_if_in_set: "x : set xs \<Longrightarrow> length xs > 0"
   780 by auto
   781 
   782 lemma length_Suc_conv:
   783 "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
   784 by (induct xs) auto
   785 
   786 lemma Suc_length_conv:
   787 "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
   788 apply (induct xs, simp, simp)
   789 apply blast
   790 done
   791 
   792 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False"
   793   by (induct xs) auto
   794 
   795 lemma list_induct2 [consumes 1, case_names Nil Cons]:
   796   "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>
   797    (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))
   798    \<Longrightarrow> P xs ys"
   799 proof (induct xs arbitrary: ys)
   800   case Nil then show ?case by simp
   801 next
   802   case (Cons x xs ys) then show ?case by (cases ys) simp_all
   803 qed
   804 
   805 lemma list_induct3 [consumes 2, case_names Nil Cons]:
   806   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>
   807    (\<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))
   808    \<Longrightarrow> P xs ys zs"
   809 proof (induct xs arbitrary: ys zs)
   810   case Nil then show ?case by simp
   811 next
   812   case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)
   813     (cases zs, simp_all)
   814 qed
   815 
   816 lemma list_induct4 [consumes 3, case_names Nil Cons]:
   817   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>
   818    P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>
   819    length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>
   820    P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"
   821 proof (induct xs arbitrary: ys zs ws)
   822   case Nil then show ?case by simp
   823 next
   824   case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)
   825 qed
   826 
   827 lemma list_induct2': 
   828   "\<lbrakk> P [] [];
   829   \<And>x xs. P (x#xs) [];
   830   \<And>y ys. P [] (y#ys);
   831    \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>
   832  \<Longrightarrow> P xs ys"
   833 by (induct xs arbitrary: ys) (case_tac x, auto)+
   834 
   835 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"
   836 by (rule Eq_FalseI) auto
   837 
   838 simproc_setup list_neq ("(xs::'a list) = ys") = {*
   839 (*
   840 Reduces xs=ys to False if xs and ys cannot be of the same length.
   841 This is the case if the atomic sublists of one are a submultiset
   842 of those of the other list and there are fewer Cons's in one than the other.
   843 *)
   844 
   845 let
   846 
   847 fun len (Const(@{const_name Nil},_)) acc = acc
   848   | len (Const(@{const_name Cons},_) $ _ $ xs) (ts,n) = len xs (ts,n+1)
   849   | len (Const(@{const_name append},_) $ xs $ ys) acc = len xs (len ys acc)
   850   | len (Const(@{const_name rev},_) $ xs) acc = len xs acc
   851   | len (Const(@{const_name map},_) $ _ $ xs) acc = len xs acc
   852   | len t (ts,n) = (t::ts,n);
   853 
   854 fun list_neq _ ss ct =
   855   let
   856     val (Const(_,eqT) $ lhs $ rhs) = Thm.term_of ct;
   857     val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);
   858     fun prove_neq() =
   859       let
   860         val Type(_,listT::_) = eqT;
   861         val size = HOLogic.size_const listT;
   862         val eq_len = HOLogic.mk_eq (size $ lhs, size $ rhs);
   863         val neq_len = HOLogic.mk_Trueprop (HOLogic.Not $ eq_len);
   864         val thm = Goal.prove (Simplifier.the_context ss) [] [] neq_len
   865           (K (simp_tac (Simplifier.inherit_context ss @{simpset}) 1));
   866       in SOME (thm RS @{thm neq_if_length_neq}) end
   867   in
   868     if m < n andalso submultiset (op aconv) (ls,rs) orelse
   869        n < m andalso submultiset (op aconv) (rs,ls)
   870     then prove_neq() else NONE
   871   end;
   872 in list_neq end;
   873 *}
   874 
   875 
   876 subsubsection {* @{text "@"} -- append *}
   877 
   878 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
   879 by (induct xs) auto
   880 
   881 lemma append_Nil2 [simp]: "xs @ [] = xs"
   882 by (induct xs) auto
   883 
   884 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"
   885 by (induct xs) auto
   886 
   887 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"
   888 by (induct xs) auto
   889 
   890 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"
   891 by (induct xs) auto
   892 
   893 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"
   894 by (induct xs) auto
   895 
   896 lemma append_eq_append_conv [simp, no_atp]:
   897  "length xs = length ys \<or> length us = length vs
   898  ==> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"
   899 apply (induct xs arbitrary: ys)
   900  apply (case_tac ys, simp, force)
   901 apply (case_tac ys, force, simp)
   902 done
   903 
   904 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =
   905   (EX us. xs = zs @ us & us @ ys = ts | xs @ us = zs & ys = us@ ts)"
   906 apply (induct xs arbitrary: ys zs ts)
   907  apply fastforce
   908 apply(case_tac zs)
   909  apply simp
   910 apply fastforce
   911 done
   912 
   913 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"
   914 by simp
   915 
   916 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"
   917 by simp
   918 
   919 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"
   920 by simp
   921 
   922 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"
   923 using append_same_eq [of _ _ "[]"] by auto
   924 
   925 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"
   926 using append_same_eq [of "[]"] by auto
   927 
   928 lemma hd_Cons_tl [simp,no_atp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"
   929 by (induct xs) auto
   930 
   931 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
   932 by (induct xs) auto
   933 
   934 lemma hd_append2 [simp]: "xs \<noteq> [] ==> hd (xs @ ys) = hd xs"
   935 by (simp add: hd_append split: list.split)
   936 
   937 lemma tl_append: "tl (xs @ ys) = (case xs of [] => tl ys | z#zs => zs @ ys)"
   938 by (simp split: list.split)
   939 
   940 lemma tl_append2 [simp]: "xs \<noteq> [] ==> tl (xs @ ys) = tl xs @ ys"
   941 by (simp add: tl_append split: list.split)
   942 
   943 
   944 lemma Cons_eq_append_conv: "x#xs = ys@zs =
   945  (ys = [] & x#xs = zs | (EX ys'. x#ys' = ys & xs = ys'@zs))"
   946 by(cases ys) auto
   947 
   948 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =
   949  (ys = [] & zs = x#xs | (EX ys'. ys = x#ys' & ys'@zs = xs))"
   950 by(cases ys) auto
   951 
   952 
   953 text {* Trivial rules for solving @{text "@"}-equations automatically. *}
   954 
   955 lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"
   956 by simp
   957 
   958 lemma Cons_eq_appendI:
   959 "[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"
   960 by (drule sym) simp
   961 
   962 lemma append_eq_appendI:
   963 "[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"
   964 by (drule sym) simp
   965 
   966 
   967 text {*
   968 Simplification procedure for all list equalities.
   969 Currently only tries to rearrange @{text "@"} to see if
   970 - both lists end in a singleton list,
   971 - or both lists end in the same list.
   972 *}
   973 
   974 simproc_setup list_eq ("(xs::'a list) = ys")  = {*
   975   let
   976     fun last (cons as Const (@{const_name Cons}, _) $ _ $ xs) =
   977           (case xs of Const (@{const_name Nil}, _) => cons | _ => last xs)
   978       | last (Const(@{const_name append},_) $ _ $ ys) = last ys
   979       | last t = t;
   980     
   981     fun list1 (Const(@{const_name Cons},_) $ _ $ Const(@{const_name Nil},_)) = true
   982       | list1 _ = false;
   983     
   984     fun butlast ((cons as Const(@{const_name Cons},_) $ x) $ xs) =
   985           (case xs of Const (@{const_name Nil}, _) => xs | _ => cons $ butlast xs)
   986       | butlast ((app as Const (@{const_name append}, _) $ xs) $ ys) = app $ butlast ys
   987       | butlast xs = Const(@{const_name Nil}, fastype_of xs);
   988     
   989     val rearr_ss =
   990       HOL_basic_ss addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}];
   991     
   992     fun list_eq ss (F as (eq as Const(_,eqT)) $ lhs $ rhs) =
   993       let
   994         val lastl = last lhs and lastr = last rhs;
   995         fun rearr conv =
   996           let
   997             val lhs1 = butlast lhs and rhs1 = butlast rhs;
   998             val Type(_,listT::_) = eqT
   999             val appT = [listT,listT] ---> listT
  1000             val app = Const(@{const_name append},appT)
  1001             val F2 = eq $ (app$lhs1$lastl) $ (app$rhs1$lastr)
  1002             val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (F,F2));
  1003             val thm = Goal.prove (Simplifier.the_context ss) [] [] eq
  1004               (K (simp_tac (Simplifier.inherit_context ss rearr_ss) 1));
  1005           in SOME ((conv RS (thm RS trans)) RS eq_reflection) end;
  1006       in
  1007         if list1 lastl andalso list1 lastr then rearr @{thm append1_eq_conv}
  1008         else if lastl aconv lastr then rearr @{thm append_same_eq}
  1009         else NONE
  1010       end;
  1011   in fn _ => fn ss => fn ct => list_eq ss (term_of ct) end;
  1012 *}
  1013 
  1014 
  1015 subsubsection {* @{const map} *}
  1016 
  1017 lemma hd_map:
  1018   "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"
  1019   by (cases xs) simp_all
  1020 
  1021 lemma map_tl:
  1022   "map f (tl xs) = tl (map f xs)"
  1023   by (cases xs) simp_all
  1024 
  1025 lemma map_ext: "(!!x. x : set xs --> f x = g x) ==> map f xs = map g xs"
  1026 by (induct xs) simp_all
  1027 
  1028 lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"
  1029 by (rule ext, induct_tac xs) auto
  1030 
  1031 lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"
  1032 by (induct xs) auto
  1033 
  1034 lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"
  1035 by (induct xs) auto
  1036 
  1037 lemma map_comp_map[simp]: "((map f) o (map g)) = map(f o g)"
  1038 apply(rule ext)
  1039 apply(simp)
  1040 done
  1041 
  1042 lemma rev_map: "rev (map f xs) = map f (rev xs)"
  1043 by (induct xs) auto
  1044 
  1045 lemma map_eq_conv[simp]: "(map f xs = map g xs) = (!x : set xs. f x = g x)"
  1046 by (induct xs) auto
  1047 
  1048 lemma map_cong [fundef_cong]:
  1049   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g ys"
  1050   by simp
  1051 
  1052 lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"
  1053 by (cases xs) auto
  1054 
  1055 lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"
  1056 by (cases xs) auto
  1057 
  1058 lemma map_eq_Cons_conv:
  1059  "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"
  1060 by (cases xs) auto
  1061 
  1062 lemma Cons_eq_map_conv:
  1063  "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"
  1064 by (cases ys) auto
  1065 
  1066 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]
  1067 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]
  1068 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]
  1069 
  1070 lemma ex_map_conv:
  1071   "(EX xs. ys = map f xs) = (ALL y : set ys. EX x. y = f x)"
  1072 by(induct ys, auto simp add: Cons_eq_map_conv)
  1073 
  1074 lemma map_eq_imp_length_eq:
  1075   assumes "map f xs = map g ys"
  1076   shows "length xs = length ys"
  1077 using assms 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   moreover 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 "length xs - n = Suc n'"
  1686       by (cases "length xs - n", auto)
  1687     moreover
  1688     then 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\<^isub>1 @ xs\<^isub>2 = ys\<^isub>1 @ ys\<^isub>2) =
  2112   (if size xs\<^isub>1 \<le> size ys\<^isub>1
  2113    then xs\<^isub>1 = take (size xs\<^isub>1) ys\<^isub>1 \<and> xs\<^isub>2 = drop (size xs\<^isub>1) ys\<^isub>1 @ ys\<^isub>2
  2114    else take (size ys\<^isub>1) xs\<^isub>1 = ys\<^isub>1 \<and> drop (size ys\<^isub>1) xs\<^isub>1 @ xs\<^isub>2 = ys\<^isub>2)"
  2115 apply(induct xs\<^isub>1 arbitrary: ys\<^isub>1)
  2116  apply simp
  2117 apply(case_tac ys\<^isub>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 
  2325 subsubsection {* @{const zip} *}
  2326 
  2327 lemma zip_Nil [simp]: "zip [] ys = []"
  2328 by (induct ys) auto
  2329 
  2330 lemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
  2331 by simp
  2332 
  2333 declare zip_Cons [simp del]
  2334 
  2335 lemma [code]:
  2336   "zip [] ys = []"
  2337   "zip xs [] = []"
  2338   "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
  2339   by (fact zip_Nil zip.simps(1) zip_Cons_Cons)+
  2340 
  2341 lemma zip_Cons1:
  2342  "zip (x#xs) ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x,y)#zip xs ys)"
  2343 by(auto split:list.split)
  2344 
  2345 lemma length_zip [simp]:
  2346 "length (zip xs ys) = min (length xs) (length ys)"
  2347 by (induct xs ys rule:list_induct2') auto
  2348 
  2349 lemma zip_obtain_same_length:
  2350   assumes "\<And>zs ws n. length zs = length ws \<Longrightarrow> n = min (length xs) (length ys)
  2351     \<Longrightarrow> zs = take n xs \<Longrightarrow> ws = take n ys \<Longrightarrow> P (zip zs ws)"
  2352   shows "P (zip xs ys)"
  2353 proof -
  2354   let ?n = "min (length xs) (length ys)"
  2355   have "P (zip (take ?n xs) (take ?n ys))"
  2356     by (rule assms) simp_all
  2357   moreover have "zip xs ys = zip (take ?n xs) (take ?n ys)"
  2358   proof (induct xs arbitrary: ys)
  2359     case Nil then show ?case by simp
  2360   next
  2361     case (Cons x xs) then show ?case by (cases ys) simp_all
  2362   qed
  2363   ultimately show ?thesis by simp
  2364 qed
  2365 
  2366 lemma zip_append1:
  2367 "zip (xs @ ys) zs =
  2368 zip xs (take (length xs) zs) @ zip ys (drop (length xs) zs)"
  2369 by (induct xs zs rule:list_induct2') auto
  2370 
  2371 lemma zip_append2:
  2372 "zip xs (ys @ zs) =
  2373 zip (take (length ys) xs) ys @ zip (drop (length ys) xs) zs"
  2374 by (induct xs ys rule:list_induct2') auto
  2375 
  2376 lemma zip_append [simp]:
  2377  "[| length xs = length us |] ==>
  2378 zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"
  2379 by (simp add: zip_append1)
  2380 
  2381 lemma zip_rev:
  2382 "length xs = length ys ==> zip (rev xs) (rev ys) = rev (zip xs ys)"
  2383 by (induct rule:list_induct2, simp_all)
  2384 
  2385 lemma zip_map_map:
  2386   "zip (map f xs) (map g ys) = map (\<lambda> (x, y). (f x, g y)) (zip xs ys)"
  2387 proof (induct xs arbitrary: ys)
  2388   case (Cons x xs) note Cons_x_xs = Cons.hyps
  2389   show ?case
  2390   proof (cases ys)
  2391     case (Cons y ys')
  2392     show ?thesis unfolding Cons using Cons_x_xs by simp
  2393   qed simp
  2394 qed simp
  2395 
  2396 lemma zip_map1:
  2397   "zip (map f xs) ys = map (\<lambda>(x, y). (f x, y)) (zip xs ys)"
  2398 using zip_map_map[of f xs "\<lambda>x. x" ys] by simp
  2399 
  2400 lemma zip_map2:
  2401   "zip xs (map f ys) = map (\<lambda>(x, y). (x, f y)) (zip xs ys)"
  2402 using zip_map_map[of "\<lambda>x. x" xs f ys] by simp
  2403 
  2404 lemma map_zip_map:
  2405   "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"
  2406 unfolding zip_map1 by auto
  2407 
  2408 lemma map_zip_map2:
  2409   "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"
  2410 unfolding zip_map2 by auto
  2411 
  2412 text{* Courtesy of Andreas Lochbihler: *}
  2413 lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"
  2414 by(induct xs) auto
  2415 
  2416 lemma nth_zip [simp]:
  2417 "[| i < length xs; i < length ys|] ==> (zip xs ys)!i = (xs!i, ys!i)"
  2418 apply (induct ys arbitrary: i xs, simp)
  2419 apply (case_tac xs)
  2420  apply (simp_all add: nth.simps split: nat.split)
  2421 done
  2422 
  2423 lemma set_zip:
  2424 "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"
  2425 by(simp add: set_conv_nth cong: rev_conj_cong)
  2426 
  2427 lemma zip_same: "((a,b) \<in> set (zip xs xs)) = (a \<in> set xs \<and> a = b)"
  2428 by(induct xs) auto
  2429 
  2430 lemma zip_update:
  2431   "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
  2432 by(rule sym, simp add: update_zip)
  2433 
  2434 lemma zip_replicate [simp]:
  2435   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"
  2436 apply (induct i arbitrary: j, auto)
  2437 apply (case_tac j, auto)
  2438 done
  2439 
  2440 lemma take_zip:
  2441   "take n (zip xs ys) = zip (take n xs) (take n ys)"
  2442 apply (induct n arbitrary: xs ys)
  2443  apply simp
  2444 apply (case_tac xs, simp)
  2445 apply (case_tac ys, simp_all)
  2446 done
  2447 
  2448 lemma drop_zip:
  2449   "drop n (zip xs ys) = zip (drop n xs) (drop 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 zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P \<circ> fst) (zip xs ys)"
  2457 proof (induct xs arbitrary: ys)
  2458   case (Cons x xs) thus ?case by (cases ys) auto
  2459 qed simp
  2460 
  2461 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"
  2462 proof (induct xs arbitrary: ys)
  2463   case (Cons x xs) thus ?case by (cases ys) auto
  2464 qed simp
  2465 
  2466 lemma set_zip_leftD:
  2467   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"
  2468 by (induct xs ys rule:list_induct2') auto
  2469 
  2470 lemma set_zip_rightD:
  2471   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"
  2472 by (induct xs ys rule:list_induct2') auto
  2473 
  2474 lemma in_set_zipE:
  2475   "(x,y) : set(zip xs ys) \<Longrightarrow> (\<lbrakk> x : set xs; y : set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
  2476 by(blast dest: set_zip_leftD set_zip_rightD)
  2477 
  2478 lemma zip_map_fst_snd:
  2479   "zip (map fst zs) (map snd zs) = zs"
  2480   by (induct zs) simp_all
  2481 
  2482 lemma zip_eq_conv:
  2483   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"
  2484   by (auto simp add: zip_map_fst_snd)
  2485 
  2486 lemma in_set_zip:
  2487   "p \<in> set (zip xs ys) \<longleftrightarrow> (\<exists>n. xs ! n = fst p \<and> ys ! n = snd p
  2488     \<and> n < length xs \<and> n < length ys)"
  2489   by (cases p) (auto simp add: set_zip)
  2490 
  2491 lemma pair_list_eqI:
  2492   assumes "map fst xs = map fst ys" and "map snd xs = map snd ys"
  2493   shows "xs = ys"
  2494 proof -
  2495   from assms(1) have "length xs = length ys" by (rule map_eq_imp_length_eq)
  2496   from this assms show ?thesis
  2497     by (induct xs ys rule: list_induct2) (simp_all add: prod_eqI)
  2498 qed
  2499 
  2500 
  2501 subsubsection {* @{const list_all2} *}
  2502 
  2503 lemma list_all2_lengthD [intro?]: 
  2504   "list_all2 P xs ys ==> length xs = length ys"
  2505 by (simp add: list_all2_def)
  2506 
  2507 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"
  2508 by (simp add: list_all2_def)
  2509 
  2510 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"
  2511 by (simp add: list_all2_def)
  2512 
  2513 lemma list_all2_Cons [iff, code]:
  2514   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"
  2515 by (auto simp add: list_all2_def)
  2516 
  2517 lemma list_all2_Cons1:
  2518 "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"
  2519 by (cases ys) auto
  2520 
  2521 lemma list_all2_Cons2:
  2522 "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"
  2523 by (cases xs) auto
  2524 
  2525 lemma list_all2_induct
  2526   [consumes 1, case_names Nil Cons, induct set: list_all2]:
  2527   assumes P: "list_all2 P xs ys"
  2528   assumes Nil: "R [] []"
  2529   assumes Cons: "\<And>x xs y ys.
  2530     \<lbrakk>P x y; list_all2 P xs ys; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"
  2531   shows "R xs ys"
  2532 using P
  2533 by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)
  2534 
  2535 lemma list_all2_rev [iff]:
  2536 "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"
  2537 by (simp add: list_all2_def zip_rev cong: conj_cong)
  2538 
  2539 lemma list_all2_rev1:
  2540 "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"
  2541 by (subst list_all2_rev [symmetric]) simp
  2542 
  2543 lemma list_all2_append1:
  2544 "list_all2 P (xs @ ys) zs =
  2545 (EX us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>
  2546 list_all2 P xs us \<and> list_all2 P ys vs)"
  2547 apply (simp add: list_all2_def zip_append1)
  2548 apply (rule iffI)
  2549  apply (rule_tac x = "take (length xs) zs" in exI)
  2550  apply (rule_tac x = "drop (length xs) zs" in exI)
  2551  apply (force split: nat_diff_split simp add: min_def, clarify)
  2552 apply (simp add: ball_Un)
  2553 done
  2554 
  2555 lemma list_all2_append2:
  2556 "list_all2 P xs (ys @ zs) =
  2557 (EX us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>
  2558 list_all2 P us ys \<and> list_all2 P vs zs)"
  2559 apply (simp add: list_all2_def zip_append2)
  2560 apply (rule iffI)
  2561  apply (rule_tac x = "take (length ys) xs" in exI)
  2562  apply (rule_tac x = "drop (length ys) xs" in exI)
  2563  apply (force split: nat_diff_split simp add: min_def, clarify)
  2564 apply (simp add: ball_Un)
  2565 done
  2566 
  2567 lemma list_all2_append:
  2568   "length xs = length ys \<Longrightarrow>
  2569   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"
  2570 by (induct rule:list_induct2, simp_all)
  2571 
  2572 lemma list_all2_appendI [intro?, trans]:
  2573   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"
  2574 by (simp add: list_all2_append list_all2_lengthD)
  2575 
  2576 lemma list_all2_conv_all_nth:
  2577 "list_all2 P xs ys =
  2578 (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"
  2579 by (force simp add: list_all2_def set_zip)
  2580 
  2581 lemma list_all2_trans:
  2582   assumes tr: "!!a b c. P1 a b ==> P2 b c ==> P3 a c"
  2583   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> list_all2 P3 as cs"
  2584         (is "!!bs cs. PROP ?Q as bs cs")
  2585 proof (induct as)
  2586   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"
  2587   show "!!cs. PROP ?Q (x # xs) bs cs"
  2588   proof (induct bs)
  2589     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"
  2590     show "PROP ?Q (x # xs) (y # ys) cs"
  2591       by (induct cs) (auto intro: tr I1 I2)
  2592   qed simp
  2593 qed simp
  2594 
  2595 lemma list_all2_all_nthI [intro?]:
  2596   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"
  2597 by (simp add: list_all2_conv_all_nth)
  2598 
  2599 lemma list_all2I:
  2600   "\<forall>x \<in> set (zip a b). split P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"
  2601 by (simp add: list_all2_def)
  2602 
  2603 lemma list_all2_nthD:
  2604   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
  2605 by (simp add: list_all2_conv_all_nth)
  2606 
  2607 lemma list_all2_nthD2:
  2608   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
  2609 by (frule list_all2_lengthD) (auto intro: list_all2_nthD)
  2610 
  2611 lemma list_all2_map1: 
  2612   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"
  2613 by (simp add: list_all2_conv_all_nth)
  2614 
  2615 lemma list_all2_map2: 
  2616   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"
  2617 by (auto simp add: list_all2_conv_all_nth)
  2618 
  2619 lemma list_all2_refl [intro?]:
  2620   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"
  2621 by (simp add: list_all2_conv_all_nth)
  2622 
  2623 lemma list_all2_update_cong:
  2624   "\<lbrakk> list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"
  2625 by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)
  2626 
  2627 lemma list_all2_takeI [simp,intro?]:
  2628   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"
  2629 apply (induct xs arbitrary: n ys)
  2630  apply simp
  2631 apply (clarsimp simp add: list_all2_Cons1)
  2632 apply (case_tac n)
  2633 apply auto
  2634 done
  2635 
  2636 lemma list_all2_dropI [simp,intro?]:
  2637   "list_all2 P as bs \<Longrightarrow> list_all2 P (drop n as) (drop n bs)"
  2638 apply (induct as arbitrary: n bs, simp)
  2639 apply (clarsimp simp add: list_all2_Cons1)
  2640 apply (case_tac n, simp, simp)
  2641 done
  2642 
  2643 lemma list_all2_mono [intro?]:
  2644   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"
  2645 apply (induct xs arbitrary: ys, simp)
  2646 apply (case_tac ys, auto)
  2647 done
  2648 
  2649 lemma list_all2_eq:
  2650   "xs = ys \<longleftrightarrow> list_all2 (op =) xs ys"
  2651 by (induct xs ys rule: list_induct2') auto
  2652 
  2653 lemma list_eq_iff_zip_eq:
  2654   "xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x,y) \<in> set (zip xs ys). x = y)"
  2655 by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)
  2656 
  2657 
  2658 subsubsection {* @{const List.product} *}
  2659 
  2660 lemma product_list_set:
  2661   "set (List.product xs ys) = set xs \<times> set ys"
  2662   by (induct xs) auto
  2663 
  2664 lemma length_product [simp]:
  2665   "length (List.product xs ys) = length xs * length ys"
  2666   by (induct xs) simp_all
  2667 
  2668 lemma product_nth:
  2669   assumes "n < length xs * length ys"
  2670   shows "List.product xs ys ! n = (xs ! (n div length ys), ys ! (n mod length ys))"
  2671 using assms proof (induct xs arbitrary: n)
  2672   case Nil then show ?case by simp
  2673 next
  2674   case (Cons x xs n)
  2675   then have "length ys > 0" by auto
  2676   with Cons show ?case
  2677     by (auto simp add: nth_append not_less le_mod_geq le_div_geq)
  2678 qed
  2679 
  2680 
  2681 subsubsection {* @{const fold} with natural argument order *}
  2682 
  2683 lemma fold_simps [code]: -- {* eta-expanded variant for generated code -- enables tail-recursion optimisation in Scala *}
  2684   "fold f [] s = s"
  2685   "fold f (x # xs) s = fold f xs (f x s)" 
  2686   by simp_all
  2687 
  2688 lemma fold_remove1_split:
  2689   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"
  2690     and x: "x \<in> set xs"
  2691   shows "fold f xs = fold f (remove1 x xs) \<circ> f x"
  2692   using assms by (induct xs) (auto simp add: comp_assoc)
  2693 
  2694 lemma fold_cong [fundef_cong]:
  2695   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)
  2696     \<Longrightarrow> fold f xs a = fold g ys b"
  2697   by (induct ys arbitrary: a b xs) simp_all
  2698 
  2699 lemma fold_id:
  2700   assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"
  2701   shows "fold f xs = id"
  2702   using assms by (induct xs) simp_all
  2703 
  2704 lemma fold_commute:
  2705   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
  2706   shows "h \<circ> fold g xs = fold f xs \<circ> h"
  2707   using assms by (induct xs) (simp_all add: fun_eq_iff)
  2708 
  2709 lemma fold_commute_apply:
  2710   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
  2711   shows "h (fold g xs s) = fold f xs (h s)"
  2712 proof -
  2713   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)
  2714   then show ?thesis by (simp add: fun_eq_iff)
  2715 qed
  2716 
  2717 lemma fold_invariant: 
  2718   assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"
  2719     and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"
  2720   shows "P (fold f xs s)"
  2721   using assms by (induct xs arbitrary: s) simp_all
  2722 
  2723 lemma fold_append [simp]:
  2724   "fold f (xs @ ys) = fold f ys \<circ> fold f xs"
  2725   by (induct xs) simp_all
  2726 
  2727 lemma fold_map [code_unfold]:
  2728   "fold g (map f xs) = fold (g o f) xs"
  2729   by (induct xs) simp_all
  2730 
  2731 lemma fold_rev:
  2732   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
  2733   shows "fold f (rev xs) = fold f xs"
  2734 using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)
  2735 
  2736 lemma fold_Cons_rev:
  2737   "fold Cons xs = append (rev xs)"
  2738   by (induct xs) simp_all
  2739 
  2740 lemma rev_conv_fold [code]:
  2741   "rev xs = fold Cons xs []"
  2742   by (simp add: fold_Cons_rev)
  2743 
  2744 lemma fold_append_concat_rev:
  2745   "fold append xss = append (concat (rev xss))"
  2746   by (induct xss) simp_all
  2747 
  2748 text {* @{const Finite_Set.fold} and @{const fold} *}
  2749 
  2750 lemma (in comp_fun_commute) fold_set_fold_remdups:
  2751   "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
  2752   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)
  2753 
  2754 lemma (in ab_semigroup_mult) fold1_distinct_set_fold:
  2755   assumes "xs \<noteq> []"
  2756   assumes d: "distinct xs"
  2757   shows "Finite_Set.fold1 times (set xs) = List.fold times (tl xs) (hd xs)"
  2758 proof -
  2759   interpret comp_fun_commute times by (fact comp_fun_commute)
  2760   from assms obtain y ys where xs: "xs = y # ys"
  2761     by (cases xs) auto
  2762   then have *: "y \<notin> set ys" using assms by simp
  2763   from xs d have **: "remdups ys = ys"  by safe (induct ys, auto)
  2764   show ?thesis
  2765   proof (cases "set ys = {}")
  2766     case True with xs show ?thesis by simp
  2767   next
  2768     case False
  2769     then have "fold1 times (Set.insert y (set ys)) = Finite_Set.fold times y (set ys)"
  2770       by (simp_all add: fold1_eq_fold *)
  2771     with xs show ?thesis
  2772       by (simp add: fold_set_fold_remdups **)
  2773   qed
  2774 qed
  2775 
  2776 lemma (in comp_fun_idem) fold_set_fold:
  2777   "Finite_Set.fold f y (set xs) = fold f xs y"
  2778   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)
  2779 
  2780 lemma (in ab_semigroup_idem_mult) fold1_set_fold:
  2781   assumes "xs \<noteq> []"
  2782   shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)"
  2783 proof -
  2784   interpret comp_fun_idem times by (fact comp_fun_idem)
  2785   from assms obtain y ys where xs: "xs = y # ys"
  2786     by (cases xs) auto
  2787   show ?thesis
  2788   proof (cases "set ys = {}")
  2789     case True with xs show ?thesis by simp
  2790   next
  2791     case False
  2792     then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)"
  2793       by (simp only: finite_set fold1_eq_fold_idem)
  2794     with xs show ?thesis by (simp add: fold_set_fold mult_commute)
  2795   qed
  2796 qed
  2797 
  2798 lemma union_set_fold [code]:
  2799   "set xs \<union> A = fold Set.insert xs A"
  2800 proof -
  2801   interpret comp_fun_idem Set.insert
  2802     by (fact comp_fun_idem_insert)
  2803   show ?thesis by (simp add: union_fold_insert fold_set_fold)
  2804 qed
  2805 
  2806 lemma union_coset_filter [code]:
  2807   "List.coset xs \<union> A = List.coset (List.filter (\<lambda>x. x \<notin> A) xs)"
  2808   by auto
  2809 
  2810 lemma minus_set_fold [code]:
  2811   "A - set xs = fold Set.remove xs A"
  2812 proof -
  2813   interpret comp_fun_idem Set.remove
  2814     by (fact comp_fun_idem_remove)
  2815   show ?thesis
  2816     by (simp add: minus_fold_remove [of _ A] fold_set_fold)
  2817 qed
  2818 
  2819 lemma minus_coset_filter [code]:
  2820   "A - List.coset xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
  2821   by auto
  2822 
  2823 lemma inter_set_filter [code]:
  2824   "A \<inter> set xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
  2825   by auto
  2826 
  2827 lemma inter_coset_fold [code]:
  2828   "A \<inter> List.coset xs = fold Set.remove xs A"
  2829   by (simp add: Diff_eq [symmetric] minus_set_fold)
  2830 
  2831 lemma (in lattice) Inf_fin_set_fold:
  2832   "Inf_fin (set (x # xs)) = fold inf xs x"
  2833 proof -
  2834   interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2835     by (fact ab_semigroup_idem_mult_inf)
  2836   show ?thesis
  2837     by (simp add: Inf_fin_def fold1_set_fold del: set.simps)
  2838 qed
  2839 
  2840 declare Inf_fin_set_fold [code]
  2841 
  2842 lemma (in lattice) Sup_fin_set_fold:
  2843   "Sup_fin (set (x # xs)) = fold sup xs x"
  2844 proof -
  2845   interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2846     by (fact ab_semigroup_idem_mult_sup)
  2847   show ?thesis
  2848     by (simp add: Sup_fin_def fold1_set_fold del: set.simps)
  2849 qed
  2850 
  2851 declare Sup_fin_set_fold [code]
  2852 
  2853 lemma (in linorder) Min_fin_set_fold:
  2854   "Min (set (x # xs)) = fold min xs x"
  2855 proof -
  2856   interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2857     by (fact ab_semigroup_idem_mult_min)
  2858   show ?thesis
  2859     by (simp add: Min_def fold1_set_fold del: set.simps)
  2860 qed
  2861 
  2862 declare Min_fin_set_fold [code]
  2863 
  2864 lemma (in linorder) Max_fin_set_fold:
  2865   "Max (set (x # xs)) = fold max xs x"
  2866 proof -
  2867   interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2868     by (fact ab_semigroup_idem_mult_max)
  2869   show ?thesis
  2870     by (simp add: Max_def fold1_set_fold del: set.simps)
  2871 qed
  2872 
  2873 declare Max_fin_set_fold [code]
  2874 
  2875 lemma (in complete_lattice) Inf_set_fold:
  2876   "Inf (set xs) = fold inf xs top"
  2877 proof -
  2878   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2879     by (fact comp_fun_idem_inf)
  2880   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)
  2881 qed
  2882 
  2883 declare Inf_set_fold [where 'a = "'a set", code]
  2884 
  2885 lemma (in complete_lattice) Sup_set_fold:
  2886   "Sup (set xs) = fold sup xs bot"
  2887 proof -
  2888   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
  2889     by (fact comp_fun_idem_sup)
  2890   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)
  2891 qed
  2892 
  2893 declare Sup_set_fold [where 'a = "'a set", code]
  2894 
  2895 lemma (in complete_lattice) INF_set_fold:
  2896   "INFI (set xs) f = fold (inf \<circ> f) xs top"
  2897   unfolding INF_def set_map [symmetric] Inf_set_fold fold_map ..
  2898 
  2899 declare INF_set_fold [code]
  2900 
  2901 lemma (in complete_lattice) SUP_set_fold:
  2902   "SUPR (set xs) f = fold (sup \<circ> f) xs bot"
  2903   unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map ..
  2904 
  2905 declare SUP_set_fold [code]
  2906 
  2907 
  2908 subsubsection {* Fold variants: @{const foldr} and @{const foldl} *}
  2909 
  2910 text {* Correspondence *}
  2911 
  2912 lemma foldr_conv_fold [code_abbrev]:
  2913   "foldr f xs = fold f (rev xs)"
  2914   by (induct xs) simp_all
  2915 
  2916 lemma foldl_conv_fold:
  2917   "foldl f s xs = fold (\<lambda>x s. f s x) xs s"
  2918   by (induct xs arbitrary: s) simp_all
  2919 
  2920 lemma foldr_conv_foldl: -- {* The ``Third Duality Theorem'' in Bird \& Wadler: *}
  2921   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"
  2922   by (simp add: foldr_conv_fold foldl_conv_fold)
  2923 
  2924 lemma foldl_conv_foldr:
  2925   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"
  2926   by (simp add: foldr_conv_fold foldl_conv_fold)
  2927 
  2928 lemma foldr_fold:
  2929   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
  2930   shows "foldr f xs = fold f xs"
  2931   using assms unfolding foldr_conv_fold by (rule fold_rev)
  2932 
  2933 lemma foldr_cong [fundef_cong]:
  2934   "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"
  2935   by (auto simp add: foldr_conv_fold intro!: fold_cong)
  2936 
  2937 lemma foldl_cong [fundef_cong]:
  2938   "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"
  2939   by (auto simp add: foldl_conv_fold intro!: fold_cong)
  2940 
  2941 lemma foldr_append [simp]:
  2942   "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"
  2943   by (simp add: foldr_conv_fold)
  2944 
  2945 lemma foldl_append [simp]:
  2946   "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"
  2947   by (simp add: foldl_conv_fold)
  2948 
  2949 lemma foldr_map [code_unfold]:
  2950   "foldr g (map f xs) a = foldr (g o f) xs a"
  2951   by (simp add: foldr_conv_fold fold_map rev_map)
  2952 
  2953 lemma foldl_map [code_unfold]:
  2954   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"
  2955   by (simp add: foldl_conv_fold fold_map comp_def)
  2956 
  2957 lemma concat_conv_foldr [code]:
  2958   "concat xss = foldr append xss []"
  2959   by (simp add: fold_append_concat_rev foldr_conv_fold)
  2960 
  2961 
  2962 subsubsection {* @{const upt} *}
  2963 
  2964 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"
  2965 -- {* simp does not terminate! *}
  2966 by (induct j) auto
  2967 
  2968 lemmas upt_rec_numeral[simp] = upt_rec[of "numeral m" "numeral n"] for m n
  2969 
  2970 lemma upt_conv_Nil [simp]: "j <= i ==> [i..<j] = []"
  2971 by (subst upt_rec) simp
  2972 
  2973 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j <= i)"
  2974 by(induct j)simp_all
  2975 
  2976 lemma upt_eq_Cons_conv:
  2977  "([i..<j] = x#xs) = (i < j & i = x & [i+1..<j] = xs)"
  2978 apply(induct j arbitrary: x xs)
  2979  apply simp
  2980 apply(clarsimp simp add: append_eq_Cons_conv)
  2981 apply arith
  2982 done
  2983 
  2984 lemma upt_Suc_append: "i <= j ==> [i..<(Suc j)] = [i..<j]@[j]"
  2985 -- {* Only needed if @{text upt_Suc} is deleted from the simpset. *}
  2986 by simp
  2987 
  2988 lemma upt_conv_Cons: "i < j ==> [i..<j] = i # [Suc i..<j]"
  2989   by (simp add: upt_rec)
  2990 
  2991 lemma upt_add_eq_append: "i<=j ==> [i..<j+k] = [i..<j]@[j..<j+k]"
  2992 -- {* LOOPS as a simprule, since @{text "j <= j"}. *}
  2993 by (induct k) auto
  2994 
  2995 lemma length_upt [simp]: "length [i..<j] = j - i"
  2996 by (induct j) (auto simp add: Suc_diff_le)
  2997 
  2998 lemma nth_upt [simp]: "i + k < j ==> [i..<j] ! k = i + k"
  2999 apply (induct j)
  3000 apply (auto simp add: less_Suc_eq nth_append split: nat_diff_split)
  3001 done
  3002 
  3003 
  3004 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"
  3005 by(simp add:upt_conv_Cons)
  3006 
  3007 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"
  3008 apply(cases j)
  3009  apply simp
  3010 by(simp add:upt_Suc_append)
  3011 
  3012 lemma take_upt [simp]: "i+m <= n ==> take m [i..<n] = [i..<i+m]"
  3013 apply (induct m arbitrary: i, simp)
  3014 apply (subst upt_rec)
  3015 apply (rule sym)
  3016 apply (subst upt_rec)
  3017 apply (simp del: upt.simps)
  3018 done
  3019 
  3020 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"
  3021 apply(induct j)
  3022 apply auto
  3023 done
  3024 
  3025 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"
  3026 by (induct n) auto
  3027 
  3028 lemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"
  3029 apply (induct n m  arbitrary: i rule: diff_induct)
  3030 prefer 3 apply (subst map_Suc_upt[symmetric])
  3031 apply (auto simp add: less_diff_conv)
  3032 done
  3033 
  3034 lemma nth_take_lemma:
  3035   "k <= length xs ==> k <= length ys ==>
  3036      (!!i. i < k --> xs!i = ys!i) ==> take k xs = take k ys"
  3037 apply (atomize, induct k arbitrary: xs ys)
  3038 apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib, clarify)
  3039 txt {* Both lists must be non-empty *}
  3040 apply (case_tac xs, simp)
  3041 apply (case_tac ys, clarify)
  3042  apply (simp (no_asm_use))
  3043 apply clarify
  3044 txt {* prenexing's needed, not miniscoping *}
  3045 apply (simp (no_asm_use) add: all_simps [symmetric] del: all_simps)
  3046 apply blast
  3047 done
  3048 
  3049 lemma nth_equalityI:
  3050  "[| length xs = length ys; ALL i < length xs. xs!i = ys!i |] ==> xs = ys"
  3051   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all
  3052 
  3053 lemma map_nth:
  3054   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"
  3055   by (rule nth_equalityI, auto)
  3056 
  3057 (* needs nth_equalityI *)
  3058 lemma list_all2_antisym:
  3059   "\<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> 
  3060   \<Longrightarrow> xs = ys"
  3061   apply (simp add: list_all2_conv_all_nth) 
  3062   apply (rule nth_equalityI, blast, simp)
  3063   done
  3064 
  3065 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) ==> xs = ys"
  3066 -- {* The famous take-lemma. *}
  3067 apply (drule_tac x = "max (length xs) (length ys)" in spec)
  3068 apply (simp add: le_max_iff_disj)
  3069 done
  3070 
  3071 
  3072 lemma take_Cons':
  3073      "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"
  3074 by (cases n) simp_all
  3075 
  3076 lemma drop_Cons':
  3077      "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"
  3078 by (cases n) simp_all
  3079 
  3080 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"
  3081 by (cases n) simp_all
  3082 
  3083 lemma take_Cons_numeral [simp]:
  3084   "take (numeral v) (x # xs) = x # take (numeral v - 1) xs"
  3085 by (simp add: take_Cons')
  3086 
  3087 lemma drop_Cons_numeral [simp]:
  3088   "drop (numeral v) (x # xs) = drop (numeral v - 1) xs"
  3089 by (simp add: drop_Cons')
  3090 
  3091 lemma nth_Cons_numeral [simp]:
  3092   "(x # xs) ! numeral v = xs ! (numeral v - 1)"
  3093 by (simp add: nth_Cons')
  3094 
  3095 
  3096 subsubsection {* @{text upto}: interval-list on @{typ int} *}
  3097 
  3098 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where
  3099   "upto i j = (if i \<le> j then i # [i+1..j] else [])"
  3100 by auto
  3101 termination
  3102 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto
  3103 
  3104 declare upto.simps[simp del]
  3105 
  3106 lemmas upto_rec_numeral [simp] =
  3107   upto.simps[of "numeral m" "numeral n"]
  3108   upto.simps[of "numeral m" "neg_numeral n"]
  3109   upto.simps[of "neg_numeral m" "numeral n"]
  3110   upto.simps[of "neg_numeral m" "neg_numeral n"] for m n
  3111 
  3112 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
  3113 by(simp add: upto.simps)
  3114 
  3115 lemma upto_rec1: "i \<le> j \<Longrightarrow> [i..j] = i#[i+1..j]"
  3116 by(simp add: upto.simps)
  3117 
  3118 lemma upto_rec2: "i \<le> j \<Longrightarrow> [i..j] = [i..j - 1]@[j]"
  3119 proof(induct "nat(j-i)" arbitrary: i j)
  3120   case 0 thus ?case by(simp add: upto.simps)
  3121 next
  3122   case (Suc n)
  3123   hence "n = nat (j - (i + 1))" "i < j" by linarith+
  3124   from this(2) Suc.hyps(1)[OF this(1)] Suc(2,3) upto_rec1 show ?case by simp
  3125 qed
  3126 
  3127 lemma set_upto[simp]: "set[i..j] = {i..j}"
  3128 proof(induct i j rule:upto.induct)
  3129   case (1 i j)
  3130   from this show ?case
  3131     unfolding upto.simps[of i j] simp_from_to[of i j] by auto
  3132 qed
  3133 
  3134 text{* Tail recursive version for code generation: *}
  3135 
  3136 definition upto_aux :: "int \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list" where
  3137   "upto_aux i j js = [i..j] @ js"
  3138 
  3139 lemma upto_aux_rec [code]:
  3140   "upto_aux i j js = (if j<i then js else upto_aux i (j - 1) (j#js))"
  3141   by (simp add: upto_aux_def upto_rec2)
  3142 
  3143 lemma upto_code[code]: "[i..j] = upto_aux i j []"
  3144 by(simp add: upto_aux_def)
  3145 
  3146 
  3147 subsubsection {* @{const distinct} and @{const remdups} *}
  3148 
  3149 lemma distinct_tl:
  3150   "distinct xs \<Longrightarrow> distinct (tl xs)"
  3151   by (cases xs) simp_all
  3152 
  3153 lemma distinct_append [simp]:
  3154 "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"
  3155 by (induct xs) auto
  3156 
  3157 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"
  3158 by(induct xs) auto
  3159 
  3160 lemma set_remdups [simp]: "set (remdups xs) = set xs"
  3161 by (induct xs) (auto simp add: insert_absorb)
  3162 
  3163 lemma distinct_remdups [iff]: "distinct (remdups xs)"
  3164 by (induct xs) auto
  3165 
  3166 lemma distinct_remdups_id: "distinct xs ==> remdups xs = xs"
  3167 by (induct xs, auto)
  3168 
  3169 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"
  3170 by (metis distinct_remdups distinct_remdups_id)
  3171 
  3172 lemma finite_distinct_list: "finite A \<Longrightarrow> EX xs. set xs = A & distinct xs"
  3173 by (metis distinct_remdups finite_list set_remdups)
  3174 
  3175 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"
  3176 by (induct x, auto)
  3177 
  3178 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"
  3179 by (induct x, auto)
  3180 
  3181 lemma length_remdups_leq[iff]: "length(remdups xs) <= length xs"
  3182 by (induct xs) auto
  3183 
  3184 lemma length_remdups_eq[iff]:
  3185   "(length (remdups xs) = length xs) = (remdups xs = xs)"
  3186 apply(induct xs)
  3187  apply auto
  3188 apply(subgoal_tac "length (remdups xs) <= length xs")
  3189  apply arith
  3190 apply(rule length_remdups_leq)
  3191 done
  3192 
  3193 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"
  3194 apply(induct xs)
  3195 apply auto
  3196 done
  3197 
  3198 lemma distinct_map:
  3199   "distinct(map f xs) = (distinct xs & inj_on f (set xs))"
  3200 by (induct xs) auto
  3201 
  3202 lemma distinct_filter [simp]: "distinct xs ==> distinct (filter P xs)"
  3203 by (induct xs) auto
  3204 
  3205 lemma distinct_upt[simp]: "distinct[i..<j]"
  3206 by (induct j) auto
  3207 
  3208 lemma distinct_upto[simp]: "distinct[i..j]"
  3209 apply(induct i j rule:upto.induct)
  3210 apply(subst upto.simps)
  3211 apply(simp)
  3212 done
  3213 
  3214 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"
  3215 apply(induct xs arbitrary: i)
  3216  apply simp
  3217 apply (case_tac i)
  3218  apply simp_all
  3219 apply(blast dest:in_set_takeD)
  3220 done
  3221 
  3222 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"
  3223 apply(induct xs arbitrary: i)
  3224  apply simp
  3225 apply (case_tac i)
  3226  apply simp_all
  3227 done
  3228 
  3229 lemma distinct_list_update:
  3230 assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"
  3231 shows "distinct (xs[i:=a])"
  3232 proof (cases "i < length xs")
  3233   case True
  3234   with a have "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"
  3235     apply (drule_tac id_take_nth_drop) by simp
  3236   with d True show ?thesis
  3237     apply (simp add: upd_conv_take_nth_drop)
  3238     apply (drule subst [OF id_take_nth_drop]) apply assumption
  3239     apply simp apply (cases "a = xs!i") apply simp by blast
  3240 next
  3241   case False with d show ?thesis by auto
  3242 qed
  3243 
  3244 lemma distinct_concat:
  3245   assumes "distinct xs"
  3246   and "\<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys"
  3247   and "\<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}"
  3248   shows "distinct (concat xs)"
  3249   using assms by (induct xs) auto
  3250 
  3251 text {* It is best to avoid this indexed version of distinct, but
  3252 sometimes it is useful. *}
  3253 
  3254 lemma distinct_conv_nth:
  3255 "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j --> xs!i \<noteq> xs!j)"
  3256 apply (induct xs, simp, simp)
  3257 apply (rule iffI, clarsimp)
  3258  apply (case_tac i)
  3259 apply (case_tac j, simp)
  3260 apply (simp add: set_conv_nth)
  3261  apply (case_tac j)
  3262 apply (clarsimp simp add: set_conv_nth, simp)
  3263 apply (rule conjI)
  3264 (*TOO SLOW
  3265 apply (metis Zero_neq_Suc gr0_conv_Suc in_set_conv_nth lessI less_trans_Suc nth_Cons' nth_Cons_Suc)
  3266 *)
  3267  apply (clarsimp simp add: set_conv_nth)
  3268  apply (erule_tac x = 0 in allE, simp)
  3269  apply (erule_tac x = "Suc i" in allE, simp, clarsimp)
  3270 (*TOO SLOW
  3271 apply (metis Suc_Suc_eq lessI less_trans_Suc nth_Cons_Suc)
  3272 *)
  3273 apply (erule_tac x = "Suc i" in allE, simp)
  3274 apply (erule_tac x = "Suc j" in allE, simp)
  3275 done
  3276 
  3277 lemma nth_eq_iff_index_eq:
  3278  "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"
  3279 by(auto simp: distinct_conv_nth)
  3280 
  3281 lemma distinct_card: "distinct xs ==> card (set xs) = size xs"
  3282 by (induct xs) auto
  3283 
  3284 lemma card_distinct: "card (set xs) = size xs ==> distinct xs"
  3285 proof (induct xs)
  3286   case Nil thus ?case by simp
  3287 next
  3288   case (Cons x xs)
  3289   show ?case
  3290   proof (cases "x \<in> set xs")
  3291     case False with Cons show ?thesis by simp
  3292   next
  3293     case True with Cons.prems
  3294     have "card (set xs) = Suc (length xs)"
  3295       by (simp add: card_insert_if split: split_if_asm)
  3296     moreover have "card (set xs) \<le> length xs" by (rule card_length)
  3297     ultimately have False by simp
  3298     thus ?thesis ..
  3299   qed
  3300 qed
  3301 
  3302 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"
  3303 by (induct xs) (auto)
  3304 
  3305 lemma not_distinct_decomp: "~ distinct ws ==> EX xs ys zs y. ws = xs@[y]@ys@[y]@zs"
  3306 apply (induct n == "length ws" arbitrary:ws) apply simp
  3307 apply(case_tac ws) apply simp
  3308 apply (simp split:split_if_asm)
  3309 apply (metis Cons_eq_appendI eq_Nil_appendI split_list)
  3310 done
  3311 
  3312 lemma not_distinct_conv_prefix:
  3313   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"
  3314   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")
  3315 proof
  3316   assume "?L" then show "?R"
  3317   proof (induct "length as" arbitrary: as rule: less_induct)
  3318     case less
  3319     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"
  3320       using not_distinct_decomp[OF less.prems] by auto
  3321     show ?case
  3322     proof (cases "distinct (xs @ y # ys)")
  3323       case True
  3324       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)
  3325       then show ?thesis by blast
  3326     next
  3327       case False
  3328       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"
  3329         by atomize_elim auto
  3330       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)
  3331       then show ?thesis by blast
  3332     qed
  3333   qed
  3334 qed (auto simp: dec_def)
  3335 
  3336 lemma distinct_product:
  3337   assumes "distinct xs" and "distinct ys"
  3338   shows "distinct (List.product xs ys)"
  3339   using assms by (induct xs)
  3340     (auto intro: inj_onI simp add: product_list_set distinct_map)
  3341 
  3342 lemma length_remdups_concat:
  3343   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"
  3344   by (simp add: distinct_card [symmetric])
  3345 
  3346 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"
  3347 proof -
  3348   have xs: "concat[xs] = xs" by simp
  3349   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp
  3350 qed
  3351 
  3352 lemma remdups_remdups:
  3353   "remdups (remdups xs) = remdups xs"
  3354   by (induct xs) simp_all
  3355 
  3356 lemma distinct_butlast:
  3357   assumes "distinct xs"
  3358   shows "distinct (butlast xs)"
  3359 proof (cases "xs = []")
  3360   case False
  3361     from `xs \<noteq> []` obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
  3362     with `distinct xs` show ?thesis by simp
  3363 qed (auto)
  3364 
  3365 lemma remdups_map_remdups:
  3366   "remdups (map f (remdups xs)) = remdups (map f xs)"
  3367   by (induct xs) simp_all
  3368 
  3369 lemma distinct_zipI1:
  3370   assumes "distinct xs"
  3371   shows "distinct (zip xs ys)"
  3372 proof (rule zip_obtain_same_length)
  3373   fix xs' :: "'a list" and ys' :: "'b list" and n
  3374   assume "length xs' = length ys'"
  3375   assume "xs' = take n xs"
  3376   with assms have "distinct xs'" by simp
  3377   with `length xs' = length ys'` show "distinct (zip xs' ys')"
  3378     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
  3379 qed
  3380 
  3381 lemma distinct_zipI2:
  3382   assumes "distinct ys"
  3383   shows "distinct (zip xs ys)"
  3384 proof (rule zip_obtain_same_length)
  3385   fix xs' :: "'b list" and ys' :: "'a list" and n
  3386   assume "length xs' = length ys'"
  3387   assume "ys' = take n ys"
  3388   with assms have "distinct ys'" by simp
  3389   with `length xs' = length ys'` show "distinct (zip xs' ys')"
  3390     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
  3391 qed
  3392 
  3393 lemma set_take_disj_set_drop_if_distinct:
  3394   "distinct vs \<Longrightarrow> i \<le> j \<Longrightarrow> set (take i vs) \<inter> set (drop j vs) = {}"
  3395 by (auto simp: in_set_conv_nth distinct_conv_nth)
  3396 
  3397 (* The next two lemmas help Sledgehammer. *)
  3398 
  3399 lemma distinct_singleton: "distinct [x]" by simp
  3400 
  3401 lemma distinct_length_2_or_more:
  3402 "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"
  3403 by (metis distinct.simps(2) hd.simps hd_in_set list.simps(2) set_ConsD set_rev_mp set_subset_Cons)
  3404 
  3405 
  3406 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}
  3407 
  3408 lemma (in monoid_add) listsum_simps [simp]:
  3409   "listsum [] = 0"
  3410   "listsum (x # xs) = x + listsum xs"
  3411   by (simp_all add: listsum_def)
  3412 
  3413 lemma (in monoid_add) listsum_append [simp]:
  3414   "listsum (xs @ ys) = listsum xs + listsum ys"
  3415   by (induct xs) (simp_all add: add.assoc)
  3416 
  3417 lemma (in comm_monoid_add) listsum_rev [simp]:
  3418   "listsum (rev xs) = listsum xs"
  3419   by (simp add: listsum_def foldr_fold fold_rev fun_eq_iff add_ac)
  3420 
  3421 lemma (in monoid_add) fold_plus_listsum_rev:
  3422   "fold plus xs = plus (listsum (rev xs))"
  3423 proof
  3424   fix x
  3425   have "fold plus xs x = fold plus xs (x + 0)" by simp
  3426   also have "\<dots> = fold plus (x # xs) 0" by simp
  3427   also have "\<dots> = foldr plus (rev xs @ [x]) 0" by (simp add: foldr_conv_fold)
  3428   also have "\<dots> = listsum (rev xs @ [x])" by (simp add: listsum_def)
  3429   also have "\<dots> = listsum (rev xs) + listsum [x]" by simp
  3430   finally show "fold plus xs x = listsum (rev xs) + x" by simp
  3431 qed
  3432 
  3433 text{* Some syntactic sugar for summing a function over a list: *}
  3434 
  3435 syntax
  3436   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)
  3437 syntax (xsymbols)
  3438   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
  3439 syntax (HTML output)
  3440   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)
  3441 
  3442 translations -- {* Beware of argument permutation! *}
  3443   "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)"
  3444   "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"
  3445 
  3446 lemma (in comm_monoid_add) listsum_map_remove1:
  3447   "x \<in> set xs \<Longrightarrow> listsum (map f xs) = f x + listsum (map f (remove1 x xs))"
  3448   by (induct xs) (auto simp add: ac_simps)
  3449 
  3450 lemma (in monoid_add) list_size_conv_listsum:
  3451   "list_size f xs = listsum (map f xs) + size xs"
  3452   by (induct xs) auto
  3453 
  3454 lemma (in monoid_add) length_concat:
  3455   "length (concat xss) = listsum (map length xss)"
  3456   by (induct xss) simp_all
  3457 
  3458 lemma (in monoid_add) listsum_map_filter:
  3459   assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"
  3460   shows "listsum (map f (filter P xs)) = listsum (map f xs)"
  3461   using assms by (induct xs) auto
  3462 
  3463 lemma (in monoid_add) distinct_listsum_conv_Setsum:
  3464   "distinct xs \<Longrightarrow> listsum xs = Setsum (set xs)"
  3465   by (induct xs) simp_all
  3466 
  3467 lemma listsum_eq_0_nat_iff_nat [simp]:
  3468   "listsum ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"
  3469   by (induct ns) simp_all
  3470 
  3471 lemma member_le_listsum_nat:
  3472   "(n :: nat) \<in> set ns \<Longrightarrow> n \<le> listsum ns"
  3473   by (induct ns) auto
  3474 
  3475 lemma elem_le_listsum_nat:
  3476   "k < size ns \<Longrightarrow> ns ! k \<le> listsum (ns::nat list)"
  3477   by (rule member_le_listsum_nat) simp
  3478 
  3479 lemma listsum_update_nat:
  3480   "k < size ns \<Longrightarrow> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"
  3481 apply(induct ns arbitrary:k)
  3482  apply (auto split:nat.split)
  3483 apply(drule elem_le_listsum_nat)
  3484 apply arith
  3485 done
  3486 
  3487 lemma (in monoid_add) listsum_triv:
  3488   "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"
  3489   by (induct xs) (simp_all add: distrib_right)
  3490 
  3491 lemma (in monoid_add) listsum_0 [simp]:
  3492   "(\<Sum>x\<leftarrow>xs. 0) = 0"
  3493   by (induct xs) (simp_all add: distrib_right)
  3494 
  3495 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}
  3496 lemma (in ab_group_add) uminus_listsum_map:
  3497   "- listsum (map f xs) = listsum (map (uminus \<circ> f) xs)"
  3498   by (induct xs) simp_all
  3499 
  3500 lemma (in comm_monoid_add) listsum_addf:
  3501   "(\<Sum>x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)"
  3502   by (induct xs) (simp_all add: algebra_simps)
  3503 
  3504 lemma (in ab_group_add) listsum_subtractf:
  3505   "(\<Sum>x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)"
  3506   by (induct xs) (simp_all add: algebra_simps)
  3507 
  3508 lemma (in semiring_0) listsum_const_mult:
  3509   "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"
  3510   by (induct xs) (simp_all add: algebra_simps)
  3511 
  3512 lemma (in semiring_0) listsum_mult_const:
  3513   "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"
  3514   by (induct xs) (simp_all add: algebra_simps)
  3515 
  3516 lemma (in ordered_ab_group_add_abs) listsum_abs:
  3517   "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"
  3518   by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])
  3519 
  3520 lemma listsum_mono:
  3521   fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"
  3522   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)"
  3523   by (induct xs) (simp, simp add: add_mono)
  3524 
  3525 lemma (in monoid_add) listsum_distinct_conv_setsum_set:
  3526   "distinct xs \<Longrightarrow> listsum (map f xs) = setsum f (set xs)"
  3527   by (induct xs) simp_all
  3528 
  3529 lemma (in monoid_add) interv_listsum_conv_setsum_set_nat:
  3530   "listsum (map f [m..<n]) = setsum f (set [m..<n])"
  3531   by (simp add: listsum_distinct_conv_setsum_set)
  3532 
  3533 lemma (in monoid_add) interv_listsum_conv_setsum_set_int:
  3534   "listsum (map f [k..l]) = setsum f (set [k..l])"
  3535   by (simp add: listsum_distinct_conv_setsum_set)
  3536 
  3537 text {* General equivalence between @{const listsum} and @{const setsum} *}
  3538 lemma (in monoid_add) listsum_setsum_nth:
  3539   "listsum xs = (\<Sum> i = 0 ..< length xs. xs ! i)"
  3540   using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)
  3541 
  3542 
  3543 subsubsection {* @{const insert} *}
  3544 
  3545 lemma in_set_insert [simp]:
  3546   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"
  3547   by (simp add: List.insert_def)
  3548 
  3549 lemma not_in_set_insert [simp]:
  3550   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"
  3551   by (simp add: List.insert_def)
  3552 
  3553 lemma insert_Nil [simp]:
  3554   "List.insert x [] = [x]"
  3555   by simp
  3556 
  3557 lemma set_insert [simp]:
  3558   "set (List.insert x xs) = insert x (set xs)"
  3559   by (auto simp add: List.insert_def)
  3560 
  3561 lemma distinct_insert [simp]:
  3562   "distinct xs \<Longrightarrow> distinct (List.insert x xs)"
  3563   by (simp add: List.insert_def)
  3564 
  3565 lemma insert_remdups:
  3566   "List.insert x (remdups xs) = remdups (List.insert x xs)"
  3567   by (simp add: List.insert_def)
  3568 
  3569 
  3570 subsubsection {* @{const List.find} *}
  3571 
  3572 lemma find_None_iff: "List.find P xs = None \<longleftrightarrow> \<not> (\<exists>x. x \<in> set xs \<and> P x)"
  3573 proof (induction xs)
  3574   case Nil thus ?case by simp
  3575 next
  3576   case (Cons x xs) thus ?case by (fastforce split: if_splits)
  3577 qed
  3578 
  3579 lemma find_Some_iff:
  3580   "List.find P xs = Some x \<longleftrightarrow>
  3581   (\<exists>i<length xs. P (xs!i) \<and> x = xs!i \<and> (\<forall>j<i. \<not> P (xs!j)))"
  3582 proof (induction xs)
  3583   case Nil thus ?case by simp
  3584 next
  3585   case (Cons x xs) thus ?case
  3586     by(auto simp: nth_Cons' split: if_splits)
  3587       (metis One_nat_def diff_Suc_1 less_Suc_eq_0_disj)
  3588 qed
  3589 
  3590 lemma find_cong[fundef_cong]:
  3591   assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x" 
  3592   shows "List.find P xs = List.find Q ys"
  3593 proof (cases "List.find P xs")
  3594   case None thus ?thesis by (metis find_None_iff assms)
  3595 next
  3596   case (Some x)
  3597   hence "List.find Q ys = Some x" using assms
  3598     by (auto simp add: find_Some_iff)
  3599   thus ?thesis using Some by auto
  3600 qed
  3601 
  3602 
  3603 subsubsection {* @{const remove1} *}
  3604 
  3605 lemma remove1_append:
  3606   "remove1 x (xs @ ys) =
  3607   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"
  3608 by (induct xs) auto
  3609 
  3610 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"
  3611 by (induct zs) auto
  3612 
  3613 lemma in_set_remove1[simp]:
  3614   "a \<noteq> b \<Longrightarrow> a : set(remove1 b xs) = (a : set xs)"
  3615 apply (induct xs)
  3616 apply auto
  3617 done
  3618 
  3619 lemma set_remove1_subset: "set(remove1 x xs) <= set xs"
  3620 apply(induct xs)
  3621  apply simp
  3622 apply simp
  3623 apply blast
  3624 done
  3625 
  3626 lemma set_remove1_eq [simp]: "distinct xs ==> set(remove1 x xs) = set xs - {x}"
  3627 apply(induct xs)
  3628  apply simp
  3629 apply simp
  3630 apply blast
  3631 done
  3632 
  3633 lemma length_remove1:
  3634   "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"
  3635 apply (induct xs)
  3636  apply (auto dest!:length_pos_if_in_set)
  3637 done
  3638 
  3639 lemma remove1_filter_not[simp]:
  3640   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"
  3641 by(induct xs) auto
  3642 
  3643 lemma filter_remove1:
  3644   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"
  3645 by (induct xs) auto
  3646 
  3647 lemma notin_set_remove1[simp]: "x ~: set xs ==> x ~: set(remove1 y xs)"
  3648 apply(insert set_remove1_subset)
  3649 apply fast
  3650 done
  3651 
  3652 lemma distinct_remove1[simp]: "distinct xs ==> distinct(remove1 x xs)"
  3653 by (induct xs) simp_all
  3654 
  3655 lemma remove1_remdups:
  3656   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"
  3657   by (induct xs) simp_all
  3658 
  3659 lemma remove1_idem:
  3660   assumes "x \<notin> set xs"
  3661   shows "remove1 x xs = xs"
  3662   using assms by (induct xs) simp_all
  3663 
  3664 
  3665 subsubsection {* @{const removeAll} *}
  3666 
  3667 lemma removeAll_filter_not_eq:
  3668   "removeAll x = filter (\<lambda>y. x \<noteq> y)"
  3669 proof
  3670   fix xs
  3671   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"
  3672     by (induct xs) auto
  3673 qed
  3674 
  3675 lemma removeAll_append[simp]:
  3676   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"
  3677 by (induct xs) auto
  3678 
  3679 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"
  3680 by (induct xs) auto
  3681 
  3682 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"
  3683 by (induct xs) auto
  3684 
  3685 (* Needs count:: 'a \<Rightarrow> 'a list \<Rightarrow> nat
  3686 lemma length_removeAll:
  3687   "length(removeAll x xs) = length xs - count x xs"
  3688 *)
  3689 
  3690 lemma removeAll_filter_not[simp]:
  3691   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"
  3692 by(induct xs) auto
  3693 
  3694 lemma distinct_removeAll:
  3695   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"
  3696   by (simp add: removeAll_filter_not_eq)
  3697 
  3698 lemma distinct_remove1_removeAll:
  3699   "distinct xs ==> remove1 x xs = removeAll x xs"
  3700 by (induct xs) simp_all
  3701 
  3702 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>
  3703   map f (removeAll x xs) = removeAll (f x) (map f xs)"
  3704 by (induct xs) (simp_all add:inj_on_def)
  3705 
  3706 lemma map_removeAll_inj: "inj f \<Longrightarrow>
  3707   map f (removeAll x xs) = removeAll (f x) (map f xs)"
  3708 by(metis map_removeAll_inj_on subset_inj_on subset_UNIV)
  3709 
  3710 
  3711 subsubsection {* @{const replicate} *}
  3712 
  3713 lemma length_replicate [simp]: "length (replicate n x) = n"
  3714 by (induct n) auto
  3715 
  3716 lemma Ex_list_of_length: "\<exists>xs. length xs = n"
  3717 by (rule exI[of _ "replicate n undefined"]) simp
  3718 
  3719 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"
  3720 by (induct n) auto
  3721 
  3722 lemma map_replicate_const:
  3723   "map (\<lambda> x. k) lst = replicate (length lst) k"
  3724   by (induct lst) auto
  3725 
  3726 lemma replicate_app_Cons_same:
  3727 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"
  3728 by (induct n) auto
  3729 
  3730 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"
  3731 apply (induct n, simp)
  3732 apply (simp add: replicate_app_Cons_same)
  3733 done
  3734 
  3735 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"
  3736 by (induct n) auto
  3737 
  3738 text{* Courtesy of Matthias Daum: *}
  3739 lemma append_replicate_commute:
  3740   "replicate n x @ replicate k x = replicate k x @ replicate n x"
  3741 apply (simp add: replicate_add [THEN sym])
  3742 apply (simp add: add_commute)
  3743 done
  3744 
  3745 text{* Courtesy of Andreas Lochbihler: *}
  3746 lemma filter_replicate:
  3747   "filter P (replicate n x) = (if P x then replicate n x else [])"
  3748 by(induct n) auto
  3749 
  3750 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"
  3751 by (induct n) auto
  3752 
  3753 lemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"
  3754 by (induct n) auto
  3755 
  3756 lemma last_replicate [simp]: "n \<noteq> 0 ==> last (replicate n x) = x"
  3757 by (atomize (full), induct n) auto
  3758 
  3759 lemma nth_replicate[simp]: "i < n ==> (replicate n x)!i = x"
  3760 apply (induct n arbitrary: i, simp)
  3761 apply (simp add: nth_Cons split: nat.split)
  3762 done
  3763 
  3764 text{* Courtesy of Matthias Daum (2 lemmas): *}
  3765 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"
  3766 apply (case_tac "k \<le> i")
  3767  apply  (simp add: min_def)
  3768 apply (drule not_leE)
  3769 apply (simp add: min_def)
  3770 apply (subgoal_tac "replicate k x = replicate i x @ replicate (k - i) x")
  3771  apply  simp
  3772 apply (simp add: replicate_add [symmetric])
  3773 done
  3774 
  3775 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"
  3776 apply (induct k arbitrary: i)
  3777  apply simp
  3778 apply clarsimp
  3779 apply (case_tac i)
  3780  apply simp
  3781 apply clarsimp
  3782 done
  3783 
  3784 
  3785 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"
  3786 by (induct n) auto
  3787 
  3788 lemma set_replicate [simp]: "n \<noteq> 0 ==> set (replicate n x) = {x}"
  3789 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)
  3790 
  3791 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"
  3792 by auto
  3793 
  3794 lemma in_set_replicate[simp]: "(x : set (replicate n y)) = (x = y & n \<noteq> 0)"
  3795 by (simp add: set_replicate_conv_if)
  3796 
  3797 lemma Ball_set_replicate[simp]:
  3798   "(ALL x : set(replicate n a). P x) = (P a | n=0)"
  3799 by(simp add: set_replicate_conv_if)
  3800 
  3801 lemma Bex_set_replicate[simp]:
  3802   "(EX x : set(replicate n a). P x) = (P a & n\<noteq>0)"
  3803 by(simp add: set_replicate_conv_if)
  3804 
  3805 lemma replicate_append_same:
  3806   "replicate i x @ [x] = x # replicate i x"
  3807   by (induct i) simp_all
  3808 
  3809 lemma map_replicate_trivial:
  3810   "map (\<lambda>i. x) [0..<i] = replicate i x"
  3811   by (induct i) (simp_all add: replicate_append_same)
  3812 
  3813 lemma concat_replicate_trivial[simp]:
  3814   "concat (replicate i []) = []"
  3815   by (induct i) (auto simp add: map_replicate_const)
  3816 
  3817 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"
  3818 by (induct n) auto
  3819 
  3820 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"
  3821 by (induct n) auto
  3822 
  3823 lemma replicate_eq_replicate[simp]:
  3824   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n & (m\<noteq>0 \<longrightarrow> x=y))"
  3825 apply(induct m arbitrary: n)
  3826  apply simp
  3827 apply(induct_tac n)
  3828 apply auto
  3829 done
  3830 
  3831 lemma replicate_length_filter:
  3832   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"
  3833   by (induct xs) auto
  3834 
  3835 lemma comm_append_are_replicate:
  3836   fixes xs ys :: "'a list"
  3837   assumes "xs \<noteq> []" "ys \<noteq> []"
  3838   assumes "xs @ ys = ys @ xs"
  3839   shows "\<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"
  3840   using assms
  3841 proof (induct "length (xs @ ys)" arbitrary: xs ys rule: less_induct)
  3842   case less
  3843 
  3844   def xs' \<equiv> "if (length xs \<le> length ys) then xs else ys"
  3845     and ys' \<equiv> "if (length xs \<le> length ys) then ys else xs"
  3846   then have
  3847     prems': "length xs' \<le> length ys'"
  3848             "xs' @ ys' = ys' @ xs'"
  3849       and "xs' \<noteq> []"
  3850       and len: "length (xs @ ys) = length (xs' @ ys')"
  3851     using less by (auto intro: less.hyps)
  3852 
  3853   from prems'
  3854   obtain ws where "ys' = xs' @ ws"
  3855     by (auto simp: append_eq_append_conv2)
  3856 
  3857   have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ys'"
  3858   proof (cases "ws = []")
  3859     case True
  3860     then have "concat (replicate 1 xs') = xs'"
  3861       and "concat (replicate 1 xs') = ys'"
  3862       using `ys' = xs' @ ws` by auto
  3863     then show ?thesis by blast
  3864   next
  3865     case False
  3866     from `ys' = xs' @ ws` and `xs' @ ys' = ys' @ xs'`
  3867     have "xs' @ ws = ws @ xs'" by simp
  3868     then have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ws"
  3869       using False and `xs' \<noteq> []` and `ys' = xs' @ ws` and len
  3870       by (intro less.hyps) auto
  3871     then obtain m n zs where "concat (replicate m zs) = xs'"
  3872       and "concat (replicate n zs) = ws" by blast
  3873     moreover
  3874     then have "concat (replicate (m + n) zs) = ys'"
  3875       using `ys' = xs' @ ws`
  3876       by (simp add: replicate_add)
  3877     ultimately
  3878     show ?thesis by blast
  3879   qed
  3880   then show ?case
  3881     using xs'_def ys'_def by metis
  3882 qed
  3883 
  3884 lemma comm_append_is_replicate:
  3885   fixes xs ys :: "'a list"
  3886   assumes "xs \<noteq> []" "ys \<noteq> []"
  3887   assumes "xs @ ys = ys @ xs"
  3888   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"
  3889 
  3890 proof -
  3891   obtain m n zs where "concat (replicate m zs) = xs"
  3892     and "concat (replicate n zs) = ys"
  3893     using assms by (metis comm_append_are_replicate)
  3894   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"
  3895     using `xs \<noteq> []` and `ys \<noteq> []`
  3896     by (auto simp: replicate_add)
  3897   then show ?thesis by blast
  3898 qed
  3899 
  3900 
  3901 subsubsection {* @{const enumerate} *}
  3902 
  3903 lemma enumerate_simps [simp, code]:
  3904   "enumerate n [] = []"
  3905   "enumerate n (x # xs) = (n, x) # enumerate (Suc n) xs"
  3906   apply (auto simp add: enumerate_eq_zip not_le)
  3907   apply (cases "n < n + length xs")
  3908   apply (auto simp add: upt_conv_Cons)
  3909   done
  3910 
  3911 lemma length_enumerate [simp]:
  3912   "length (enumerate n xs) = length xs"
  3913   by (simp add: enumerate_eq_zip)
  3914 
  3915 lemma map_fst_enumerate [simp]:
  3916   "map fst (enumerate n xs) = [n..<n + length xs]"
  3917   by (simp add: enumerate_eq_zip)
  3918 
  3919 lemma map_snd_enumerate [simp]:
  3920   "map snd (enumerate n xs) = xs"
  3921   by (simp add: enumerate_eq_zip)
  3922   
  3923 lemma in_set_enumerate_eq:
  3924   "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"
  3925 proof -
  3926   { fix m
  3927     assume "n \<le> m"
  3928     moreover assume "m < length xs + n"
  3929     ultimately have "[n..<n + length xs] ! (m - n) = m \<and>
  3930       xs ! (m - n) = xs ! (m - n) \<and> m - n < length xs" by auto
  3931     then have "\<exists>q. [n..<n + length xs] ! q = m \<and>
  3932         xs ! q = xs ! (m - n) \<and> q < length xs" ..
  3933   } then show ?thesis by (cases p) (auto simp add: enumerate_eq_zip in_set_zip)
  3934 qed
  3935 
  3936 lemma nth_enumerate_eq:
  3937   assumes "m < length xs"
  3938   shows "enumerate n xs ! m = (n + m, xs ! m)"
  3939   using assms by (simp add: enumerate_eq_zip)
  3940 
  3941 lemma enumerate_replicate_eq:
  3942   "enumerate n (replicate m a) = map (\<lambda>q. (q, a)) [n..<n + m]"
  3943   by (rule pair_list_eqI)
  3944     (simp_all add: enumerate_eq_zip comp_def map_replicate_const)
  3945 
  3946 lemma enumerate_Suc_eq:
  3947   "enumerate (Suc n) xs = map (apfst Suc) (enumerate n xs)"
  3948   by (rule pair_list_eqI)
  3949     (simp_all add: not_le, simp del: map_map [simp del] add: map_Suc_upt map_map [symmetric])
  3950 
  3951 
  3952 subsubsection {* @{const rotate1} and @{const rotate} *}
  3953 
  3954 lemma rotate0[simp]: "rotate 0 = id"
  3955 by(simp add:rotate_def)
  3956 
  3957 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"
  3958 by(simp add:rotate_def)
  3959 
  3960 lemma rotate_add:
  3961   "rotate (m+n) = rotate m o rotate n"
  3962 by(simp add:rotate_def funpow_add)
  3963 
  3964 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"
  3965 by(simp add:rotate_add)
  3966 
  3967 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"
  3968 by(simp add:rotate_def funpow_swap1)
  3969 
  3970 lemma rotate1_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate1 xs = xs"
  3971 by(cases xs) simp_all
  3972 
  3973 lemma rotate_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate n xs = xs"
  3974 apply(induct n)
  3975  apply simp
  3976 apply (simp add:rotate_def)
  3977 done
  3978 
  3979 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"
  3980 by (cases xs) simp_all
  3981 
  3982 lemma rotate_drop_take:
  3983   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"
  3984 apply(induct n)
  3985  apply simp
  3986 apply(simp add:rotate_def)
  3987 apply(cases "xs = []")
  3988  apply (simp)
  3989 apply(case_tac "n mod length xs = 0")
  3990  apply(simp add:mod_Suc)
  3991  apply(simp add: rotate1_hd_tl drop_Suc take_Suc)
  3992 apply(simp add:mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]
  3993                 take_hd_drop linorder_not_le)
  3994 done
  3995 
  3996 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"
  3997 by(simp add:rotate_drop_take)
  3998 
  3999 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"
  4000 by(simp add:rotate_drop_take)
  4001 
  4002 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"
  4003 by (cases xs) simp_all
  4004 
  4005 lemma length_rotate[simp]: "length(rotate n xs) = length xs"
  4006 by (induct n arbitrary: xs) (simp_all add:rotate_def)
  4007 
  4008 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"
  4009 by (cases xs) auto
  4010 
  4011 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"
  4012 by (induct n) (simp_all add:rotate_def)
  4013 
  4014 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"
  4015 by(simp add:rotate_drop_take take_map drop_map)
  4016 
  4017 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"
  4018 by (cases xs) auto
  4019 
  4020 lemma set_rotate[simp]: "set(rotate n xs) = set xs"
  4021 by (induct n) (simp_all add:rotate_def)
  4022 
  4023 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"
  4024 by (cases xs) auto
  4025 
  4026 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"
  4027 by (induct n) (simp_all add:rotate_def)
  4028 
  4029 lemma rotate_rev:
  4030   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"
  4031 apply(simp add:rotate_drop_take rev_drop rev_take)
  4032 apply(cases "length xs = 0")
  4033  apply simp
  4034 apply(cases "n mod length xs = 0")
  4035  apply simp
  4036 apply(simp add:rotate_drop_take rev_drop rev_take)
  4037 done
  4038 
  4039 lemma hd_rotate_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd(rotate n xs) = xs!(n mod length xs)"
  4040 apply(simp add:rotate_drop_take hd_append hd_drop_conv_nth hd_conv_nth)
  4041 apply(subgoal_tac "length xs \<noteq> 0")
  4042  prefer 2 apply simp
  4043 using mod_less_divisor[of "length xs" n] by arith
  4044 
  4045 
  4046 subsubsection {* @{const sublist} --- a generalization of @{const nth} to sets *}
  4047 
  4048 lemma sublist_empty [simp]: "sublist xs {} = []"
  4049 by (auto simp add: sublist_def)
  4050 
  4051 lemma sublist_nil [simp]: "sublist [] A = []"
  4052 by (auto simp add: sublist_def)
  4053 
  4054 lemma length_sublist:
  4055   "length(sublist xs I) = card{i. i < length xs \<and> i : I}"
  4056 by(simp add: sublist_def length_filter_conv_card cong:conj_cong)
  4057 
  4058 lemma sublist_shift_lemma_Suc:
  4059   "map fst (filter (%p. P(Suc(snd p))) (zip xs is)) =
  4060    map fst (filter (%p. P(snd p)) (zip xs (map Suc is)))"
  4061 apply(induct xs arbitrary: "is")
  4062  apply simp
  4063 apply (case_tac "is")
  4064  apply simp
  4065 apply simp
  4066 done
  4067 
  4068 lemma sublist_shift_lemma:
  4069      "map fst [p<-zip xs [i..<i + length xs] . snd p : A] =
  4070       map fst [p<-zip xs [0..<length xs] . snd p + i : A]"
  4071 by (induct xs rule: rev_induct) (simp_all add: add_commute)
  4072 
  4073 lemma sublist_append:
  4074      "sublist (l @ l') A = sublist l A @ sublist l' {j. j + length l : A}"
  4075 apply (unfold sublist_def)
  4076 apply (induct l' rule: rev_induct, simp)
  4077 apply (simp add: upt_add_eq_append[of 0] sublist_shift_lemma)
  4078 apply (simp add: add_commute)
  4079 done
  4080 
  4081 lemma sublist_Cons:
  4082 "sublist (x # l) A = (if 0:A then [x] else []) @ sublist l {j. Suc j : A}"
  4083 apply (induct l rule: rev_induct)
  4084  apply (simp add: sublist_def)
  4085 apply (simp del: append_Cons add: append_Cons[symmetric] sublist_append)
  4086 done
  4087 
  4088 lemma set_sublist: "set(sublist xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"
  4089 apply(induct xs arbitrary: I)
  4090 apply(auto simp: sublist_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)
  4091 done
  4092 
  4093 lemma set_sublist_subset: "set(sublist xs I) \<subseteq> set xs"
  4094 by(auto simp add:set_sublist)
  4095 
  4096 lemma notin_set_sublistI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(sublist xs I)"
  4097 by(auto simp add:set_sublist)
  4098 
  4099 lemma in_set_sublistD: "x \<in> set(sublist xs I) \<Longrightarrow> x \<in> set xs"
  4100 by(auto simp add:set_sublist)
  4101 
  4102 lemma sublist_singleton [simp]: "sublist [x] A = (if 0 : A then [x] else [])"
  4103 by (simp add: sublist_Cons)
  4104 
  4105 
  4106 lemma distinct_sublistI[simp]: "distinct xs \<Longrightarrow> distinct(sublist xs I)"
  4107 apply(induct xs arbitrary: I)
  4108  apply simp
  4109 apply(auto simp add:sublist_Cons)
  4110 done
  4111 
  4112 
  4113 lemma sublist_upt_eq_take [simp]: "sublist l {..<n} = take n l"
  4114 apply (induct l rule: rev_induct, simp)
  4115 apply (simp split: nat_diff_split add: sublist_append)
  4116 done
  4117 
  4118 lemma filter_in_sublist:
  4119  "distinct xs \<Longrightarrow> filter (%x. x \<in> set(sublist xs s)) xs = sublist xs s"
  4120 proof (induct xs arbitrary: s)
  4121   case Nil thus ?case by simp
  4122 next
  4123   case (Cons a xs)
  4124   moreover hence "!x. x: set xs \<longrightarrow> x \<noteq> a" by auto
  4125   ultimately show ?case by(simp add: sublist_Cons cong:filter_cong)
  4126 qed
  4127 
  4128 
  4129 subsubsection {* @{const sublists} and @{const List.n_lists} *}
  4130 
  4131 lemma length_sublists:
  4132   "length (sublists xs) = 2 ^ length xs"
  4133   by (induct xs) (simp_all add: Let_def)
  4134 
  4135 lemma sublists_powset:
  4136   "set ` set (sublists xs) = Pow (set xs)"
  4137 proof -
  4138   have aux: "\<And>x A. set ` Cons x ` A = insert x ` set ` A"
  4139     by (auto simp add: image_def)
  4140   have "set (map set (sublists xs)) = Pow (set xs)"
  4141     by (induct xs)
  4142       (simp_all add: aux Let_def Pow_insert Un_commute comp_def del: map_map)
  4143   then show ?thesis by simp
  4144 qed
  4145 
  4146 lemma distinct_set_sublists:
  4147   assumes "distinct xs"
  4148   shows "distinct (map set (sublists xs))"
  4149 proof (rule card_distinct)
  4150   have "finite (set xs)" by rule
  4151   then have "card (Pow (set xs)) = 2 ^ card (set xs)" by (rule card_Pow)
  4152   with assms distinct_card [of xs]
  4153     have "card (Pow (set xs)) = 2 ^ length xs" by simp
  4154   then show "card (set (map set (sublists xs))) = length (map set (sublists xs))"
  4155     by (simp add: sublists_powset length_sublists)
  4156 qed
  4157 
  4158 lemma n_lists_Nil [simp]: "List.n_lists n [] = (if n = 0 then [[]] else [])"
  4159   by (induct n) simp_all
  4160 
  4161 lemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n"
  4162   by (induct n) (auto simp add: length_concat o_def listsum_triv)
  4163 
  4164 lemma length_n_lists_elem: "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
  4165   by (induct n arbitrary: ys) auto
  4166 
  4167 lemma set_n_lists: "set (List.n_lists n xs) = {ys. length ys = n \<and> set ys \<subseteq> set xs}"
  4168 proof (rule set_eqI)
  4169   fix ys :: "'a list"
  4170   show "ys \<in> set (List.n_lists n xs) \<longleftrightarrow> ys \<in> {ys. length ys = n \<and> set ys \<subseteq> set xs}"
  4171   proof -
  4172     have "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
  4173       by (induct n arbitrary: ys) auto
  4174     moreover have "\<And>x. ys \<in> set (List.n_lists n xs) \<Longrightarrow> x \<in> set ys \<Longrightarrow> x \<in> set xs"
  4175       by (induct n arbitrary: ys) auto
  4176     moreover have "set ys \<subseteq> set xs \<Longrightarrow> ys \<in> set (List.n_lists (length ys) xs)"
  4177       by (induct ys) auto
  4178     ultimately show ?thesis by auto
  4179   qed
  4180 qed
  4181 
  4182 lemma distinct_n_lists:
  4183   assumes "distinct xs"
  4184   shows "distinct (List.n_lists n xs)"
  4185 proof (rule card_distinct)
  4186   from assms have card_length: "card (set xs) = length xs" by (rule distinct_card)
  4187   have "card (set (List.n_lists n xs)) = card (set xs) ^ n"
  4188   proof (induct n)
  4189     case 0 then show ?case by simp
  4190   next
  4191     case (Suc n)
  4192     moreover have "card (\<Union>ys\<in>set (List.n_lists n xs). (\<lambda>y. y # ys) ` set xs)
  4193       = (\<Sum>ys\<in>set (List.n_lists n xs). card ((\<lambda>y. y # ys) ` set xs))"
  4194       by (rule card_UN_disjoint) auto
  4195     moreover have "\<And>ys. card ((\<lambda>y. y # ys) ` set xs) = card (set xs)"
  4196       by (rule card_image) (simp add: inj_on_def)
  4197     ultimately show ?case by auto
  4198   qed
  4199   also have "\<dots> = length xs ^ n" by (simp add: card_length)
  4200   finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)"
  4201     by (simp add: length_n_lists)
  4202 qed
  4203 
  4204 
  4205 subsubsection {* @{const splice} *}
  4206 
  4207 lemma splice_Nil2 [simp, code]: "splice xs [] = xs"
  4208 by (cases xs) simp_all
  4209 
  4210 declare splice.simps(1,3)[code]
  4211 declare splice.simps(2)[simp del]
  4212 
  4213 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"
  4214 by (induct xs ys rule: splice.induct) auto
  4215 
  4216 
  4217 subsubsection {* Transpose *}
  4218 
  4219 function transpose where
  4220 "transpose []             = []" |
  4221 "transpose ([]     # xss) = transpose xss" |
  4222 "transpose ((x#xs) # xss) =
  4223   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"
  4224 by pat_completeness auto
  4225 
  4226 lemma transpose_aux_filter_head:
  4227   "concat (map (list_case [] (\<lambda>h t. [h])) xss) =
  4228   map (\<lambda>xs. hd xs) [ys\<leftarrow>xss . ys \<noteq> []]"
  4229   by (induct xss) (auto split: list.split)
  4230 
  4231 lemma transpose_aux_filter_tail:
  4232   "concat (map (list_case [] (\<lambda>h t. [t])) xss) =
  4233   map (\<lambda>xs. tl xs) [ys\<leftarrow>xss . ys \<noteq> []]"
  4234   by (induct xss) (auto split: list.split)
  4235 
  4236 lemma transpose_aux_max:
  4237   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =
  4238   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) [ys\<leftarrow>xss . ys\<noteq>[]] 0))"
  4239   (is "max _ ?foldB = Suc (max _ ?foldA)")
  4240 proof (cases "[ys\<leftarrow>xss . ys\<noteq>[]] = []")
  4241   case True
  4242   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"
  4243   proof (induct xss)
  4244     case (Cons x xs)
  4245     moreover hence "x = []" by (cases x) auto
  4246     ultimately show ?case by auto
  4247   qed simp
  4248   thus ?thesis using True by simp
  4249 next
  4250   case False
  4251 
  4252   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0 - 1"
  4253     by (induct xss) auto
  4254   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0"
  4255     by (induct xss) auto
  4256 
  4257   have "0 < ?foldB"
  4258   proof -
  4259     from False
  4260     obtain z zs where zs: "[ys\<leftarrow>xss . ys \<noteq> []] = z#zs" by (auto simp: neq_Nil_conv)
  4261     hence "z \<in> set ([ys\<leftarrow>xss . ys \<noteq> []])" by auto
  4262     hence "z \<noteq> []" by auto
  4263     thus ?thesis
  4264       unfolding foldB zs
  4265       by (auto simp: max_def intro: less_le_trans)
  4266   qed
  4267   thus ?thesis
  4268     unfolding foldA foldB max_Suc_Suc[symmetric]
  4269     by simp
  4270 qed
  4271 
  4272 termination transpose
  4273   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")
  4274      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)
  4275 
  4276 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"
  4277   by (induct rule: transpose.induct) simp_all
  4278 
  4279 lemma length_transpose:
  4280   fixes xs :: "'a list list"
  4281   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"
  4282   by (induct rule: transpose.induct)
  4283     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max
  4284                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)
  4285 
  4286 lemma nth_transpose:
  4287   fixes xs :: "'a list list"
  4288   assumes "i < length (transpose xs)"
  4289   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) [ys \<leftarrow> xs. i < length ys]"
  4290 using assms proof (induct arbitrary: i rule: transpose.induct)
  4291   case (3 x xs xss)
  4292   def XS == "(x # xs) # xss"
  4293   hence [simp]: "XS \<noteq> []" by auto
  4294   thus ?case
  4295   proof (cases i)
  4296     case 0
  4297     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)
  4298   next
  4299     case (Suc j)
  4300     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp
  4301     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp
  4302     { fix x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"
  4303       by (cases x) simp_all
  4304     } note *** = this
  4305 
  4306     have j_less: "j < length (transpose (xs # concat (map (list_case [] (\<lambda>h t. [t])) xss)))"
  4307       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)
  4308 
  4309     show ?thesis
  4310       unfolding transpose.simps `i = Suc j` nth_Cons_Suc "3.hyps"[OF j_less]
  4311       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])
  4312       apply (rule_tac y=x in list.exhaust)
  4313       by auto
  4314   qed
  4315 qed simp_all
  4316 
  4317 lemma transpose_map_map:
  4318   "transpose (map (map f) xs) = map (map f) (transpose xs)"
  4319 proof (rule nth_equalityI, safe)
  4320   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"
  4321     by (simp add: length_transpose foldr_map comp_def)
  4322   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp
  4323 
  4324   fix i assume "i < length (transpose (map (map f) xs))"
  4325   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"
  4326     by (simp add: nth_transpose filter_map comp_def)
  4327 qed
  4328 
  4329 
  4330 subsubsection {* (In)finiteness *}
  4331 
  4332 lemma finite_maxlen:
  4333   "finite (M::'a list set) ==> EX n. ALL s:M. size s < n"
  4334 proof (induct rule: finite.induct)
  4335   case emptyI show ?case by simp
  4336 next
  4337   case (insertI M xs)
  4338   then obtain n where "\<forall>s\<in>M. length s < n" by blast
  4339   hence "ALL s:insert xs M. size s < max n (size xs) + 1" by auto
  4340   thus ?case ..
  4341 qed
  4342 
  4343 lemma lists_length_Suc_eq:
  4344   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =
  4345     (\<lambda>(xs, n). n#xs) ` ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"
  4346   by (auto simp: length_Suc_conv)
  4347 
  4348 lemma
  4349   assumes "finite A"
  4350   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
  4351   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"
  4352   using `finite A`
  4353   by (induct n)
  4354      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)
  4355 
  4356 lemma finite_lists_length_le:
  4357   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
  4358  (is "finite ?S")
  4359 proof-
  4360   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto
  4361   thus ?thesis by (auto intro!: finite_lists_length_eq[OF `finite A`] simp only:)
  4362 qed
  4363 
  4364 lemma card_lists_length_le:
  4365   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"
  4366 proof -
  4367   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"
  4368     using `finite A`
  4369     by (subst card_UN_disjoint)
  4370        (auto simp add: card_lists_length_eq finite_lists_length_eq)
  4371   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}"
  4372     by auto
  4373   finally show ?thesis by simp
  4374 qed
  4375 
  4376 lemma card_lists_distinct_length_eq:
  4377   assumes "k < card A"
  4378   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"
  4379 using assms
  4380 proof (induct k)
  4381   case 0
  4382   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto
  4383   then show ?case by simp
  4384 next
  4385   case (Suc k)
  4386   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"
  4387   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto
  4388 
  4389   from Suc have "k < card A" by simp
  4390   moreover have "finite A" using assms by (simp add: card_ge_0_finite)
  4391   moreover have "finite {xs. ?k_list k xs}"
  4392     using finite_lists_length_eq[OF `finite A`, of k]
  4393     by - (rule finite_subset, auto)
  4394   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"
  4395     by auto
  4396   moreover have "\<And>i. i \<in>Collect (?k_list k) \<Longrightarrow> card (A - set i) = card A - k"
  4397     by (simp add: card_Diff_subset distinct_card)
  4398   moreover have "{xs. ?k_list (Suc k) xs} =
  4399       (\<lambda>(xs, n). n#xs) ` \<Union>(\<lambda>xs. {xs} \<times> (A - set xs)) ` {xs. ?k_list k xs}"
  4400     by (auto simp: length_Suc_conv)
  4401   moreover
  4402   have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp
  4403   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"
  4404     by (subst setprod_insert[symmetric]) (simp add: atLeastAtMost_insertL)+
  4405   ultimately show ?case
  4406     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)
  4407 qed
  4408 
  4409 lemma infinite_UNIV_listI: "~ finite(UNIV::'a list set)"
  4410 apply(rule notI)
  4411 apply(drule finite_maxlen)
  4412 apply (metis UNIV_I length_replicate less_not_refl)
  4413 done
  4414 
  4415 
  4416 subsection {* Sorting *}
  4417 
  4418 text{* Currently it is not shown that @{const sort} returns a
  4419 permutation of its input because the nicest proof is via multisets,
  4420 which are not yet available. Alternatively one could define a function
  4421 that counts the number of occurrences of an element in a list and use
  4422 that instead of multisets to state the correctness property. *}
  4423 
  4424 context linorder
  4425 begin
  4426 
  4427 lemma length_insort [simp]:
  4428   "length (insort_key f x xs) = Suc (length xs)"
  4429   by (induct xs) simp_all
  4430 
  4431 lemma insort_key_left_comm:
  4432   assumes "f x \<noteq> f y"
  4433   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"
  4434   by (induct xs) (auto simp add: assms dest: antisym)
  4435 
  4436 lemma insort_left_comm:
  4437   "insort x (insort y xs) = insort y (insort x xs)"
  4438   by (cases "x = y") (auto intro: insort_key_left_comm)
  4439 
  4440 lemma comp_fun_commute_insort:
  4441   "comp_fun_commute insort"
  4442 proof
  4443 qed (simp add: insort_left_comm fun_eq_iff)
  4444 
  4445 lemma sort_key_simps [simp]:
  4446   "sort_key f [] = []"
  4447   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"
  4448   by (simp_all add: sort_key_def)
  4449 
  4450 lemma (in linorder) sort_key_conv_fold:
  4451   assumes "inj_on f (set xs)"
  4452   shows "sort_key f xs = fold (insort_key f) xs []"
  4453 proof -
  4454   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
  4455   proof (rule fold_rev, rule ext)
  4456     fix zs
  4457     fix x y
  4458     assume "x \<in> set xs" "y \<in> set xs"
  4459     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
  4460     have **: "x = y \<longleftrightarrow> y = x" by auto
  4461     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
  4462       by (induct zs) (auto intro: * simp add: **)
  4463   qed
  4464   then show ?thesis by (simp add: sort_key_def foldr_conv_fold)
  4465 qed
  4466 
  4467 lemma (in linorder) sort_conv_fold:
  4468   "sort xs = fold insort xs []"
  4469   by (rule sort_key_conv_fold) simp
  4470 
  4471 lemma length_sort[simp]: "length (sort_key f xs) = length xs"
  4472 by (induct xs, auto)
  4473 
  4474 lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"
  4475 apply(induct xs arbitrary: x) apply simp
  4476 by simp (blast intro: order_trans)
  4477 
  4478 lemma sorted_tl:
  4479   "sorted xs \<Longrightarrow> sorted (tl xs)"
  4480   by (cases xs) (simp_all add: sorted_Cons)
  4481 
  4482 lemma sorted_append:
  4483   "sorted (xs@ys) = (sorted xs & sorted ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"
  4484 by (induct xs) (auto simp add:sorted_Cons)
  4485 
  4486 lemma sorted_nth_mono:
  4487   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"
  4488 by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)
  4489 
  4490 lemma sorted_rev_nth_mono:
  4491   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"
  4492 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]
  4493       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]
  4494 by auto
  4495 
  4496 lemma sorted_nth_monoI:
  4497   "(\<And> i j. \<lbrakk> i \<le> j ; j < length xs \<rbrakk> \<Longrightarrow> xs ! i \<le> xs ! j) \<Longrightarrow> sorted xs"
  4498 proof (induct xs)
  4499   case (Cons x xs)
  4500   have "sorted xs"
  4501   proof (rule Cons.hyps)
  4502     fix i j assume "i \<le> j" and "j < length xs"
  4503     with Cons.prems[of "Suc i" "Suc j"]
  4504     show "xs ! i \<le> xs ! j" by auto
  4505   qed
  4506   moreover
  4507   {
  4508     fix y assume "y \<in> set xs"
  4509     then obtain j where "j < length xs" and "xs ! j = y"
  4510       unfolding in_set_conv_nth by blast
  4511     with Cons.prems[of 0 "Suc j"]
  4512     have "x \<le> y"
  4513       by auto
  4514   }
  4515   ultimately
  4516   show ?case
  4517     unfolding sorted_Cons by auto
  4518 qed simp
  4519 
  4520 lemma sorted_equals_nth_mono:
  4521   "sorted xs = (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"
  4522 by (auto intro: sorted_nth_monoI sorted_nth_mono)
  4523 
  4524 lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"
  4525 by (induct xs) auto
  4526 
  4527 lemma set_sort[simp]: "set(sort_key f xs) = set xs"
  4528 by (induct xs) (simp_all add:set_insort)
  4529 
  4530 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"
  4531 by(induct xs)(auto simp:set_insort)
  4532 
  4533 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"
  4534   by (induct xs) (simp_all add: distinct_insort)
  4535 
  4536 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"
  4537   by (induct xs) (auto simp:sorted_Cons set_insort)
  4538 
  4539 lemma sorted_insort: "sorted (insort x xs) = sorted xs"
  4540   using sorted_insort_key [where f="\<lambda>x. x"] by simp
  4541 
  4542 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"
  4543   by (induct xs) (auto simp:sorted_insort_key)
  4544 
  4545 theorem sorted_sort [simp]: "sorted (sort xs)"
  4546   using sorted_sort_key [where f="\<lambda>x. x"] by simp
  4547 
  4548 lemma sorted_butlast:
  4549   assumes "xs \<noteq> []" and "sorted xs"
  4550   shows "sorted (butlast xs)"
  4551 proof -
  4552   from `xs \<noteq> []` obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
  4553   with `sorted xs` show ?thesis by (simp add: sorted_append)
  4554 qed
  4555   
  4556 lemma insort_not_Nil [simp]:
  4557   "insort_key f a xs \<noteq> []"
  4558   by (induct xs) simp_all
  4559 
  4560 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
  4561 by (cases xs) auto
  4562 
  4563 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"
  4564   by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)
  4565 
  4566 lemma sorted_map_remove1:
  4567   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"
  4568   by (induct xs) (auto simp add: sorted_Cons)
  4569 
  4570 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"
  4571   using sorted_map_remove1 [of "\<lambda>x. x"] by simp
  4572 
  4573 lemma insort_key_remove1:
  4574   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"
  4575   shows "insort_key f a (remove1 a xs) = xs"
  4576 using assms proof (induct xs)
  4577   case (Cons x xs)
  4578   then show ?case
  4579   proof (cases "x = a")
  4580     case False
  4581     then have "f x \<noteq> f a" using Cons.prems by auto
  4582     then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons)
  4583     with `f x \<noteq> f a` show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons)
  4584   qed (auto simp: sorted_Cons insort_is_Cons)
  4585 qed simp
  4586 
  4587 lemma insort_remove1:
  4588   assumes "a \<in> set xs" and "sorted xs"
  4589   shows "insort a (remove1 a xs) = xs"
  4590 proof (rule insort_key_remove1)
  4591   from `a \<in> set xs` show "a \<in> set xs" .
  4592   from `sorted xs` show "sorted (map (\<lambda>x. x) xs)" by simp
  4593   from `a \<in> set xs` have "a \<in> set (filter (op = a) xs)" by auto
  4594   then have "set (filter (op = a) xs) \<noteq> {}" by auto
  4595   then have "filter (op = a) xs \<noteq> []" by (auto simp only: set_empty)
  4596   then have "length (filter (op = a) xs) > 0" by simp
  4597   then obtain n where n: "Suc n = length (filter (op = a) xs)"
  4598     by (cases "length (filter (op = a) xs)") simp_all
  4599   moreover have "replicate (Suc n) a = a # replicate n a"
  4600     by simp
  4601   ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)
  4602 qed
  4603 
  4604 lemma sorted_remdups[simp]:
  4605   "sorted l \<Longrightarrow> sorted (remdups l)"
  4606 by (induct l) (auto simp: sorted_Cons)
  4607 
  4608 lemma sorted_distinct_set_unique:
  4609 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"
  4610 shows "xs = ys"
  4611 proof -
  4612   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
  4613   from assms show ?thesis
  4614   proof(induct rule:list_induct2[OF 1])
  4615     case 1 show ?case by simp
  4616   next
  4617     case 2 thus ?case by (simp add:sorted_Cons)
  4618        (metis Diff_insert_absorb antisym insertE insert_iff)
  4619   qed
  4620 qed
  4621 
  4622 lemma map_sorted_distinct_set_unique:
  4623   assumes "inj_on f (set xs \<union> set ys)"
  4624   assumes "sorted (map f xs)" "distinct (map f xs)"
  4625     "sorted (map f ys)" "distinct (map f ys)"
  4626   assumes "set xs = set ys"
  4627   shows "xs = ys"
  4628 proof -
  4629   from assms have "map f xs = map f ys"
  4630     by (simp add: sorted_distinct_set_unique)
  4631   moreover with `inj_on f (set xs \<union> set ys)` show "xs = ys"
  4632     by (blast intro: map_inj_on)
  4633 qed
  4634 
  4635 lemma finite_sorted_distinct_unique:
  4636 shows "finite A \<Longrightarrow> EX! xs. set xs = A & sorted xs & distinct xs"
  4637 apply(drule finite_distinct_list)
  4638 apply clarify
  4639 apply(rule_tac a="sort xs" in ex1I)
  4640 apply (auto simp: sorted_distinct_set_unique)
  4641 done
  4642 
  4643 lemma
  4644   assumes "sorted xs"
  4645   shows sorted_take: "sorted (take n xs)"
  4646   and sorted_drop: "sorted (drop n xs)"
  4647 proof -
  4648   from assms have "sorted (take n xs @ drop n xs)" by simp
  4649   then show "sorted (take n xs)" and "sorted (drop n xs)"
  4650     unfolding sorted_append by simp_all
  4651 qed
  4652 
  4653 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"
  4654   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)
  4655 
  4656 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"
  4657   by (subst takeWhile_eq_take) (auto dest: sorted_take)
  4658 
  4659 lemma sorted_filter:
  4660   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"
  4661   by (induct xs) (simp_all add: sorted_Cons)
  4662 
  4663 lemma foldr_max_sorted:
  4664   assumes "sorted (rev xs)"
  4665   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"
  4666 using assms proof (induct xs)
  4667   case (Cons x xs)
  4668   moreover hence "sorted (rev xs)" using sorted_append by auto
  4669   ultimately show ?case
  4670     by (cases xs, auto simp add: sorted_append max_def)
  4671 qed simp
  4672 
  4673 lemma filter_equals_takeWhile_sorted_rev:
  4674   assumes sorted: "sorted (rev (map f xs))"
  4675   shows "[x \<leftarrow> xs. t < f x] = takeWhile (\<lambda> x. t < f x) xs"
  4676     (is "filter ?P xs = ?tW")
  4677 proof (rule takeWhile_eq_filter[symmetric])
  4678   let "?dW" = "dropWhile ?P xs"
  4679   fix x assume "x \<in> set ?dW"
  4680   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"
  4681     unfolding in_set_conv_nth by auto
  4682   hence "length ?tW + i < length (?tW @ ?dW)"
  4683     unfolding length_append by simp
  4684   hence i': "length (map f ?tW) + i < length (map f xs)" by simp
  4685   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>
  4686         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"
  4687     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]
  4688     unfolding map_append[symmetric] by simp
  4689   hence "f x \<le> f (?dW ! 0)"
  4690     unfolding nth_append_length_plus nth_i
  4691     using i preorder_class.le_less_trans[OF le0 i] by simp
  4692   also have "... \<le> t"
  4693     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]
  4694     using hd_conv_nth[of "?dW"] by simp
  4695   finally show "\<not> t < f x" by simp
  4696 qed
  4697 
  4698 lemma insort_insert_key_triv:
  4699   "f x \<in> f ` set xs \<Longrightarrow> insort_insert_key f x xs = xs"
  4700   by (simp add: insort_insert_key_def)
  4701 
  4702 lemma insort_insert_triv:
  4703   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"
  4704   using insort_insert_key_triv [of "\<lambda>x. x"] by simp
  4705 
  4706 lemma insort_insert_insort_key:
  4707   "f x \<notin> f ` set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"
  4708   by (simp add: insort_insert_key_def)
  4709 
  4710 lemma insort_insert_insort:
  4711   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"
  4712   using insort_insert_insort_key [of "\<lambda>x. x"] by simp
  4713 
  4714 lemma set_insort_insert:
  4715   "set (insort_insert x xs) = insert x (set xs)"
  4716   by (auto simp add: insort_insert_key_def set_insort)
  4717 
  4718 lemma distinct_insort_insert:
  4719   assumes "distinct xs"
  4720   shows "distinct (insort_insert_key f x xs)"
  4721   using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)
  4722 
  4723 lemma sorted_insort_insert_key:
  4724   assumes "sorted (map f xs)"
  4725   shows "sorted (map f (insort_insert_key f x xs))"
  4726   using assms by (simp add: insort_insert_key_def sorted_insort_key)
  4727 
  4728 lemma sorted_insort_insert:
  4729   assumes "sorted xs"
  4730   shows "sorted (insort_insert x xs)"
  4731   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp
  4732 
  4733 lemma filter_insort_triv:
  4734   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
  4735   by (induct xs) simp_all
  4736 
  4737 lemma filter_insort:
  4738   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
  4739   using assms by (induct xs)
  4740     (auto simp add: sorted_Cons, subst insort_is_Cons, auto)
  4741 
  4742 lemma filter_sort:
  4743   "filter P (sort_key f xs) = sort_key f (filter P xs)"
  4744   by (induct xs) (simp_all add: filter_insort_triv filter_insort)
  4745 
  4746 lemma sorted_map_same:
  4747   "sorted (map f [x\<leftarrow>xs. f x = g xs])"
  4748 proof (induct xs arbitrary: g)
  4749   case Nil then show ?case by simp
  4750 next
  4751   case (Cons x xs)
  4752   then have "sorted (map f [y\<leftarrow>xs . f y = (\<lambda>xs. f x) xs])" .
  4753   moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g \<circ> Cons x) xs])" .
  4754   ultimately show ?case by (simp_all add: sorted_Cons)
  4755 qed
  4756 
  4757 lemma sorted_same:
  4758   "sorted [x\<leftarrow>xs. x = g xs]"
  4759   using sorted_map_same [of "\<lambda>x. x"] by simp
  4760 
  4761 lemma remove1_insort [simp]:
  4762   "remove1 x (insort x xs) = xs"
  4763   by (induct xs) simp_all
  4764 
  4765 end
  4766 
  4767 lemma sorted_upt[simp]: "sorted[i..<j]"
  4768 by (induct j) (simp_all add:sorted_append)
  4769 
  4770 lemma sorted_upto[simp]: "sorted[i..j]"
  4771 apply(induct i j rule:upto.induct)
  4772 apply(subst upto.simps)
  4773 apply(simp add:sorted_Cons)
  4774 done
  4775 
  4776 
  4777 subsubsection {* @{const transpose} on sorted lists *}
  4778 
  4779 lemma sorted_transpose[simp]:
  4780   shows "sorted (rev (map length (transpose xs)))"
  4781   by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose
  4782     length_filter_conv_card intro: card_mono)
  4783 
  4784 lemma transpose_max_length:
  4785   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x \<noteq> []]"
  4786   (is "?L = ?R")
  4787 proof (cases "transpose xs = []")
  4788   case False
  4789   have "?L = foldr max (map length (transpose xs)) 0"
  4790     by (simp add: foldr_map comp_def)
  4791   also have "... = length (transpose xs ! 0)"
  4792     using False sorted_transpose by (simp add: foldr_max_sorted)
  4793   finally show ?thesis
  4794     using False by (simp add: nth_transpose)
  4795 next
  4796   case True
  4797   hence "[x \<leftarrow> xs. x \<noteq> []] = []"
  4798     by (auto intro!: filter_False simp: transpose_empty)
  4799   thus ?thesis by (simp add: transpose_empty True)
  4800 qed
  4801 
  4802 lemma length_transpose_sorted:
  4803   fixes xs :: "'a list list"
  4804   assumes sorted: "sorted (rev (map length xs))"
  4805   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"
  4806 proof (cases "xs = []")
  4807   case False
  4808   thus ?thesis
  4809     using foldr_max_sorted[OF sorted] False
  4810     unfolding length_transpose foldr_map comp_def
  4811     by simp
  4812 qed simp
  4813 
  4814 lemma nth_nth_transpose_sorted[simp]:
  4815   fixes xs :: "'a list list"
  4816   assumes sorted: "sorted (rev (map length xs))"
  4817   and i: "i < length (transpose xs)"
  4818   and j: "j < length [ys \<leftarrow> xs. i < length ys]"
  4819   shows "transpose xs ! i ! j = xs ! j  ! i"
  4820   using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]
  4821     nth_transpose[OF i] nth_map[OF j]
  4822   by (simp add: takeWhile_nth)
  4823 
  4824 lemma transpose_column_length:
  4825   fixes xs :: "'a list list"
  4826   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
  4827   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"
  4828 proof -
  4829   have "xs \<noteq> []" using `i < length xs` by auto
  4830   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]
  4831   { fix j assume "j \<le> i"
  4832     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this `i < length xs`]
  4833   } note sortedE = this[consumes 1]
  4834 
  4835   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}
  4836     = {..< length (xs ! i)}"
  4837   proof safe
  4838     fix j
  4839     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"
  4840     with this(2) nth_transpose[OF this(1)]
  4841     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp
  4842     from nth_mem[OF this] takeWhile_nth[OF this]
  4843     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)
  4844   next
  4845     fix j assume "j < length (xs ! i)"
  4846     thus "j < length (transpose xs)"
  4847       using foldr_max_sorted[OF sorted] `xs \<noteq> []` sortedE[OF le0]
  4848       by (auto simp: length_transpose comp_def foldr_map)
  4849 
  4850     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"
  4851       using `i < length xs` `j < length (xs ! i)` less_Suc_eq_le
  4852       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)
  4853     with nth_transpose[OF `j < length (transpose xs)`]
  4854     show "i < length (transpose xs ! j)" by simp
  4855   qed
  4856   thus ?thesis by (simp add: length_filter_conv_card)
  4857 qed
  4858 
  4859 lemma transpose_column:
  4860   fixes xs :: "'a list list"
  4861   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
  4862   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))
  4863     = xs ! i" (is "?R = _")
  4864 proof (rule nth_equalityI, safe)
  4865   show length: "length ?R = length (xs ! i)"
  4866     using transpose_column_length[OF assms] by simp
  4867 
  4868   fix j assume j: "j < length ?R"
  4869   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]
  4870   from j have j_less: "j < length (xs ! i)" using length by simp
  4871   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"
  4872   proof (rule length_takeWhile_less_P_nth)
  4873     show "Suc i \<le> length xs" using `i < length xs` by simp
  4874     fix k assume "k < Suc i"
  4875     hence "k \<le> i" by auto
  4876     with sorted_rev_nth_mono[OF sorted this] `i < length xs`
  4877     have "length (xs ! i) \<le> length (xs ! k)" by simp
  4878     thus "Suc j \<le> length (xs ! k)" using j_less by simp
  4879   qed
  4880   have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]"
  4881     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]
  4882     using i_less_tW by (simp_all add: Suc_le_eq)
  4883   from j show "?R ! j = xs ! i ! j"
  4884     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]
  4885     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])
  4886 qed
  4887 
  4888 lemma transpose_transpose:
  4889   fixes xs :: "'a list list"
  4890   assumes sorted: "sorted (rev (map length xs))"
  4891   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")
  4892 proof -
  4893   have len: "length ?L = length ?R"
  4894     unfolding length_transpose transpose_max_length
  4895     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]
  4896     by simp
  4897 
  4898   { fix i assume "i < length ?R"
  4899     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]
  4900     have "i < length xs" by simp
  4901   } note * = this
  4902   show ?thesis
  4903     by (rule nth_equalityI)
  4904        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)
  4905 qed
  4906 
  4907 theorem transpose_rectangle:
  4908   assumes "xs = [] \<Longrightarrow> n = 0"
  4909   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"
  4910   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"
  4911     (is "?trans = ?map")
  4912 proof (rule nth_equalityI)
  4913   have "sorted (rev (map length xs))"
  4914     by (auto simp: rev_nth rect intro!: sorted_nth_monoI)
  4915   from foldr_max_sorted[OF this] assms
  4916   show len: "length ?trans = length ?map"
  4917     by (simp_all add: length_transpose foldr_map comp_def)
  4918   moreover
  4919   { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs"
  4920       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }
  4921   ultimately show "\<forall>i < length ?trans. ?trans ! i = ?map ! i"
  4922     by (auto simp: nth_transpose intro: nth_equalityI)
  4923 qed
  4924 
  4925 
  4926 subsubsection {* @{text sorted_list_of_set} *}
  4927 
  4928 text{* This function maps (finite) linearly ordered sets to sorted
  4929 lists. Warning: in most cases it is not a good idea to convert from
  4930 sets to lists but one should convert in the other direction (via
  4931 @{const set}). *}
  4932 
  4933 context linorder
  4934 begin
  4935 
  4936 definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
  4937 "sorted_list_of_set = Finite_Set.fold insort []"
  4938 
  4939 lemma sorted_list_of_set_empty [simp]:
  4940   "sorted_list_of_set {} = []"
  4941   by (simp add: sorted_list_of_set_def)
  4942 
  4943 lemma sorted_list_of_set_insert [simp]:
  4944   assumes "finite A"
  4945   shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"
  4946 proof -
  4947   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
  4948   from assms show ?thesis
  4949     by (simp add: sorted_list_of_set_def fold_insert_remove)
  4950 qed
  4951 
  4952 lemma sorted_list_of_set [simp]:
  4953   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A) 
  4954     \<and> distinct (sorted_list_of_set A)"
  4955   by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)
  4956 
  4957 lemma sorted_list_of_set_sort_remdups [code]:
  4958   "sorted_list_of_set (set xs) = sort (remdups xs)"
  4959 proof -
  4960   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
  4961   show ?thesis by (simp add: sorted_list_of_set_def sort_conv_fold fold_set_fold_remdups)
  4962 qed
  4963 
  4964 lemma sorted_list_of_set_remove:
  4965   assumes "finite A"
  4966   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"
  4967 proof (cases "x \<in> A")
  4968   case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp
  4969   with False show ?thesis by (simp add: remove1_idem)
  4970 next
  4971   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)
  4972   with assms show ?thesis by simp
  4973 qed
  4974 
  4975 end
  4976 
  4977 lemma sorted_list_of_set_range [simp]:
  4978   "sorted_list_of_set {m..<n} = [m..<n]"
  4979   by (rule sorted_distinct_set_unique) simp_all
  4980 
  4981 
  4982 subsubsection {* @{text lists}: the list-forming operator over sets *}
  4983 
  4984 inductive_set
  4985   lists :: "'a set => 'a list set"
  4986   for A :: "'a set"
  4987 where
  4988     Nil [intro!, simp]: "[]: lists A"
  4989   | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"
  4990 
  4991 inductive_cases listsE [elim!,no_atp]: "x#l : lists A"
  4992 inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"
  4993 
  4994 inductive_simps listsp_simps[code]:
  4995   "listsp A []"
  4996   "listsp A (x # xs)"
  4997 
  4998 lemma listsp_mono [mono]: "A \<le> B ==> listsp A \<le> listsp B"
  4999 by (rule predicate1I, erule listsp.induct, blast+)
  5000 
  5001 lemmas lists_mono = listsp_mono [to_set]
  5002 
  5003 lemma listsp_infI:
  5004   assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using l
  5005 by induct blast+
  5006 
  5007 lemmas lists_IntI = listsp_infI [to_set]
  5008 
  5009 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"
  5010 proof (rule mono_inf [where f=listsp, THEN order_antisym])
  5011   show "mono listsp" by (simp add: mono_def listsp_mono)
  5012   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI)
  5013 qed
  5014 
  5015 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]
  5016 
  5017 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]
  5018 
  5019 lemma Cons_in_lists_iff[simp]: "x#xs : lists A \<longleftrightarrow> x:A \<and> xs : lists A"
  5020 by auto
  5021 
  5022 lemma append_in_listsp_conv [iff]:
  5023      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"
  5024 by (induct xs) auto
  5025 
  5026 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]
  5027 
  5028 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"
  5029 -- {* eliminate @{text listsp} in favour of @{text set} *}
  5030 by (induct xs) auto
  5031 
  5032 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]
  5033 
  5034 lemma in_listspD [dest!,no_atp]: "listsp A xs ==> \<forall>x\<in>set xs. A x"
  5035 by (rule in_listsp_conv_set [THEN iffD1])
  5036 
  5037 lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]
  5038 
  5039 lemma in_listspI [intro!,no_atp]: "\<forall>x\<in>set xs. A x ==> listsp A xs"
  5040 by (rule in_listsp_conv_set [THEN iffD2])
  5041 
  5042 lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]
  5043 
  5044 lemma lists_eq_set: "lists A = {xs. set xs <= A}"
  5045 by auto
  5046 
  5047 lemma lists_empty [simp]: "lists {} = {[]}"
  5048 by auto
  5049 
  5050 lemma lists_UNIV [simp]: "lists UNIV = UNIV"
  5051 by auto
  5052 
  5053 lemma lists_image: "lists (f`A) = map f ` lists A"
  5054 proof -
  5055   { fix xs have "\<forall>x\<in>set xs. x \<in> f ` A \<Longrightarrow> xs \<in> map f ` lists A"
  5056       by (induct xs) (auto simp del: map.simps simp add: map.simps[symmetric] intro!: imageI) }
  5057   then show ?thesis by auto
  5058 qed
  5059 
  5060 subsubsection {* Inductive definition for membership *}
  5061 
  5062 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
  5063 where
  5064     elem:  "ListMem x (x # xs)"
  5065   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"
  5066 
  5067 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"
  5068 apply (rule iffI)
  5069  apply (induct set: ListMem)
  5070   apply auto
  5071 apply (induct xs)
  5072  apply (auto intro: ListMem.intros)
  5073 done
  5074 
  5075 
  5076 subsubsection {* Lists as Cartesian products *}
  5077 
  5078 text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from
  5079 @{term A} and tail drawn from @{term Xs}.*}
  5080 
  5081 definition set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where
  5082 "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"
  5083 
  5084 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])`A"
  5085 by (auto simp add: set_Cons_def)
  5086 
  5087 text{*Yields the set of lists, all of the same length as the argument and
  5088 with elements drawn from the corresponding element of the argument.*}
  5089 
  5090 primrec listset :: "'a set list \<Rightarrow> 'a list set" where
  5091 "listset [] = {[]}" |
  5092 "listset (A # As) = set_Cons A (listset As)"
  5093 
  5094 
  5095 subsection {* Relations on Lists *}
  5096 
  5097 subsubsection {* Length Lexicographic Ordering *}
  5098 
  5099 text{*These orderings preserve well-foundedness: shorter lists 
  5100   precede longer lists. These ordering are not used in dictionaries.*}
  5101         
  5102 primrec -- {*The lexicographic ordering for lists of the specified length*}
  5103   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where
  5104 "lexn r 0 = {}" |
  5105 "lexn r (Suc n) =
  5106   (map_pair (%(x, xs). x#xs) (%(x, xs). x#xs) ` (r <*lex*> lexn r n)) Int
  5107   {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"
  5108 
  5109 definition lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5110 "lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}
  5111 
  5112 definition lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where
  5113 "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"
  5114         -- {*Compares lists by their length and then lexicographically*}
  5115 
  5116 lemma wf_lexn: "wf r ==> wf (lexn r n)"
  5117 apply (induct n, simp, simp)
  5118 apply(rule wf_subset)
  5119  prefer 2 apply (rule Int_lower1)
  5120 apply(rule wf_map_pair_image)
  5121  prefer 2 apply (rule inj_onI, auto)
  5122 done
  5123 
  5124 lemma lexn_length:
  5125   "(xs, ys) : lexn r n ==> length xs = n \<and> length ys = n"
  5126 by (induct n arbitrary: xs ys) auto
  5127 
  5128 lemma wf_lex [intro!]: "wf r ==> wf (lex r)"
  5129 apply (unfold lex_def)
  5130 apply (rule wf_UN)
  5131 apply (blast intro: wf_lexn, clarify)
  5132 apply (rename_tac m n)
  5133 apply (subgoal_tac "m \<noteq> n")
  5134  prefer 2 apply blast
  5135 apply (blast dest: lexn_length not_sym)
  5136 done
  5137 
  5138 lemma lexn_conv:
  5139   "lexn r n =
  5140     {(xs,ys). length xs = n \<and> length ys = n \<and>
  5141     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y):r)}"
  5142 apply (induct n, simp)
  5143 apply (simp add: image_Collect lex_prod_def, safe, blast)
  5144  apply (rule_tac x = "ab # xys" in exI, simp)
  5145 apply (case_tac xys, simp_all, blast)
  5146 done
  5147 
  5148 lemma lex_conv:
  5149   "lex r =
  5150     {(xs,ys). length xs = length ys \<and>
  5151     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y):r)}"
  5152 by (force simp add: lex_def lexn_conv)
  5153 
  5154 lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"
  5155 by (unfold lenlex_def) blast
  5156 
  5157 lemma lenlex_conv:
  5158     "lenlex r = {(xs,ys). length xs < length ys |
  5159                  length xs = length ys \<and> (xs, ys) : lex r}"
  5160 by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)
  5161 
  5162 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"
  5163 by (simp add: lex_conv)
  5164 
  5165 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"
  5166 by (simp add:lex_conv)
  5167 
  5168 lemma Cons_in_lex [simp]:
  5169     "((x # xs, y # ys) : lex r) =
  5170       ((x, y) : r \<and> length xs = length ys | x = y \<and> (xs, ys) : lex r)"
  5171 apply (simp add: lex_conv)
  5172 apply (rule iffI)
  5173  prefer 2 apply (blast intro: Cons_eq_appendI, clarify)
  5174 apply (case_tac xys, simp, simp)
  5175 apply blast
  5176 done
  5177 
  5178 
  5179 subsubsection {* Lexicographic Ordering *}
  5180 
  5181 text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".
  5182     This ordering does \emph{not} preserve well-foundedness.
  5183      Author: N. Voelker, March 2005. *} 
  5184 
  5185 definition lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5186 "lexord r = {(x,y). \<exists> a v. y = x @ a # v \<or>
  5187             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"
  5188 
  5189 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"
  5190 by (unfold lexord_def, induct_tac y, auto) 
  5191 
  5192 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"
  5193 by (unfold lexord_def, induct_tac x, auto)
  5194 
  5195 lemma lexord_cons_cons[simp]:
  5196      "((a # x, b # y) \<in> lexord r) = ((a,b)\<in> r | (a = b & (x,y)\<in> lexord r))"
  5197   apply (unfold lexord_def, safe, simp_all)
  5198   apply (case_tac u, simp, simp)
  5199   apply (case_tac u, simp, clarsimp, blast, blast, clarsimp)
  5200   apply (erule_tac x="b # u" in allE)
  5201   by force
  5202 
  5203 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons
  5204 
  5205 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"
  5206 by (induct_tac x, auto)  
  5207 
  5208 lemma lexord_append_left_rightI:
  5209      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"
  5210 by (induct_tac u, auto)
  5211 
  5212 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"
  5213 by (induct x, auto)
  5214 
  5215 lemma lexord_append_leftD:
  5216      "\<lbrakk> (x @ u, x @ v) \<in> lexord r; (! a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"
  5217 by (erule rev_mp, induct_tac x, auto)
  5218 
  5219 lemma lexord_take_index_conv: 
  5220    "((x,y) : lexord r) = 
  5221     ((length x < length y \<and> take (length x) y = x) \<or> 
  5222      (\<exists>i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) \<in> r))"
  5223   apply (unfold lexord_def Let_def, clarsimp) 
  5224   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)
  5225   apply auto 
  5226   apply (rule_tac x="hd (drop (length x) y)" in exI)
  5227   apply (rule_tac x="tl (drop (length x) y)" in exI)
  5228   apply (erule subst, simp add: min_def) 
  5229   apply (rule_tac x ="length u" in exI, simp) 
  5230   apply (rule_tac x ="take i x" in exI) 
  5231   apply (rule_tac x ="x ! i" in exI) 
  5232   apply (rule_tac x ="y ! i" in exI, safe) 
  5233   apply (rule_tac x="drop (Suc i) x" in exI)
  5234   apply (drule sym, simp add: drop_Suc_conv_tl) 
  5235   apply (rule_tac x="drop (Suc i) y" in exI)
  5236   by (simp add: drop_Suc_conv_tl) 
  5237 
  5238 -- {* lexord is extension of partial ordering List.lex *} 
  5239 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"
  5240   apply (rule_tac x = y in spec) 
  5241   apply (induct_tac x, clarsimp) 
  5242   by (clarify, case_tac x, simp, force)
  5243 
  5244 lemma lexord_irreflexive: "ALL x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"
  5245 by (induct xs) auto
  5246 
  5247 text{* By Ren\'e Thiemann: *}
  5248 lemma lexord_partial_trans: 
  5249   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)
  5250    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"
  5251 proof (induct xs arbitrary: ys zs)
  5252   case Nil
  5253   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)
  5254 next
  5255   case (Cons x xs yys zzs)
  5256   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def
  5257     by (cases yys, auto)
  5258   note Cons = Cons[unfolded yys]
  5259   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto
  5260   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def
  5261     by (cases zzs, auto)
  5262   note Cons = Cons[unfolded zzs]
  5263   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto
  5264   {
  5265     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"
  5266     from Cons(1)[OF _ this] Cons(2)
  5267     have "(xs,zs) \<in> lexord r" by auto
  5268   } note ind1 = this
  5269   {
  5270     assume "(x,y) \<in> r" and "(y,z) \<in> r"
  5271     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto
  5272   } note ind2 = this
  5273   from one two ind1 ind2
  5274   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast
  5275   thus ?case unfolding zzs by auto
  5276 qed
  5277 
  5278 lemma lexord_trans: 
  5279     "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"
  5280 by(auto simp: trans_def intro:lexord_partial_trans)
  5281 
  5282 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"
  5283 by (rule transI, drule lexord_trans, blast) 
  5284 
  5285 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"
  5286   apply (rule_tac x = y in spec) 
  5287   apply (induct_tac x, rule allI) 
  5288   apply (case_tac x, simp, simp) 
  5289   apply (rule allI, case_tac x, simp, simp) 
  5290   by blast
  5291 
  5292 
  5293 subsubsection {* Lexicographic combination of measure functions *}
  5294 
  5295 text {* These are useful for termination proofs *}
  5296 
  5297 definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"
  5298 
  5299 lemma wf_measures[simp]: "wf (measures fs)"
  5300 unfolding measures_def
  5301 by blast
  5302 
  5303 lemma in_measures[simp]: 
  5304   "(x, y) \<in> measures [] = False"
  5305   "(x, y) \<in> measures (f # fs)
  5306          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"  
  5307 unfolding measures_def
  5308 by auto
  5309 
  5310 lemma measures_less: "f x < f y ==> (x, y) \<in> measures (f#fs)"
  5311 by simp
  5312 
  5313 lemma measures_lesseq: "f x <= f y ==> (x, y) \<in> measures fs ==> (x, y) \<in> measures (f#fs)"
  5314 by auto
  5315 
  5316 
  5317 subsubsection {* Lifting Relations to Lists: one element *}
  5318 
  5319 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
  5320 "listrel1 r = {(xs,ys).
  5321    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"
  5322 
  5323 lemma listrel1I:
  5324   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>
  5325   (xs, ys) \<in> listrel1 r"
  5326 unfolding listrel1_def by auto
  5327 
  5328 lemma listrel1E:
  5329   "\<lbrakk> (xs, ys) \<in> listrel1 r;
  5330      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P
  5331    \<rbrakk> \<Longrightarrow> P"
  5332 unfolding listrel1_def by auto
  5333 
  5334 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"
  5335 unfolding listrel1_def by blast
  5336 
  5337 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"
  5338 unfolding listrel1_def by blast
  5339 
  5340 lemma Cons_listrel1_Cons [iff]:
  5341   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>
  5342    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"
  5343 by (simp add: listrel1_def Cons_eq_append_conv) (blast)
  5344 
  5345 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"
  5346 by (metis Cons_listrel1_Cons)
  5347 
  5348 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"
  5349 by (metis Cons_listrel1_Cons)
  5350 
  5351 lemma append_listrel1I:
  5352   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r
  5353     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"
  5354 unfolding listrel1_def
  5355 by auto (blast intro: append_eq_appendI)+
  5356 
  5357 lemma Cons_listrel1E1[elim!]:
  5358   assumes "(x # xs, ys) \<in> listrel1 r"
  5359     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
  5360     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"
  5361   shows R
  5362 using assms by (cases ys) blast+
  5363 
  5364 lemma Cons_listrel1E2[elim!]:
  5365   assumes "(xs, y # ys) \<in> listrel1 r"
  5366     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
  5367     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"
  5368   shows R
  5369 using assms by (cases xs) blast+
  5370 
  5371 lemma snoc_listrel1_snoc_iff:
  5372   "(xs @ [x], ys @ [y]) \<in> listrel1 r
  5373     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")
  5374 proof
  5375   assume ?L thus ?R
  5376     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)
  5377 next
  5378   assume ?R then show ?L unfolding listrel1_def by force
  5379 qed
  5380 
  5381 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"
  5382 unfolding listrel1_def by auto
  5383 
  5384 lemma listrel1_mono:
  5385   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"
  5386 unfolding listrel1_def by blast
  5387 
  5388 
  5389 lemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"
  5390 unfolding listrel1_def by blast
  5391 
  5392 lemma in_listrel1_converse:
  5393   "(x,y) : listrel1 (r^-1) \<longleftrightarrow> (x,y) : (listrel1 r)^-1"
  5394 unfolding listrel1_def by blast
  5395 
  5396 lemma listrel1_iff_update:
  5397   "(xs,ys) \<in> (listrel1 r)
  5398    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")
  5399 proof
  5400   assume "?L"
  5401   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"
  5402     unfolding listrel1_def by auto
  5403   then have "ys = xs[length u := y]" and "length u < length xs"
  5404     and "(xs ! length u, y) \<in> r" by auto
  5405   then show "?R" by auto
  5406 next
  5407   assume "?R"
  5408   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"
  5409     by auto
  5410   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"
  5411     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)
  5412   then show "?L" by (auto simp: listrel1_def)
  5413 qed
  5414 
  5415 
  5416 text{* Accessible part and wellfoundedness: *}
  5417 
  5418 lemma Cons_acc_listrel1I [intro!]:
  5419   "x \<in> acc r \<Longrightarrow> xs \<in> acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> acc (listrel1 r)"
  5420 apply (induct arbitrary: xs set: acc)
  5421 apply (erule thin_rl)
  5422 apply (erule acc_induct)
  5423 apply (rule accI)
  5424 apply (blast)
  5425 done
  5426 
  5427 lemma lists_accD: "xs \<in> lists (acc r) \<Longrightarrow> xs \<in> acc (listrel1 r)"
  5428 apply (induct set: lists)
  5429  apply (rule accI)
  5430  apply simp
  5431 apply (rule accI)
  5432 apply (fast dest: acc_downward)
  5433 done
  5434 
  5435 lemma lists_accI: "xs \<in> acc (listrel1 r) \<Longrightarrow> xs \<in> lists (acc r)"
  5436 apply (induct set: acc)
  5437 apply clarify
  5438 apply (rule accI)
  5439 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)
  5440 done
  5441 
  5442 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"
  5443 by(metis wf_acc_iff in_lists_conv_set lists_accI lists_accD Cons_in_lists_iff)
  5444 
  5445 
  5446 subsubsection {* Lifting Relations to Lists: all elements *}
  5447 
  5448 inductive_set
  5449   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"
  5450   for r :: "('a \<times> 'b) set"
  5451 where
  5452     Nil:  "([],[]) \<in> listrel r"
  5453   | Cons: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (x#xs, y#ys) \<in> listrel r"
  5454 
  5455 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"
  5456 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"
  5457 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"
  5458 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"
  5459 
  5460 
  5461 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"
  5462 by(induct rule: listrel.induct) auto
  5463 
  5464 lemma listrel_iff_zip [code_unfold]: "(xs,ys) : listrel r \<longleftrightarrow>
  5465   length xs = length ys & (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")
  5466 proof
  5467   assume ?L thus ?R by induct (auto intro: listrel_eq_len)
  5468 next
  5469   assume ?R thus ?L
  5470     apply (clarify)
  5471     by (induct rule: list_induct2) (auto intro: listrel.intros)
  5472 qed
  5473 
  5474 lemma listrel_iff_nth: "(xs,ys) : listrel r \<longleftrightarrow>
  5475   length xs = length ys & (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")
  5476 by (auto simp add: all_set_conv_all_nth listrel_iff_zip)
  5477 
  5478 
  5479 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"
  5480 apply clarify  
  5481 apply (erule listrel.induct)
  5482 apply (blast intro: listrel.intros)+
  5483 done
  5484 
  5485 lemma listrel_subset: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"
  5486 apply clarify 
  5487 apply (erule listrel.induct, auto) 
  5488 done
  5489 
  5490 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)" 
  5491 apply (simp add: refl_on_def listrel_subset Ball_def)
  5492 apply (rule allI) 
  5493 apply (induct_tac x) 
  5494 apply (auto intro: listrel.intros)
  5495 done
  5496 
  5497 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)" 
  5498 apply (auto simp add: sym_def)
  5499 apply (erule listrel.induct) 
  5500 apply (blast intro: listrel.intros)+
  5501 done
  5502 
  5503 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)" 
  5504 apply (simp add: trans_def)
  5505 apply (intro allI) 
  5506 apply (rule impI) 
  5507 apply (erule listrel.induct) 
  5508 apply (blast intro: listrel.intros)+
  5509 done
  5510 
  5511 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"
  5512 by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans) 
  5513 
  5514 lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"
  5515 using listrel_refl_on[of UNIV, OF refl_rtrancl]
  5516 by(auto simp: refl_on_def)
  5517 
  5518 lemma listrel_rtrancl_trans:
  5519   "\<lbrakk> (xs,ys) : listrel(r^*);  (ys,zs) : listrel(r^*) \<rbrakk>
  5520   \<Longrightarrow> (xs,zs) : listrel(r^*)"
  5521 by (metis listrel_trans trans_def trans_rtrancl)
  5522 
  5523 
  5524 lemma listrel_Nil [simp]: "listrel r `` {[]} = {[]}"
  5525 by (blast intro: listrel.intros)
  5526 
  5527 lemma listrel_Cons:
  5528      "listrel r `` {x#xs} = set_Cons (r``{x}) (listrel r `` {xs})"
  5529 by (auto simp add: set_Cons_def intro: listrel.intros)
  5530 
  5531 text {* Relating @{term listrel1}, @{term listrel} and closures: *}
  5532 
  5533 lemma listrel1_rtrancl_subset_rtrancl_listrel1:
  5534   "listrel1 (r^*) \<subseteq> (listrel1 r)^*"
  5535 proof (rule subrelI)
  5536   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r^*)"
  5537   { fix x y us vs
  5538     have "(x,y) : r^* \<Longrightarrow> (us @ x # vs, us @ y # vs) : (listrel1 r)^*"
  5539     proof(induct rule: rtrancl.induct)
  5540       case rtrancl_refl show ?case by simp
  5541     next
  5542       case rtrancl_into_rtrancl thus ?case
  5543         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)
  5544     qed }
  5545   thus "(xs,ys) \<in> (listrel1 r)^*" using 1 by(blast elim: listrel1E)
  5546 qed
  5547 
  5548 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)^* \<Longrightarrow> length x = length y"
  5549 by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)
  5550 
  5551 lemma rtrancl_listrel1_ConsI1:
  5552   "(xs,ys) : (listrel1 r)^* \<Longrightarrow> (x#xs,x#ys) : (listrel1 r)^*"
  5553 apply(induct rule: rtrancl.induct)
  5554  apply simp
  5555 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)
  5556 
  5557 lemma rtrancl_listrel1_ConsI2:
  5558   "(x,y) \<in> r^* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)^*
  5559   \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)^*"
  5560   by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1 
  5561     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])
  5562 
  5563 lemma listrel1_subset_listrel:
  5564   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"
  5565 by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)
  5566 
  5567 lemma listrel_reflcl_if_listrel1:
  5568   "(xs,ys) : listrel1 r \<Longrightarrow> (xs,ys) : listrel(r^*)"
  5569 by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)
  5570 
  5571 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"
  5572 proof
  5573   { fix x y assume "(x,y) \<in> listrel (r^*)"
  5574     then have "(x,y) \<in> (listrel1 r)^*"
  5575     by induct (auto intro: rtrancl_listrel1_ConsI2) }
  5576   then show "listrel (r^*) \<subseteq> (listrel1 r)^*"
  5577     by (rule subrelI)
  5578 next
  5579   show "listrel (r^*) \<supseteq> (listrel1 r)^*"
  5580   proof(rule subrelI)
  5581     fix xs ys assume "(xs,ys) \<in> (listrel1 r)^*"
  5582     then show "(xs,ys) \<in> listrel (r^*)"
  5583     proof induct
  5584       case base show ?case by(auto simp add: listrel_iff_zip set_zip)
  5585     next
  5586       case (step ys zs)
  5587       thus ?case  by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)
  5588     qed
  5589   qed
  5590 qed
  5591 
  5592 lemma rtrancl_listrel1_if_listrel:
  5593   "(xs,ys) : listrel r \<Longrightarrow> (xs,ys) : (listrel1 r)^*"
  5594 by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)
  5595 
  5596 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)^*"
  5597 by(fast intro:rtrancl_listrel1_if_listrel)
  5598 
  5599 
  5600 subsection {* Size function *}
  5601 
  5602 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"
  5603 by (rule is_measure_trivial)
  5604 
  5605 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (option_size f)"
  5606 by (rule is_measure_trivial)
  5607 
  5608 lemma list_size_estimation[termination_simp]: 
  5609   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < list_size f xs"
  5610 by (induct xs) auto
  5611 
  5612 lemma list_size_estimation'[termination_simp]: 
  5613   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> list_size f xs"
  5614 by (induct xs) auto
  5615 
  5616 lemma list_size_map[simp]: "list_size f (map g xs) = list_size (f o g) xs"
  5617 by (induct xs) auto
  5618 
  5619 lemma list_size_append[simp]: "list_size f (xs @ ys) = list_size f xs + list_size f ys"
  5620 by (induct xs, auto)
  5621 
  5622 lemma list_size_pointwise[termination_simp]: 
  5623   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"
  5624 by (induct xs) force+
  5625 
  5626 
  5627 subsection {* Monad operation *}
  5628 
  5629 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
  5630 "bind xs f = concat (map f xs)"
  5631 
  5632 hide_const (open) bind
  5633 
  5634 lemma bind_simps [simp]:
  5635   "List.bind [] f = []"
  5636   "List.bind (x # xs) f = f x @ List.bind xs f"
  5637   by (simp_all add: bind_def)
  5638 
  5639 
  5640 subsection {* Transfer *}
  5641 
  5642 definition embed_list :: "nat list \<Rightarrow> int list" where
  5643 "embed_list l = map int l"
  5644 
  5645 definition nat_list :: "int list \<Rightarrow> bool" where
  5646 "nat_list l = nat_set (set l)"
  5647 
  5648 definition return_list :: "int list \<Rightarrow> nat list" where
  5649 "return_list l = map nat l"
  5650 
  5651 lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>
  5652     embed_list (return_list l) = l"
  5653   unfolding embed_list_def return_list_def nat_list_def nat_set_def
  5654   apply (induct l)
  5655   apply auto
  5656 done
  5657 
  5658 lemma transfer_nat_int_list_functions:
  5659   "l @ m = return_list (embed_list l @ embed_list m)"
  5660   "[] = return_list []"
  5661   unfolding return_list_def embed_list_def
  5662   apply auto
  5663   apply (induct l, auto)
  5664   apply (induct m, auto)
  5665 done
  5666 
  5667 (*
  5668 lemma transfer_nat_int_fold1: "fold f l x =
  5669     fold (%x. f (nat x)) (embed_list l) x";
  5670 *)
  5671 
  5672 
  5673 subsection {* Code generation *}
  5674 
  5675 subsubsection {* Counterparts for set-related operations *}
  5676 
  5677 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
  5678 [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"
  5679 
  5680 text {*
  5681   Use @{text member} only for generating executable code.  Otherwise use
  5682   @{prop "x \<in> set xs"} instead --- it is much easier to reason about.
  5683 *}
  5684 
  5685 lemma member_rec [code]:
  5686   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"
  5687   "member [] y \<longleftrightarrow> False"
  5688   by (auto simp add: member_def)
  5689 
  5690 lemma in_set_member (* FIXME delete candidate *):
  5691   "x \<in> set xs \<longleftrightarrow> member xs x"
  5692   by (simp add: member_def)
  5693 
  5694 definition list_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  5695 list_all_iff [code_abbrev]: "list_all P xs \<longleftrightarrow> Ball (set xs) P"
  5696 
  5697 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  5698 list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"
  5699 
  5700 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  5701 list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"
  5702 
  5703 text {*
  5704   Usually you should prefer @{text "\<forall>x\<in>set xs"}, @{text "\<exists>x\<in>set xs"}
  5705   and @{text "\<exists>!x. x\<in>set xs \<and> _"} over @{const list_all}, @{const list_ex}
  5706   and @{const list_ex1} in specifications.
  5707 *}
  5708 
  5709 lemma list_all_simps [simp, code]:
  5710   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"
  5711   "list_all P [] \<longleftrightarrow> True"
  5712   by (simp_all add: list_all_iff)
  5713 
  5714 lemma list_ex_simps [simp, code]:
  5715   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"
  5716   "list_ex P [] \<longleftrightarrow> False"
  5717   by (simp_all add: list_ex_iff)
  5718 
  5719 lemma list_ex1_simps [simp, code]:
  5720   "list_ex1 P [] = False"
  5721   "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)"
  5722   by (auto simp add: list_ex1_iff list_all_iff)
  5723 
  5724 lemma Ball_set_list_all: (* FIXME delete candidate *)
  5725   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
  5726   by (simp add: list_all_iff)
  5727 
  5728 lemma Bex_set_list_ex: (* FIXME delete candidate *)
  5729   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
  5730   by (simp add: list_ex_iff)
  5731 
  5732 lemma list_all_append [simp]:
  5733   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"
  5734   by (auto simp add: list_all_iff)
  5735 
  5736 lemma list_ex_append [simp]:
  5737   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"
  5738   by (auto simp add: list_ex_iff)
  5739 
  5740 lemma list_all_rev [simp]:
  5741   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"
  5742   by (simp add: list_all_iff)
  5743 
  5744 lemma list_ex_rev [simp]:
  5745   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"
  5746   by (simp add: list_ex_iff)
  5747 
  5748 lemma list_all_length:
  5749   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"
  5750   by (auto simp add: list_all_iff set_conv_nth)
  5751 
  5752 lemma list_ex_length:
  5753   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"
  5754   by (auto simp add: list_ex_iff set_conv_nth)
  5755 
  5756 lemma list_all_cong [fundef_cong]:
  5757   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_all f xs = list_all g ys"
  5758   by (simp add: list_all_iff)
  5759 
  5760 lemma list_ex_cong [fundef_cong]:
  5761   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"
  5762 by (simp add: list_ex_iff)
  5763 
  5764 definition can_select :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  5765 [code_abbrev]: "can_select P A = (\<exists>!x\<in>A. P x)"
  5766 
  5767 lemma can_select_set_list_ex1 [code]:
  5768   "can_select P (set A) = list_ex1 P A"
  5769   by (simp add: list_ex1_iff can_select_def)
  5770 
  5771 
  5772 text {* Executable checks for relations on sets *}
  5773 
  5774 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  5775 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"
  5776 
  5777 lemma [code_unfold]:
  5778   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"
  5779 unfolding listrel1p_def by auto
  5780 
  5781 lemma [code]:
  5782   "listrel1p r [] xs = False"
  5783   "listrel1p r xs [] =  False"
  5784   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>
  5785      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"
  5786 by (simp add: listrel1p_def)+
  5787 
  5788 definition
  5789   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  5790   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"
  5791 
  5792 lemma [code_unfold]:
  5793   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"
  5794 unfolding lexordp_def by auto
  5795 
  5796 lemma [code]:
  5797   "lexordp r xs [] = False"
  5798   "lexordp r [] (y#ys) = True"
  5799   "lexordp r (x # xs) (y # ys) = (r x y | (x = y & lexordp r xs ys))"
  5800 unfolding lexordp_def by auto
  5801 
  5802 text {* Bounded quantification and summation over nats. *}
  5803 
  5804 lemma atMost_upto [code_unfold]:
  5805   "{..n} = set [0..<Suc n]"
  5806   by auto
  5807 
  5808 lemma atLeast_upt [code_unfold]:
  5809   "{..<n} = set [0..<n]"
  5810   by auto
  5811 
  5812 lemma greaterThanLessThan_upt [code_unfold]:
  5813   "{n<..<m} = set [Suc n..<m]"
  5814   by auto
  5815 
  5816 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]
  5817 
  5818 lemma greaterThanAtMost_upt [code_unfold]:
  5819   "{n<..m} = set [Suc n..<Suc m]"
  5820   by auto
  5821 
  5822 lemma atLeastAtMost_upt [code_unfold]:
  5823   "{n..m} = set [n..<Suc m]"
  5824   by auto
  5825 
  5826 lemma all_nat_less_eq [code_unfold]:
  5827   "(\<forall>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"
  5828   by auto
  5829 
  5830 lemma ex_nat_less_eq [code_unfold]:
  5831   "(\<exists>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"
  5832   by auto
  5833 
  5834 lemma all_nat_less [code_unfold]:
  5835   "(\<forall>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"
  5836   by auto
  5837 
  5838 lemma ex_nat_less [code_unfold]:
  5839   "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"
  5840   by auto
  5841 
  5842 lemma setsum_set_upt_conv_listsum_nat [code_unfold]:
  5843   "setsum f (set [m..<n]) = listsum (map f [m..<n])"
  5844   by (simp add: interv_listsum_conv_setsum_set_nat)
  5845 
  5846 text {* Summation over ints. *}
  5847 
  5848 lemma greaterThanLessThan_upto [code_unfold]:
  5849   "{i<..<j::int} = set [i+1..j - 1]"
  5850 by auto
  5851 
  5852 lemma atLeastLessThan_upto [code_unfold]:
  5853   "{i..<j::int} = set [i..j - 1]"
  5854 by auto
  5855 
  5856 lemma greaterThanAtMost_upto [code_unfold]:
  5857   "{i<..j::int} = set [i+1..j]"
  5858 by auto
  5859 
  5860 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]
  5861 
  5862 lemma setsum_set_upto_conv_listsum_int [code_unfold]:
  5863   "setsum f (set [i..j::int]) = listsum (map f [i..j])"
  5864   by (simp add: interv_listsum_conv_setsum_set_int)
  5865 
  5866 
  5867 subsubsection {* Optimizing by rewriting *}
  5868 
  5869 definition null :: "'a list \<Rightarrow> bool" where
  5870   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"
  5871 
  5872 text {*
  5873   Efficient emptyness check is implemented by @{const null}.
  5874 *}
  5875 
  5876 lemma null_rec [code]:
  5877   "null (x # xs) \<longleftrightarrow> False"
  5878   "null [] \<longleftrightarrow> True"
  5879   by (simp_all add: null_def)
  5880 
  5881 lemma eq_Nil_null: (* FIXME delete candidate *)
  5882   "xs = [] \<longleftrightarrow> null xs"
  5883   by (simp add: null_def)
  5884 
  5885 lemma equal_Nil_null [code_unfold]:
  5886   "HOL.equal xs [] \<longleftrightarrow> null xs"
  5887   by (simp add: equal eq_Nil_null)
  5888 
  5889 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  5890   [code_abbrev]: "maps f xs = concat (map f xs)"
  5891 
  5892 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  5893   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"
  5894 
  5895 text {*
  5896   Operations @{const maps} and @{const map_filter} avoid
  5897   intermediate lists on execution -- do not use for proving.
  5898 *}
  5899 
  5900 lemma maps_simps [code]:
  5901   "maps f (x # xs) = f x @ maps f xs"
  5902   "maps f [] = []"
  5903   by (simp_all add: maps_def)
  5904 
  5905 lemma map_filter_simps [code]:
  5906   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"
  5907   "map_filter f [] = []"
  5908   by (simp_all add: map_filter_def split: option.split)
  5909 
  5910 lemma concat_map_maps: (* FIXME delete candidate *)
  5911   "concat (map f xs) = maps f xs"
  5912   by (simp add: maps_def)
  5913 
  5914 lemma map_filter_map_filter [code_unfold]:
  5915   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"
  5916   by (simp add: map_filter_def)
  5917 
  5918 text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}
  5919 and similiarly for @{text"\<exists>"}. *}
  5920 
  5921 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
  5922   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"
  5923 
  5924 lemma [code]:
  5925   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"
  5926 proof -
  5927   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"
  5928   proof -
  5929     fix n
  5930     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"
  5931     then show "P n" by (cases "n = i") simp_all
  5932   qed
  5933   show ?thesis by (auto simp add: all_interval_nat_def intro: *)
  5934 qed
  5935 
  5936 lemma list_all_iff_all_interval_nat [code_unfold]:
  5937   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"
  5938   by (simp add: list_all_iff all_interval_nat_def)
  5939 
  5940 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:
  5941   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"
  5942   by (simp add: list_ex_iff all_interval_nat_def)
  5943 
  5944 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  5945   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"
  5946 
  5947 lemma [code]:
  5948   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"
  5949 proof -
  5950   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"
  5951   proof -
  5952     fix k
  5953     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"
  5954     then show "P k" by (cases "k = i") simp_all
  5955   qed
  5956   show ?thesis by (auto simp add: all_interval_int_def intro: *)
  5957 qed
  5958 
  5959 lemma list_all_iff_all_interval_int [code_unfold]:
  5960   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"
  5961   by (simp add: list_all_iff all_interval_int_def)
  5962 
  5963 lemma list_ex_iff_not_all_inverval_int [code_unfold]:
  5964   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"
  5965   by (simp add: list_ex_iff all_interval_int_def)
  5966 
  5967 text {* optimized code (tail-recursive) for @{term length} *}
  5968 
  5969 definition gen_length :: "nat \<Rightarrow> 'a list \<Rightarrow> nat"
  5970 where "gen_length n xs = n + length xs"
  5971 
  5972 lemma gen_length_code [code]:
  5973   "gen_length n [] = n"
  5974   "gen_length n (x # xs) = gen_length (Suc n) xs"
  5975 by(simp_all add: gen_length_def)
  5976 
  5977 declare list.size(3-4)[code del]
  5978 
  5979 lemma length_code [code]: "length = gen_length 0"
  5980 by(simp add: gen_length_def fun_eq_iff)
  5981 
  5982 hide_const (open) member null maps map_filter all_interval_nat all_interval_int gen_length
  5983 
  5984 
  5985 subsubsection {* Pretty lists *}
  5986 
  5987 ML {*
  5988 (* Code generation for list literals. *)
  5989 
  5990 signature LIST_CODE =
  5991 sig
  5992   val implode_list: string -> string -> Code_Thingol.iterm -> Code_Thingol.iterm list option
  5993   val default_list: int * string
  5994     -> (Code_Printer.fixity -> Code_Thingol.iterm -> Pretty.T)
  5995     -> Code_Printer.fixity -> Code_Thingol.iterm -> Code_Thingol.iterm -> Pretty.T
  5996   val add_literal_list: string -> theory -> theory
  5997 end;
  5998 
  5999 structure List_Code : LIST_CODE =
  6000 struct
  6001 
  6002 open Basic_Code_Thingol;
  6003 
  6004 fun implode_list nil' cons' t =
  6005   let
  6006     fun dest_cons (IConst { name = c, ... } `$ t1 `$ t2) =
  6007           if c = cons'
  6008           then SOME (t1, t2)
  6009           else NONE
  6010       | dest_cons _ = NONE;
  6011     val (ts, t') = Code_Thingol.unfoldr dest_cons t;
  6012   in case t'
  6013    of IConst { name = c, ... } => if c = nil' then SOME ts else NONE
  6014     | _ => NONE
  6015   end;
  6016 
  6017 fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
  6018   Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (
  6019     pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
  6020     Code_Printer.str target_cons,
  6021     pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
  6022   );
  6023 
  6024 fun add_literal_list target =
  6025   let
  6026     fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =
  6027       case Option.map (cons t1) (implode_list nil' cons' t2)
  6028        of SOME ts =>
  6029             Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)
  6030         | NONE =>
  6031             default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
  6032   in Code_Target.add_const_syntax target @{const_name Cons}
  6033     (SOME (Code_Printer.complex_const_syntax (2, ([@{const_name Nil}, @{const_name Cons}], pretty))))
  6034   end
  6035 
  6036 end;
  6037 *}
  6038 
  6039 code_type list
  6040   (SML "_ list")
  6041   (OCaml "_ list")
  6042   (Haskell "![(_)]")
  6043   (Scala "List[(_)]")
  6044 
  6045 code_const Nil
  6046   (SML "[]")
  6047   (OCaml "[]")
  6048   (Haskell "[]")
  6049   (Scala "!Nil")
  6050 
  6051 code_instance list :: equal
  6052   (Haskell -)
  6053 
  6054 code_const "HOL.equal \<Colon> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  6055   (Haskell infix 4 "==")
  6056 
  6057 code_reserved SML
  6058   list
  6059 
  6060 code_reserved OCaml
  6061   list
  6062 
  6063 setup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}
  6064 
  6065 
  6066 subsubsection {* Use convenient predefined operations *}
  6067 
  6068 code_const "op @"
  6069   (SML infixr 7 "@")
  6070   (OCaml infixr 6 "@")
  6071   (Haskell infixr 5 "++")
  6072   (Scala infixl 7 "++")
  6073 
  6074 code_const map
  6075   (Haskell "map")
  6076 
  6077 code_const filter
  6078   (Haskell "filter")
  6079 
  6080 code_const concat
  6081   (Haskell "concat")
  6082 
  6083 code_const List.maps
  6084   (Haskell "concatMap")
  6085 
  6086 code_const rev
  6087   (Haskell "reverse")
  6088 
  6089 code_const zip
  6090   (Haskell "zip")
  6091 
  6092 code_const List.null
  6093   (Haskell "null")
  6094 
  6095 code_const takeWhile
  6096   (Haskell "takeWhile")
  6097 
  6098 code_const dropWhile
  6099   (Haskell "dropWhile")
  6100 
  6101 code_const list_all
  6102   (Haskell "all")
  6103 
  6104 code_const list_ex
  6105   (Haskell "any")
  6106 
  6107 
  6108 subsubsection {* Implementation of sets by lists *}
  6109 
  6110 lemma is_empty_set [code]:
  6111   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"
  6112   by (simp add: Set.is_empty_def null_def)
  6113 
  6114 lemma empty_set [code]:
  6115   "{} = set []"
  6116   by simp
  6117 
  6118 lemma UNIV_coset [code]:
  6119   "UNIV = List.coset []"
  6120   by simp
  6121 
  6122 lemma compl_set [code]:
  6123   "- set xs = List.coset xs"
  6124   by simp
  6125 
  6126 lemma compl_coset [code]:
  6127   "- List.coset xs = set xs"
  6128   by simp
  6129 
  6130 lemma [code]:
  6131   "x \<in> set xs \<longleftrightarrow> List.member xs x"
  6132   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"
  6133   by (simp_all add: member_def)
  6134 
  6135 lemma insert_code [code]:
  6136   "insert x (set xs) = set (List.insert x xs)"
  6137   "insert x (List.coset xs) = List.coset (removeAll x xs)"
  6138   by simp_all
  6139 
  6140 lemma remove_code [code]:
  6141   "Set.remove x (set xs) = set (removeAll x xs)"
  6142   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"
  6143   by (simp_all add: remove_def Compl_insert)
  6144 
  6145 lemma filter_set [code]:
  6146   "Set.filter P (set xs) = set (filter P xs)"
  6147   by auto
  6148 
  6149 lemma image_set [code]:
  6150   "image f (set xs) = set (map f xs)"
  6151   by simp
  6152 
  6153 lemma subset_code [code]:
  6154   "set xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> B)"
  6155   "A \<le> List.coset ys \<longleftrightarrow> (\<forall>y\<in>set ys. y \<notin> A)"
  6156   "List.coset [] \<le> set [] \<longleftrightarrow> False"
  6157   by auto
  6158 
  6159 text {* A frequent case – avoid intermediate sets *}
  6160 lemma [code_unfold]:
  6161   "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"
  6162   by (auto simp: list_all_iff)
  6163 
  6164 lemma Ball_set [code]:
  6165   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
  6166   by (simp add: list_all_iff)
  6167 
  6168 lemma Bex_set [code]:
  6169   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
  6170   by (simp add: list_ex_iff)
  6171 
  6172 lemma card_set [code]:
  6173   "card (set xs) = length (remdups xs)"
  6174 proof -
  6175   have "card (set (remdups xs)) = length (remdups xs)"
  6176     by (rule distinct_card) simp
  6177   then show ?thesis by simp
  6178 qed
  6179 
  6180 lemma the_elem_set [code]:
  6181   "the_elem (set [x]) = x"
  6182   by simp
  6183 
  6184 lemma Pow_set [code]:
  6185   "Pow (set []) = {{}}"
  6186   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x ` A)"
  6187   by (simp_all add: Pow_insert Let_def)
  6188 
  6189 lemma setsum_code [code]:
  6190   "setsum f (set xs) = listsum (map f (remdups xs))"
  6191 by (simp add: listsum_distinct_conv_setsum_set)
  6192 
  6193 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
  6194   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"
  6195 
  6196 lemma [code]:
  6197   "map_project f (set xs) = set (List.map_filter f xs)"
  6198   by (auto simp add: map_project_def map_filter_def image_def)
  6199 
  6200 hide_const (open) map_project
  6201 
  6202 
  6203 text {* Operations on relations *}
  6204 
  6205 lemma product_code [code]:
  6206   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"
  6207   by (auto simp add: Product_Type.product_def)
  6208 
  6209 lemma Id_on_set [code]:
  6210   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"
  6211   by (auto simp add: Id_on_def)
  6212 
  6213 lemma [code]:
  6214   "R `` S = List.map_project (%(x, y). if x : S then Some y else None) R"
  6215 unfolding map_project_def by (auto split: prod.split split_if_asm)
  6216 
  6217 lemma trancl_set_ntrancl [code]:
  6218   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"
  6219   by (simp add: finite_trancl_ntranl)
  6220 
  6221 lemma set_relcomp [code]:
  6222   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"
  6223   by (auto simp add: Bex_def)
  6224 
  6225 lemma wf_set [code]:
  6226   "wf (set xs) = acyclic (set xs)"
  6227   by (simp add: wf_iff_acyclic_if_finite)
  6228 
  6229 end
  6230