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