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