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