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