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