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