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