src/HOL/List.thy
 author haftmann Sat Jun 15 17:19:23 2013 +0200 (2013-06-15) changeset 52379 7f864f2219a9 parent 52148 893b15200ec1 child 52380 3cc46b8cca5e permissions -rw-r--r--
selection operator smallest_prime_beyond
     1 (*  Title:      HOL/List.thy

     2     Author:     Tobias Nipkow

     3 *)

     4

     5 header {* The datatype of finite lists *}

     6

     7 theory List

     8 imports Presburger Code_Numeral Quotient ATP

     9 begin

    10

    11 datatype 'a list =

    12     Nil    ("[]")

    13   | Cons 'a  "'a list"    (infixr "#" 65)

    14

    15 syntax

    16   -- {* list Enumeration *}

    17   "_list" :: "args => 'a list"    ("[(_)]")

    18

    19 translations

    20   "[x, xs]" == "x#[xs]"

    21   "[x]" == "x#[]"

    22

    23

    24 subsection {* Basic list processing functions *}

    25

    26 primrec hd :: "'a list \<Rightarrow> 'a" where

    27 "hd (x # xs) = x"

    28

    29 primrec tl :: "'a list \<Rightarrow> 'a list" where

    30 "tl [] = []" |

    31 "tl (x # xs) = xs"

    32

    33 primrec last :: "'a list \<Rightarrow> 'a" where

    34 "last (x # xs) = (if xs = [] then x else last xs)"

    35

    36 primrec butlast :: "'a list \<Rightarrow> 'a list" where

    37 "butlast []= []" |

    38 "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"

    39

    40 primrec set :: "'a list \<Rightarrow> 'a set" where

    41 "set [] = {}" |

    42 "set (x # xs) = insert x (set xs)"

    43

    44 definition coset :: "'a list \<Rightarrow> 'a set" where

    45 [simp]: "coset xs = - set xs"

    46

    47 primrec map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

    48 "map f [] = []" |

    49 "map f (x # xs) = f x # map f xs"

    50

    51 primrec append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where

    52 append_Nil: "[] @ ys = ys" |

    53 append_Cons: "(x#xs) @ ys = x # xs @ ys"

    54

    55 primrec rev :: "'a list \<Rightarrow> 'a list" where

    56 "rev [] = []" |

    57 "rev (x # xs) = rev xs @ [x]"

    58

    59 primrec filter:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where

    60 "filter P [] = []" |

    61 "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"

    62

    63 syntax

    64   -- {* Special syntax for filter *}

    65   "_filter" :: "[pttrn, 'a list, bool] => 'a list"    ("(1[_<-_./ _])")

    66

    67 translations

    68   "[x<-xs . P]"== "CONST filter (%x. P) xs"

    69

    70 syntax (xsymbols)

    71   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")

    72 syntax (HTML output)

    73   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")

    74

    75 primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where

    76 fold_Nil:  "fold f [] = id" |

    77 fold_Cons: "fold f (x # xs) = fold f xs \<circ> f x"

    78

    79 primrec foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where

    80 foldr_Nil:  "foldr f [] = id" |

    81 foldr_Cons: "foldr f (x # xs) = f x \<circ> foldr f xs"

    82

    83 primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where

    84 foldl_Nil:  "foldl f a [] = a" |

    85 foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"

    86

    87 primrec concat:: "'a list list \<Rightarrow> 'a list" where

    88 "concat [] = []" |

    89 "concat (x # xs) = x @ concat xs"

    90

    91 definition (in monoid_add) listsum :: "'a list \<Rightarrow> 'a" where

    92 "listsum xs = foldr plus xs 0"

    93

    94 primrec drop:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where

    95 drop_Nil: "drop n [] = []" |

    96 drop_Cons: "drop n (x # xs) = (case n of 0 \<Rightarrow> x # xs | Suc m \<Rightarrow> drop m xs)"

    97   -- {*Warning: simpset does not contain this definition, but separate

    98        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}

    99

   100 primrec take:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   101 take_Nil:"take n [] = []" |

   102 take_Cons: "take n (x # xs) = (case n of 0 \<Rightarrow> [] | Suc m \<Rightarrow> x # take m xs)"

   103   -- {*Warning: simpset does not contain this definition, but separate

   104        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}

   105

   106 primrec nth :: "'a list => nat => 'a" (infixl "!" 100) where

   107 nth_Cons: "(x # xs) ! n = (case n of 0 \<Rightarrow> x | Suc k \<Rightarrow> xs ! k)"

   108   -- {*Warning: simpset does not contain this definition, but separate

   109        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}

   110

   111 primrec list_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where

   112 "list_update [] i v = []" |

   113 "list_update (x # xs) i v =

   114   (case i of 0 \<Rightarrow> v # xs | Suc j \<Rightarrow> x # list_update xs j v)"

   115

   116 nonterminal lupdbinds and lupdbind

   117

   118 syntax

   119   "_lupdbind":: "['a, 'a] => lupdbind"    ("(2_ :=/ _)")

   120   "" :: "lupdbind => lupdbinds"    ("_")

   121   "_lupdbinds" :: "[lupdbind, lupdbinds] => lupdbinds"    ("_,/ _")

   122   "_LUpdate" :: "['a, lupdbinds] => 'a"    ("_/[(_)]" [900,0] 900)

   123

   124 translations

   125   "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"

   126   "xs[i:=x]" == "CONST list_update xs i x"

   127

   128 primrec takeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   129 "takeWhile P [] = []" |

   130 "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"

   131

   132 primrec dropWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   133 "dropWhile P [] = []" |

   134 "dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"

   135

   136 primrec zip :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where

   137 "zip xs [] = []" |

   138 zip_Cons: "zip xs (y # ys) =

   139   (case xs of [] => [] | z # zs => (z, y) # zip zs ys)"

   140   -- {*Warning: simpset does not contain this definition, but separate

   141        theorems for @{text "xs = []"} and @{text "xs = z # zs"} *}

   142

   143 primrec product :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where

   144 "product [] _ = []" |

   145 "product (x#xs) ys = map (Pair x) ys @ product xs ys"

   146

   147 hide_const (open) product

   148

   149 primrec upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_..</_'])") where

   150 upt_0: "[i..<0] = []" |

   151 upt_Suc: "[i..<(Suc j)] = (if i <= j then [i..<j] @ [j] else [])"

   152

   153 definition insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   154 "insert x xs = (if x \<in> set xs then xs else x # xs)"

   155

   156 hide_const (open) insert

   157 hide_fact (open) insert_def

   158

   159 primrec find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where

   160 "find _ [] = None" |

   161 "find P (x#xs) = (if P x then Some x else find P xs)"

   162

   163 hide_const (open) find

   164

   165 primrec those :: "'a option list \<Rightarrow> 'a list option"

   166 where

   167 "those [] = Some []" |

   168 "those (x # xs) = (case x of

   169   None \<Rightarrow> None

   170 | Some y \<Rightarrow> Option.map (Cons y) (those xs))"

   171

   172 primrec remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   173 "remove1 x [] = []" |

   174 "remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"

   175

   176 primrec removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   177 "removeAll x [] = []" |

   178 "removeAll x (y # xs) = (if x = y then removeAll x xs else y # removeAll x xs)"

   179

   180 primrec distinct :: "'a list \<Rightarrow> bool" where

   181 "distinct [] \<longleftrightarrow> True" |

   182 "distinct (x # xs) \<longleftrightarrow> x \<notin> set xs \<and> distinct xs"

   183

   184 primrec remdups :: "'a list \<Rightarrow> 'a list" where

   185 "remdups [] = []" |

   186 "remdups (x # xs) = (if x \<in> set xs then remdups xs else x # remdups xs)"

   187

   188 primrec replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where

   189 replicate_0: "replicate 0 x = []" |

   190 replicate_Suc: "replicate (Suc n) x = x # replicate n x"

   191

   192 text {*

   193   Function @{text size} is overloaded for all datatypes. Users may

   194   refer to the list version as @{text length}. *}

   195

   196 abbreviation length :: "'a list \<Rightarrow> nat" where

   197 "length \<equiv> size"

   198

   199 definition enumerate :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list" where

   200 enumerate_eq_zip: "enumerate n xs = zip [n..<n + length xs] xs"

   201

   202 primrec rotate1 :: "'a list \<Rightarrow> 'a list" where

   203 "rotate1 [] = []" |

   204 "rotate1 (x # xs) = xs @ [x]"

   205

   206 definition rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   207 "rotate n = rotate1 ^^ n"

   208

   209 definition list_all2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool" where

   210 "list_all2 P xs ys =

   211   (length xs = length ys \<and> (\<forall>(x, y) \<in> set (zip xs ys). P x y))"

   212

   213 definition sublist :: "'a list => nat set => 'a list" where

   214 "sublist xs A = map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [0..<size xs]))"

   215

   216 primrec sublists :: "'a list \<Rightarrow> 'a list list" where

   217 "sublists [] = [[]]" |

   218 "sublists (x#xs) = (let xss = sublists xs in map (Cons x) xss @ xss)"

   219

   220 primrec n_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where

   221 "n_lists 0 xs = [[]]" |

   222 "n_lists (Suc n) xs = concat (map (\<lambda>ys. map (\<lambda>y. y # ys) xs) (n_lists n xs))"

   223

   224 hide_const (open) n_lists

   225

   226 fun splice :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   227 "splice [] ys = ys" |

   228 "splice xs [] = xs" |

   229 "splice (x#xs) (y#ys) = x # y # splice xs ys"

   230

   231 text{*

   232 \begin{figure}[htbp]

   233 \fbox{

   234 \begin{tabular}{l}

   235 @{lemma "[a,b]@[c,d] = [a,b,c,d]" by simp}\\

   236 @{lemma "length [a,b,c] = 3" by simp}\\

   237 @{lemma "set [a,b,c] = {a,b,c}" by simp}\\

   238 @{lemma "map f [a,b,c] = [f a, f b, f c]" by simp}\\

   239 @{lemma "rev [a,b,c] = [c,b,a]" by simp}\\

   240 @{lemma "hd [a,b,c,d] = a" by simp}\\

   241 @{lemma "tl [a,b,c,d] = [b,c,d]" by simp}\\

   242 @{lemma "last [a,b,c,d] = d" by simp}\\

   243 @{lemma "butlast [a,b,c,d] = [a,b,c]" by simp}\\

   244 @{lemma[source] "filter (\<lambda>n::nat. n<2) [0,2,1] = [0,1]" by simp}\\

   245 @{lemma "concat [[a,b],[c,d,e],[],[f]] = [a,b,c,d,e,f]" by simp}\\

   246 @{lemma "fold f [a,b,c] x = f c (f b (f a x))" by simp}\\

   247 @{lemma "foldr f [a,b,c] x = f a (f b (f c x))" by simp}\\

   248 @{lemma "foldl f x [a,b,c] = f (f (f x a) b) c" by simp}\\

   249 @{lemma "zip [a,b,c] [x,y,z] = [(a,x),(b,y),(c,z)]" by simp}\\

   250 @{lemma "zip [a,b] [x,y,z] = [(a,x),(b,y)]" by simp}\\

   251 @{lemma "enumerate 3 [a,b,c] = [(3,a),(4,b),(5,c)]" by normalization}\\

   252 @{lemma "List.product [a,b] [c,d] = [(a, c), (a, d), (b, c), (b, d)]" by simp}\\

   253 @{lemma "splice [a,b,c] [x,y,z] = [a,x,b,y,c,z]" by simp}\\

   254 @{lemma "splice [a,b,c,d] [x,y] = [a,x,b,y,c,d]" by simp}\\

   255 @{lemma "take 2 [a,b,c,d] = [a,b]" by simp}\\

   256 @{lemma "take 6 [a,b,c,d] = [a,b,c,d]" by simp}\\

   257 @{lemma "drop 2 [a,b,c,d] = [c,d]" by simp}\\

   258 @{lemma "drop 6 [a,b,c,d] = []" by simp}\\

   259 @{lemma "takeWhile (%n::nat. n<3) [1,2,3,0] = [1,2]" by simp}\\

   260 @{lemma "dropWhile (%n::nat. n<3) [1,2,3,0] = [3,0]" by simp}\\

   261 @{lemma "distinct [2,0,1::nat]" by simp}\\

   262 @{lemma "remdups [2,0,2,1::nat,2] = [0,1,2]" by simp}\\

   263 @{lemma "List.insert 2 [0::nat,1,2] = [0,1,2]" by (simp add: List.insert_def)}\\

   264 @{lemma "List.insert 3 [0::nat,1,2] = [3,0,1,2]" by (simp add: List.insert_def)}\\

   265 @{lemma "List.find (%i::int. i>0) [0,0] = None" by simp}\\

   266 @{lemma "List.find (%i::int. i>0) [0,1,0,2] = Some 1" by simp}\\

   267 @{lemma "remove1 2 [2,0,2,1::nat,2] = [0,2,1,2]" by simp}\\

   268 @{lemma "removeAll 2 [2,0,2,1::nat,2] = [0,1]" by simp}\\

   269 @{lemma "nth [a,b,c,d] 2 = c" by simp}\\

   270 @{lemma "[a,b,c,d][2 := x] = [a,b,x,d]" by simp}\\

   271 @{lemma "sublist [a,b,c,d,e] {0,2,3} = [a,c,d]" by (simp add:sublist_def)}\\

   272 @{lemma "sublists [a,b] = [[a, b], [a], [b], []]" by simp}\\

   273 @{lemma "List.n_lists 2 [a,b,c] = [[a, a], [b, a], [c, a], [a, b], [b, b], [c, b], [a, c], [b, c], [c, c]]" by (simp add: eval_nat_numeral)}\\

   274 @{lemma "rotate1 [a,b,c,d] = [b,c,d,a]" by simp}\\

   275 @{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate_def eval_nat_numeral)}\\

   276 @{lemma "replicate 4 a = [a,a,a,a]" by (simp add:eval_nat_numeral)}\\

   277 @{lemma "[2..<5] = [2,3,4]" by (simp add:eval_nat_numeral)}\\

   278 @{lemma "listsum [1,2,3::nat] = 6" by (simp add: listsum_def)}

   279 \end{tabular}}

   280 \caption{Characteristic examples}

   281 \label{fig:Characteristic}

   282 \end{figure}

   283 Figure~\ref{fig:Characteristic} shows characteristic examples

   284 that should give an intuitive understanding of the above functions.

   285 *}

   286

   287 text{* The following simple sort functions are intended for proofs,

   288 not for efficient implementations. *}

   289

   290 context linorder

   291 begin

   292

   293 inductive sorted :: "'a list \<Rightarrow> bool" where

   294   Nil [iff]: "sorted []"

   295 | Cons: "\<forall>y\<in>set xs. x \<le> y \<Longrightarrow> sorted xs \<Longrightarrow> sorted (x # xs)"

   296

   297 lemma sorted_single [iff]:

   298   "sorted [x]"

   299   by (rule sorted.Cons) auto

   300

   301 lemma sorted_many:

   302   "x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> sorted (x # y # zs)"

   303   by (rule sorted.Cons) (cases "y # zs" rule: sorted.cases, auto)

   304

   305 lemma sorted_many_eq [simp, code]:

   306   "sorted (x # y # zs) \<longleftrightarrow> x \<le> y \<and> sorted (y # zs)"

   307   by (auto intro: sorted_many elim: sorted.cases)

   308

   309 lemma [code]:

   310   "sorted [] \<longleftrightarrow> True"

   311   "sorted [x] \<longleftrightarrow> True"

   312   by simp_all

   313

   314 primrec insort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where

   315 "insort_key f x [] = [x]" |

   316 "insort_key f x (y#ys) =

   317   (if f x \<le> f y then (x#y#ys) else y#(insort_key f x ys))"

   318

   319 definition sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where

   320 "sort_key f xs = foldr (insort_key f) xs []"

   321

   322 definition insort_insert_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where

   323 "insort_insert_key f x xs =

   324   (if f x \<in> f  set xs then xs else insort_key f x xs)"

   325

   326 abbreviation "sort \<equiv> sort_key (\<lambda>x. x)"

   327 abbreviation "insort \<equiv> insort_key (\<lambda>x. x)"

   328 abbreviation "insort_insert \<equiv> insort_insert_key (\<lambda>x. x)"

   329

   330 end

   331

   332

   333 subsubsection {* List comprehension *}

   334

   335 text{* Input syntax for Haskell-like list comprehension notation.

   336 Typical example: @{text"[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x \<noteq> y]"},

   337 the list of all pairs of distinct elements from @{text xs} and @{text ys}.

   338 The syntax is as in Haskell, except that @{text"|"} becomes a dot

   339 (like in Isabelle's set comprehension): @{text"[e. x \<leftarrow> xs, \<dots>]"} rather than

   340 \verb![e| x <- xs, ...]!.

   341

   342 The qualifiers after the dot are

   343 \begin{description}

   344 \item[generators] @{text"p \<leftarrow> xs"},

   345  where @{text p} is a pattern and @{text xs} an expression of list type, or

   346 \item[guards] @{text"b"}, where @{text b} is a boolean expression.

   347 %\item[local bindings] @ {text"let x = e"}.

   348 \end{description}

   349

   350 Just like in Haskell, list comprehension is just a shorthand. To avoid

   351 misunderstandings, the translation into desugared form is not reversed

   352 upon output. Note that the translation of @{text"[e. x \<leftarrow> xs]"} is

   353 optmized to @{term"map (%x. e) xs"}.

   354

   355 It is easy to write short list comprehensions which stand for complex

   356 expressions. During proofs, they may become unreadable (and

   357 mangled). In such cases it can be advisable to introduce separate

   358 definitions for the list comprehensions in question.  *}

   359

   360 nonterminal lc_qual and lc_quals

   361

   362 syntax

   363   "_listcompr" :: "'a \<Rightarrow> lc_qual \<Rightarrow> lc_quals \<Rightarrow> 'a list"  ("[_ . __")

   364   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ <- _")

   365   "_lc_test" :: "bool \<Rightarrow> lc_qual" ("_")

   366   (*"_lc_let" :: "letbinds => lc_qual"  ("let _")*)

   367   "_lc_end" :: "lc_quals" ("]")

   368   "_lc_quals" :: "lc_qual \<Rightarrow> lc_quals \<Rightarrow> lc_quals"  (", __")

   369   "_lc_abs" :: "'a => 'b list => 'b list"

   370

   371 (* These are easier than ML code but cannot express the optimized

   372    translation of [e. p<-xs]

   373 translations

   374   "[e. p<-xs]" => "concat(map (_lc_abs p [e]) xs)"

   375   "_listcompr e (_lc_gen p xs) (_lc_quals Q Qs)"

   376    => "concat (map (_lc_abs p (_listcompr e Q Qs)) xs)"

   377   "[e. P]" => "if P then [e] else []"

   378   "_listcompr e (_lc_test P) (_lc_quals Q Qs)"

   379    => "if P then (_listcompr e Q Qs) else []"

   380   "_listcompr e (_lc_let b) (_lc_quals Q Qs)"

   381    => "_Let b (_listcompr e Q Qs)"

   382 *)

   383

   384 syntax (xsymbols)

   385   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")

   386 syntax (HTML output)

   387   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")

   388

   389 parse_translation {*

   390   let

   391     val NilC = Syntax.const @{const_syntax Nil};

   392     val ConsC = Syntax.const @{const_syntax Cons};

   393     val mapC = Syntax.const @{const_syntax map};

   394     val concatC = Syntax.const @{const_syntax concat};

   395     val IfC = Syntax.const @{const_syntax If};

   396

   397     fun single x = ConsC $x$ NilC;

   398

   399     fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)

   400       let

   401         (* FIXME proper name context!? *)

   402         val x =

   403           Free (singleton (Name.variant_list (fold Term.add_free_names [p, e] [])) "x", dummyT);

   404         val e = if opti then single e else e;

   405         val case1 = Syntax.const @{syntax_const "_case1"} $p$ e;

   406         val case2 =

   407           Syntax.const @{syntax_const "_case1"} $  408 Syntax.const @{const_syntax dummy_pattern}$ NilC;

   409         val cs = Syntax.const @{syntax_const "_case2"} $case1$ case2;

   410       in Syntax_Trans.abs_tr [x, Case_Translation.case_tr false ctxt [x, cs]] end;

   411

   412     fun abs_tr ctxt p e opti =

   413       (case Term_Position.strip_positions p of

   414         Free (s, T) =>

   415           let

   416             val thy = Proof_Context.theory_of ctxt;

   417             val s' = Proof_Context.intern_const ctxt s;

   418           in

   419             if Sign.declared_const thy s'

   420             then (pat_tr ctxt p e opti, false)

   421             else (Syntax_Trans.abs_tr [p, e], true)

   422           end

   423       | _ => (pat_tr ctxt p e opti, false));

   424

   425     fun lc_tr ctxt [e, Const (@{syntax_const "_lc_test"}, _) $b, qs] =   426 let   427 val res =   428 (case qs of   429 Const (@{syntax_const "_lc_end"}, _) => single e   430 | Const (@{syntax_const "_lc_quals"}, _)$ q $qs => lc_tr ctxt [e, q, qs]);   431 in IfC$ b $res$ NilC end

   432       | lc_tr ctxt

   433             [e, Const (@{syntax_const "_lc_gen"}, _) $p$ es,

   434               Const(@{syntax_const "_lc_end"}, _)] =

   435           (case abs_tr ctxt p e true of

   436             (f, true) => mapC $f$ es

   437           | (f, false) => concatC $(mapC$ f $es))   438 | lc_tr ctxt   439 [e, Const (@{syntax_const "_lc_gen"}, _)$ p $es,   440 Const (@{syntax_const "_lc_quals"}, _)$ q $qs] =   441 let val e' = lc_tr ctxt [e, q, qs];   442 in concatC$ (mapC $(fst (abs_tr ctxt p e' false))$ es) end;

   443

   444   in [(@{syntax_const "_listcompr"}, lc_tr)] end

   445 *}

   446

   447 ML_val {*

   448   let

   449     val read = Syntax.read_term @{context};

   450     fun check s1 s2 = read s1 aconv read s2 orelse error ("Check failed: " ^ quote s1);

   451   in

   452     check "[(x,y,z). b]" "if b then [(x, y, z)] else []";

   453     check "[(x,y,z). x\<leftarrow>xs]" "map (\<lambda>x. (x, y, z)) xs";

   454     check "[e x y. x\<leftarrow>xs, y\<leftarrow>ys]" "concat (map (\<lambda>x. map (\<lambda>y. e x y) ys) xs)";

   455     check "[(x,y,z). x<a, x>b]" "if x < a then if b < x then [(x, y, z)] else [] else []";

   456     check "[(x,y,z). x\<leftarrow>xs, x>b]" "concat (map (\<lambda>x. if b < x then [(x, y, z)] else []) xs)";

   457     check "[(x,y,z). x<a, x\<leftarrow>xs]" "if x < a then map (\<lambda>x. (x, y, z)) xs else []";

   458     check "[(x,y). Cons True x \<leftarrow> xs]"

   459       "concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | True # x \<Rightarrow> [(x, y)] | False # x \<Rightarrow> []) xs)";

   460     check "[(x,y,z). Cons x [] \<leftarrow> xs]"

   461       "concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | [x] \<Rightarrow> [(x, y, z)] | x # aa # lista \<Rightarrow> []) xs)";

   462     check "[(x,y,z). x<a, x>b, x=d]"

   463       "if x < a then if b < x then if x = d then [(x, y, z)] else [] else [] else []";

   464     check "[(x,y,z). x<a, x>b, y\<leftarrow>ys]"

   465       "if x < a then if b < x then map (\<lambda>y. (x, y, z)) ys else [] else []";

   466     check "[(x,y,z). x<a, x\<leftarrow>xs,y>b]"

   467       "if x < a then concat (map (\<lambda>x. if b < y then [(x, y, z)] else []) xs) else []";

   468     check "[(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys]"

   469       "if x < a then concat (map (\<lambda>x. map (\<lambda>y. (x, y, z)) ys) xs) else []";

   470     check "[(x,y,z). x\<leftarrow>xs, x>b, y<a]"

   471       "concat (map (\<lambda>x. if b < x then if y < a then [(x, y, z)] else [] else []) xs)";

   472     check "[(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys]"

   473       "concat (map (\<lambda>x. if b < x then map (\<lambda>y. (x, y, z)) ys else []) xs)";

   474     check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x]"

   475       "concat (map (\<lambda>x. concat (map (\<lambda>y. if x < y then [(x, y, z)] else []) ys)) xs)";

   476     check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs]"

   477       "concat (map (\<lambda>x. concat (map (\<lambda>y. map (\<lambda>z. (x, y, z)) zs) ys)) xs)"

   478   end;

   479 *}

   480

   481 (*

   482 term "[(x,y). x\<leftarrow>xs, let xx = x+x, y\<leftarrow>ys, y \<noteq> xx]"

   483 *)

   484

   485

   486 ML {*

   487 (* Simproc for rewriting list comprehensions applied to List.set to set

   488    comprehension. *)

   489

   490 signature LIST_TO_SET_COMPREHENSION =

   491 sig

   492   val simproc : Proof.context -> cterm -> thm option

   493 end

   494

   495 structure List_to_Set_Comprehension : LIST_TO_SET_COMPREHENSION =

   496 struct

   497

   498 (* conversion *)

   499

   500 fun all_exists_conv cv ctxt ct =

   501   (case Thm.term_of ct of

   502     Const (@{const_name HOL.Ex}, _) $Abs _ =>   503 Conv.arg_conv (Conv.abs_conv (all_exists_conv cv o #2) ctxt) ct   504 | _ => cv ctxt ct)   505   506 fun all_but_last_exists_conv cv ctxt ct =   507 (case Thm.term_of ct of   508 Const (@{const_name HOL.Ex}, _)$ Abs (_, _, Const (@{const_name HOL.Ex}, _) $_) =>   509 Conv.arg_conv (Conv.abs_conv (all_but_last_exists_conv cv o #2) ctxt) ct   510 | _ => cv ctxt ct)   511   512 fun Collect_conv cv ctxt ct =   513 (case Thm.term_of ct of   514 Const (@{const_name Set.Collect}, _)$ Abs _ => Conv.arg_conv (Conv.abs_conv cv ctxt) ct

   515   | _ => raise CTERM ("Collect_conv", [ct]))

   516

   517 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)

   518

   519 fun conjunct_assoc_conv ct =

   520   Conv.try_conv

   521     (rewr_conv' @{thm conj_assoc} then_conv HOLogic.conj_conv Conv.all_conv conjunct_assoc_conv) ct

   522

   523 fun right_hand_set_comprehension_conv conv ctxt =

   524   HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv

   525     (Collect_conv (all_exists_conv conv o #2) ctxt))

   526

   527

   528 (* term abstraction of list comprehension patterns *)

   529

   530 datatype termlets = If | Case of (typ * int)

   531

   532 fun simproc ctxt redex =

   533   let

   534     val thy = Proof_Context.theory_of ctxt

   535     val set_Nil_I = @{thm trans} OF [@{thm set.simps(1)}, @{thm empty_def}]

   536     val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}

   537     val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}

   538     val del_refl_eq = @{lemma "(t = t & P) == P" by simp}

   539     fun mk_set T = Const (@{const_name List.set}, HOLogic.listT T --> HOLogic.mk_setT T)

   540     fun dest_set (Const (@{const_name List.set}, _) $xs) = xs   541 fun dest_singleton_list (Const (@{const_name List.Cons}, _)   542$ t $(Const (@{const_name List.Nil}, _))) = t   543 | dest_singleton_list t = raise TERM ("dest_singleton_list", [t])   544 (* We check that one case returns a singleton list and all other cases   545 return [], and return the index of the one singleton list case *)   546 fun possible_index_of_singleton_case cases =   547 let   548 fun check (i, case_t) s =   549 (case strip_abs_body case_t of   550 (Const (@{const_name List.Nil}, _)) => s   551 | _ => (case s of NONE => SOME i | SOME _ => NONE))   552 in   553 fold_index check cases NONE   554 end   555 (* returns (case_expr type index chosen_case) option *)   556 fun dest_case case_term =   557 let   558 val (case_const, args) = strip_comb case_term   559 in   560 (case try dest_Const case_const of   561 SOME (c, T) =>   562 (case Datatype.info_of_case thy c of   563 SOME _ =>   564 (case possible_index_of_singleton_case (fst (split_last args)) of   565 SOME i =>   566 let   567 val (Ts, _) = strip_type T   568 val T' = List.last Ts   569 in SOME (List.last args, T', i, nth args i) end   570 | NONE => NONE)   571 | NONE => NONE)   572 | NONE => NONE)   573 end   574 (* returns condition continuing term option *)   575 fun dest_if (Const (@{const_name If}, _)$ cond $then_t$ Const (@{const_name Nil}, _)) =

   576           SOME (cond, then_t)

   577       | dest_if _ = NONE

   578     fun tac _ [] = rtac set_singleton 1 ORELSE rtac inst_Collect_mem_eq 1

   579       | tac ctxt (If :: cont) =

   580           Splitter.split_tac [@{thm split_if}] 1

   581           THEN rtac @{thm conjI} 1

   582           THEN rtac @{thm impI} 1

   583           THEN Subgoal.FOCUS (fn {prems, context, ...} =>

   584             CONVERSION (right_hand_set_comprehension_conv (K

   585               (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv

   586                then_conv

   587                rewr_conv' @{lemma "(True & P) = P" by simp})) context) 1) ctxt 1

   588           THEN tac ctxt cont

   589           THEN rtac @{thm impI} 1

   590           THEN Subgoal.FOCUS (fn {prems, context, ...} =>

   591               CONVERSION (right_hand_set_comprehension_conv (K

   592                 (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv

   593                  then_conv rewr_conv' @{lemma "(False & P) = False" by simp})) context) 1) ctxt 1

   594           THEN rtac set_Nil_I 1

   595       | tac ctxt (Case (T, i) :: cont) =

   596           let

   597             val info = Datatype.the_info thy (fst (dest_Type T))

   598           in

   599             (* do case distinction *)

   600             Splitter.split_tac [#split info] 1

   601             THEN EVERY (map_index (fn (i', _) =>

   602               (if i' < length (#case_rewrites info) - 1 then rtac @{thm conjI} 1 else all_tac)

   603               THEN REPEAT_DETERM (rtac @{thm allI} 1)

   604               THEN rtac @{thm impI} 1

   605               THEN (if i' = i then

   606                 (* continue recursively *)

   607                 Subgoal.FOCUS (fn {prems, context, ...} =>

   608                   CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K

   609                       ((HOLogic.conj_conv

   610                         (HOLogic.eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv

   611                           (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq (#inject info)))))

   612                         Conv.all_conv)

   613                         then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))

   614                         then_conv conjunct_assoc_conv)) context

   615                     then_conv (HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt) =>

   616                       Conv.repeat_conv

   617                         (all_but_last_exists_conv

   618                           (K (rewr_conv'

   619                             @{lemma "(EX x. x = t & P x) = P t" by simp})) ctxt)) context)))) 1) ctxt 1

   620                 THEN tac ctxt cont

   621               else

   622                 Subgoal.FOCUS (fn {prems, context, ...} =>

   623                   CONVERSION

   624                     (right_hand_set_comprehension_conv (K

   625                       (HOLogic.conj_conv

   626                         ((HOLogic.eq_conv Conv.all_conv

   627                           (rewr_conv' (List.last prems))) then_conv

   628                           (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) (#distinct info))))

   629                         Conv.all_conv then_conv

   630                         (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv

   631                       HOLogic.Trueprop_conv

   632                         (HOLogic.eq_conv Conv.all_conv

   633                           (Collect_conv (fn (_, ctxt) =>

   634                             Conv.repeat_conv

   635                               (Conv.bottom_conv

   636                                 (K (rewr_conv'

   637                                   @{lemma "(EX x. P) = P" by simp})) ctxt)) context))) 1) ctxt 1

   638                 THEN rtac set_Nil_I 1)) (#case_rewrites info))

   639           end

   640     fun make_inner_eqs bound_vs Tis eqs t =

   641       (case dest_case t of

   642         SOME (x, T, i, cont) =>

   643           let

   644             val (vs, body) = strip_abs (Envir.eta_long (map snd bound_vs) cont)

   645             val x' = incr_boundvars (length vs) x

   646             val eqs' = map (incr_boundvars (length vs)) eqs

   647             val (constr_name, _) = nth (the (Datatype.get_constrs thy (fst (dest_Type T)))) i

   648             val constr_t =

   649               list_comb

   650                 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))

   651             val constr_eq = Const (@{const_name HOL.eq}, T --> T --> @{typ bool}) $constr_t$ x'

   652           in

   653             make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body

   654           end

   655       | NONE =>

   656           (case dest_if t of

   657             SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont

   658           | NONE =>

   659             if eqs = [] then NONE (* no rewriting, nothing to be done *)

   660             else

   661               let

   662                 val Type (@{type_name List.list}, [rT]) = fastype_of1 (map snd bound_vs, t)

   663                 val pat_eq =

   664                   (case try dest_singleton_list t of

   665                     SOME t' =>

   666                       Const (@{const_name HOL.eq}, rT --> rT --> @{typ bool}) $  667 Bound (length bound_vs)$ t'

   668                   | NONE =>

   669                       Const (@{const_name Set.member}, rT --> HOLogic.mk_setT rT --> @{typ bool}) $  670 Bound (length bound_vs)$ (mk_set rT $t))   671 val reverse_bounds = curry subst_bounds   672 ((map Bound ((length bound_vs - 1) downto 0)) @ [Bound (length bound_vs)])   673 val eqs' = map reverse_bounds eqs   674 val pat_eq' = reverse_bounds pat_eq   675 val inner_t =   676 fold (fn (_, T) => fn t => HOLogic.exists_const T$ absdummy T t)

   677                     (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')

   678                 val lhs = term_of redex

   679                 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)

   680                 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))

   681               in

   682                 SOME

   683                   ((Goal.prove ctxt [] [] rewrite_rule_t

   684                     (fn {context, ...} => tac context (rev Tis))) RS @{thm eq_reflection})

   685               end))

   686   in

   687     make_inner_eqs [] [] [] (dest_set (term_of redex))

   688   end

   689

   690 end

   691 *}

   692

   693 simproc_setup list_to_set_comprehension ("set xs") = {* K List_to_Set_Comprehension.simproc *}

   694

   695 code_datatype set coset

   696

   697 hide_const (open) coset

   698

   699

   700 subsubsection {* @{const Nil} and @{const Cons} *}

   701

   702 lemma not_Cons_self [simp]:

   703   "xs \<noteq> x # xs"

   704 by (induct xs) auto

   705

   706 lemma not_Cons_self2 [simp]:

   707   "x # xs \<noteq> xs"

   708 by (rule not_Cons_self [symmetric])

   709

   710 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"

   711 by (induct xs) auto

   712

   713 lemma length_induct:

   714   "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"

   715 by (rule measure_induct [of length]) iprover

   716

   717 lemma list_nonempty_induct [consumes 1, case_names single cons]:

   718   assumes "xs \<noteq> []"

   719   assumes single: "\<And>x. P [x]"

   720   assumes cons: "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)"

   721   shows "P xs"

   722 using xs \<noteq> [] proof (induct xs)

   723   case Nil then show ?case by simp

   724 next

   725   case (Cons x xs) show ?case proof (cases xs)

   726     case Nil with single show ?thesis by simp

   727   next

   728     case Cons then have "xs \<noteq> []" by simp

   729     moreover with Cons.hyps have "P xs" .

   730     ultimately show ?thesis by (rule cons)

   731   qed

   732 qed

   733

   734 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"

   735   by (auto intro!: inj_onI)

   736

   737

   738 subsubsection {* @{const length} *}

   739

   740 text {*

   741   Needs to come before @{text "@"} because of theorem @{text

   742   append_eq_append_conv}.

   743 *}

   744

   745 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"

   746 by (induct xs) auto

   747

   748 lemma length_map [simp]: "length (map f xs) = length xs"

   749 by (induct xs) auto

   750

   751 lemma length_rev [simp]: "length (rev xs) = length xs"

   752 by (induct xs) auto

   753

   754 lemma length_tl [simp]: "length (tl xs) = length xs - 1"

   755 by (cases xs) auto

   756

   757 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"

   758 by (induct xs) auto

   759

   760 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"

   761 by (induct xs) auto

   762

   763 lemma length_pos_if_in_set: "x : set xs \<Longrightarrow> length xs > 0"

   764 by auto

   765

   766 lemma length_Suc_conv:

   767 "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"

   768 by (induct xs) auto

   769

   770 lemma Suc_length_conv:

   771 "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"

   772 apply (induct xs, simp, simp)

   773 apply blast

   774 done

   775

   776 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False"

   777   by (induct xs) auto

   778

   779 lemma list_induct2 [consumes 1, case_names Nil Cons]:

   780   "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>

   781    (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))

   782    \<Longrightarrow> P xs ys"

   783 proof (induct xs arbitrary: ys)

   784   case Nil then show ?case by simp

   785 next

   786   case (Cons x xs ys) then show ?case by (cases ys) simp_all

   787 qed

   788

   789 lemma list_induct3 [consumes 2, case_names Nil Cons]:

   790   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>

   791    (\<And>x xs y ys z zs. length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P xs ys zs \<Longrightarrow> P (x#xs) (y#ys) (z#zs))

   792    \<Longrightarrow> P xs ys zs"

   793 proof (induct xs arbitrary: ys zs)

   794   case Nil then show ?case by simp

   795 next

   796   case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)

   797     (cases zs, simp_all)

   798 qed

   799

   800 lemma list_induct4 [consumes 3, case_names Nil Cons]:

   801   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>

   802    P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>

   803    length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>

   804    P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"

   805 proof (induct xs arbitrary: ys zs ws)

   806   case Nil then show ?case by simp

   807 next

   808   case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)

   809 qed

   810

   811 lemma list_induct2':

   812   "\<lbrakk> P [] [];

   813   \<And>x xs. P (x#xs) [];

   814   \<And>y ys. P [] (y#ys);

   815    \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>

   816  \<Longrightarrow> P xs ys"

   817 by (induct xs arbitrary: ys) (case_tac x, auto)+

   818

   819 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"

   820 by (rule Eq_FalseI) auto

   821

   822 simproc_setup list_neq ("(xs::'a list) = ys") = {*

   823 (*

   824 Reduces xs=ys to False if xs and ys cannot be of the same length.

   825 This is the case if the atomic sublists of one are a submultiset

   826 of those of the other list and there are fewer Cons's in one than the other.

   827 *)

   828

   829 let

   830

   831 fun len (Const(@{const_name Nil},_)) acc = acc

   832   | len (Const(@{const_name Cons},_) $_$ xs) (ts,n) = len xs (ts,n+1)

   833   | len (Const(@{const_name append},_) $xs$ ys) acc = len xs (len ys acc)

   834   | len (Const(@{const_name rev},_) $xs) acc = len xs acc   835 | len (Const(@{const_name map},_)$ _ $xs) acc = len xs acc   836 | len t (ts,n) = (t::ts,n);   837   838 val ss = simpset_of @{context};   839   840 fun list_neq ctxt ct =   841 let   842 val (Const(_,eqT)$ lhs $rhs) = Thm.term_of ct;   843 val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);   844 fun prove_neq() =   845 let   846 val Type(_,listT::_) = eqT;   847 val size = HOLogic.size_const listT;   848 val eq_len = HOLogic.mk_eq (size$ lhs, size $rhs);   849 val neq_len = HOLogic.mk_Trueprop (HOLogic.Not$ eq_len);

   850         val thm = Goal.prove ctxt [] [] neq_len

   851           (K (simp_tac (put_simpset ss ctxt) 1));

   852       in SOME (thm RS @{thm neq_if_length_neq}) end

   853   in

   854     if m < n andalso submultiset (op aconv) (ls,rs) orelse

   855        n < m andalso submultiset (op aconv) (rs,ls)

   856     then prove_neq() else NONE

   857   end;

   858 in K list_neq end;

   859 *}

   860

   861

   862 subsubsection {* @{text "@"} -- append *}

   863

   864 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"

   865 by (induct xs) auto

   866

   867 lemma append_Nil2 [simp]: "xs @ [] = xs"

   868 by (induct xs) auto

   869

   870 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"

   871 by (induct xs) auto

   872

   873 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"

   874 by (induct xs) auto

   875

   876 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"

   877 by (induct xs) auto

   878

   879 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"

   880 by (induct xs) auto

   881

   882 lemma append_eq_append_conv [simp, no_atp]:

   883  "length xs = length ys \<or> length us = length vs

   884  ==> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"

   885 apply (induct xs arbitrary: ys)

   886  apply (case_tac ys, simp, force)

   887 apply (case_tac ys, force, simp)

   888 done

   889

   890 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =

   891   (EX us. xs = zs @ us & us @ ys = ts | xs @ us = zs & ys = us@ ts)"

   892 apply (induct xs arbitrary: ys zs ts)

   893  apply fastforce

   894 apply(case_tac zs)

   895  apply simp

   896 apply fastforce

   897 done

   898

   899 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"

   900 by simp

   901

   902 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"

   903 by simp

   904

   905 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"

   906 by simp

   907

   908 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"

   909 using append_same_eq [of _ _ "[]"] by auto

   910

   911 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"

   912 using append_same_eq [of "[]"] by auto

   913

   914 lemma hd_Cons_tl [simp,no_atp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"

   915 by (induct xs) auto

   916

   917 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"

   918 by (induct xs) auto

   919

   920 lemma hd_append2 [simp]: "xs \<noteq> [] ==> hd (xs @ ys) = hd xs"

   921 by (simp add: hd_append split: list.split)

   922

   923 lemma tl_append: "tl (xs @ ys) = (case xs of [] => tl ys | z#zs => zs @ ys)"

   924 by (simp split: list.split)

   925

   926 lemma tl_append2 [simp]: "xs \<noteq> [] ==> tl (xs @ ys) = tl xs @ ys"

   927 by (simp add: tl_append split: list.split)

   928

   929

   930 lemma Cons_eq_append_conv: "x#xs = ys@zs =

   931  (ys = [] & x#xs = zs | (EX ys'. x#ys' = ys & xs = ys'@zs))"

   932 by(cases ys) auto

   933

   934 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =

   935  (ys = [] & zs = x#xs | (EX ys'. ys = x#ys' & ys'@zs = xs))"

   936 by(cases ys) auto

   937

   938

   939 text {* Trivial rules for solving @{text "@"}-equations automatically. *}

   940

   941 lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"

   942 by simp

   943

   944 lemma Cons_eq_appendI:

   945 "[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"

   946 by (drule sym) simp

   947

   948 lemma append_eq_appendI:

   949 "[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"

   950 by (drule sym) simp

   951

   952

   953 text {*

   954 Simplification procedure for all list equalities.

   955 Currently only tries to rearrange @{text "@"} to see if

   956 - both lists end in a singleton list,

   957 - or both lists end in the same list.

   958 *}

   959

   960 simproc_setup list_eq ("(xs::'a list) = ys")  = {*

   961   let

   962     fun last (cons as Const (@{const_name Cons}, _) $_$ xs) =

   963           (case xs of Const (@{const_name Nil}, _) => cons | _ => last xs)

   964       | last (Const(@{const_name append},_) $_$ ys) = last ys

   965       | last t = t;

   966

   967     fun list1 (Const(@{const_name Cons},_) $_$ Const(@{const_name Nil},_)) = true

   968       | list1 _ = false;

   969

   970     fun butlast ((cons as Const(@{const_name Cons},_) $x)$ xs) =

   971           (case xs of Const (@{const_name Nil}, _) => xs | _ => cons $butlast xs)   972 | butlast ((app as Const (@{const_name append}, _)$ xs) $ys) = app$ butlast ys

   973       | butlast xs = Const(@{const_name Nil}, fastype_of xs);

   974

   975     val rearr_ss =

   976       simpset_of (put_simpset HOL_basic_ss @{context}

   977         addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}]);

   978

   979     fun list_eq ctxt (F as (eq as Const(_,eqT)) $lhs$ rhs) =

   980       let

   981         val lastl = last lhs and lastr = last rhs;

   982         fun rearr conv =

   983           let

   984             val lhs1 = butlast lhs and rhs1 = butlast rhs;

   985             val Type(_,listT::_) = eqT

   986             val appT = [listT,listT] ---> listT

   987             val app = Const(@{const_name append},appT)

   988             val F2 = eq $(app$lhs1$lastl)$ (app$rhs1$lastr)

   989             val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (F,F2));

   990             val thm = Goal.prove ctxt [] [] eq

   991               (K (simp_tac (put_simpset rearr_ss ctxt) 1));

   992           in SOME ((conv RS (thm RS trans)) RS eq_reflection) end;

   993       in

   994         if list1 lastl andalso list1 lastr then rearr @{thm append1_eq_conv}

   995         else if lastl aconv lastr then rearr @{thm append_same_eq}

   996         else NONE

   997       end;

   998   in fn _ => fn ctxt => fn ct => list_eq ctxt (term_of ct) end;

   999 *}

  1000

  1001

  1002 subsubsection {* @{const map} *}

  1003

  1004 lemma hd_map:

  1005   "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"

  1006   by (cases xs) simp_all

  1007

  1008 lemma map_tl:

  1009   "map f (tl xs) = tl (map f xs)"

  1010   by (cases xs) simp_all

  1011

  1012 lemma map_ext: "(!!x. x : set xs --> f x = g x) ==> map f xs = map g xs"

  1013 by (induct xs) simp_all

  1014

  1015 lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"

  1016 by (rule ext, induct_tac xs) auto

  1017

  1018 lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"

  1019 by (induct xs) auto

  1020

  1021 lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"

  1022 by (induct xs) auto

  1023

  1024 lemma map_comp_map[simp]: "((map f) o (map g)) = map(f o g)"

  1025 apply(rule ext)

  1026 apply(simp)

  1027 done

  1028

  1029 lemma rev_map: "rev (map f xs) = map f (rev xs)"

  1030 by (induct xs) auto

  1031

  1032 lemma map_eq_conv[simp]: "(map f xs = map g xs) = (!x : set xs. f x = g x)"

  1033 by (induct xs) auto

  1034

  1035 lemma map_cong [fundef_cong]:

  1036   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g ys"

  1037   by simp

  1038

  1039 lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"

  1040 by (cases xs) auto

  1041

  1042 lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"

  1043 by (cases xs) auto

  1044

  1045 lemma map_eq_Cons_conv:

  1046  "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"

  1047 by (cases xs) auto

  1048

  1049 lemma Cons_eq_map_conv:

  1050  "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"

  1051 by (cases ys) auto

  1052

  1053 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]

  1054 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]

  1055 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]

  1056

  1057 lemma ex_map_conv:

  1058   "(EX xs. ys = map f xs) = (ALL y : set ys. EX x. y = f x)"

  1059 by(induct ys, auto simp add: Cons_eq_map_conv)

  1060

  1061 lemma map_eq_imp_length_eq:

  1062   assumes "map f xs = map g ys"

  1063   shows "length xs = length ys"

  1064 using assms proof (induct ys arbitrary: xs)

  1065   case Nil then show ?case by simp

  1066 next

  1067   case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto

  1068   from Cons xs have "map f zs = map g ys" by simp

  1069   moreover with Cons have "length zs = length ys" by blast

  1070   with xs show ?case by simp

  1071 qed

  1072

  1073 lemma map_inj_on:

  1074  "[| map f xs = map f ys; inj_on f (set xs Un set ys) |]

  1075   ==> xs = ys"

  1076 apply(frule map_eq_imp_length_eq)

  1077 apply(rotate_tac -1)

  1078 apply(induct rule:list_induct2)

  1079  apply simp

  1080 apply(simp)

  1081 apply (blast intro:sym)

  1082 done

  1083

  1084 lemma inj_on_map_eq_map:

  1085  "inj_on f (set xs Un set ys) \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"

  1086 by(blast dest:map_inj_on)

  1087

  1088 lemma map_injective:

  1089  "map f xs = map f ys ==> inj f ==> xs = ys"

  1090 by (induct ys arbitrary: xs) (auto dest!:injD)

  1091

  1092 lemma inj_map_eq_map[simp]: "inj f \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"

  1093 by(blast dest:map_injective)

  1094

  1095 lemma inj_mapI: "inj f ==> inj (map f)"

  1096 by (iprover dest: map_injective injD intro: inj_onI)

  1097

  1098 lemma inj_mapD: "inj (map f) ==> inj f"

  1099 apply (unfold inj_on_def, clarify)

  1100 apply (erule_tac x = "[x]" in ballE)

  1101  apply (erule_tac x = "[y]" in ballE, simp, blast)

  1102 apply blast

  1103 done

  1104

  1105 lemma inj_map[iff]: "inj (map f) = inj f"

  1106 by (blast dest: inj_mapD intro: inj_mapI)

  1107

  1108 lemma inj_on_mapI: "inj_on f (\<Union>(set  A)) \<Longrightarrow> inj_on (map f) A"

  1109 apply(rule inj_onI)

  1110 apply(erule map_inj_on)

  1111 apply(blast intro:inj_onI dest:inj_onD)

  1112 done

  1113

  1114 lemma map_idI: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = x) \<Longrightarrow> map f xs = xs"

  1115 by (induct xs, auto)

  1116

  1117 lemma map_fun_upd [simp]: "y \<notin> set xs \<Longrightarrow> map (f(y:=v)) xs = map f xs"

  1118 by (induct xs) auto

  1119

  1120 lemma map_fst_zip[simp]:

  1121   "length xs = length ys \<Longrightarrow> map fst (zip xs ys) = xs"

  1122 by (induct rule:list_induct2, simp_all)

  1123

  1124 lemma map_snd_zip[simp]:

  1125   "length xs = length ys \<Longrightarrow> map snd (zip xs ys) = ys"

  1126 by (induct rule:list_induct2, simp_all)

  1127

  1128 enriched_type map: map

  1129 by (simp_all add: id_def)

  1130

  1131 declare map.id [simp]

  1132

  1133

  1134 subsubsection {* @{const rev} *}

  1135

  1136 lemma rev_append [simp]: "rev (xs @ ys) = rev ys @ rev xs"

  1137 by (induct xs) auto

  1138

  1139 lemma rev_rev_ident [simp]: "rev (rev xs) = xs"

  1140 by (induct xs) auto

  1141

  1142 lemma rev_swap: "(rev xs = ys) = (xs = rev ys)"

  1143 by auto

  1144

  1145 lemma rev_is_Nil_conv [iff]: "(rev xs = []) = (xs = [])"

  1146 by (induct xs) auto

  1147

  1148 lemma Nil_is_rev_conv [iff]: "([] = rev xs) = (xs = [])"

  1149 by (induct xs) auto

  1150

  1151 lemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"

  1152 by (cases xs) auto

  1153

  1154 lemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"

  1155 by (cases xs) auto

  1156

  1157 lemma rev_is_rev_conv [iff, no_atp]: "(rev xs = rev ys) = (xs = ys)"

  1158 apply (induct xs arbitrary: ys, force)

  1159 apply (case_tac ys, simp, force)

  1160 done

  1161

  1162 lemma inj_on_rev[iff]: "inj_on rev A"

  1163 by(simp add:inj_on_def)

  1164

  1165 lemma rev_induct [case_names Nil snoc]:

  1166   "[| P []; !!x xs. P xs ==> P (xs @ [x]) |] ==> P xs"

  1167 apply(simplesubst rev_rev_ident[symmetric])

  1168 apply(rule_tac list = "rev xs" in list.induct, simp_all)

  1169 done

  1170

  1171 lemma rev_exhaust [case_names Nil snoc]:

  1172   "(xs = [] ==> P) ==>(!!ys y. xs = ys @ [y] ==> P) ==> P"

  1173 by (induct xs rule: rev_induct) auto

  1174

  1175 lemmas rev_cases = rev_exhaust

  1176

  1177 lemma rev_eq_Cons_iff[iff]: "(rev xs = y#ys) = (xs = rev ys @ [y])"

  1178 by(rule rev_cases[of xs]) auto

  1179

  1180

  1181 subsubsection {* @{const set} *}

  1182

  1183 declare set.simps [code_post]  --"pretty output"

  1184

  1185 lemma finite_set [iff]: "finite (set xs)"

  1186 by (induct xs) auto

  1187

  1188 lemma set_append [simp]: "set (xs @ ys) = (set xs \<union> set ys)"

  1189 by (induct xs) auto

  1190

  1191 lemma hd_in_set[simp]: "xs \<noteq> [] \<Longrightarrow> hd xs : set xs"

  1192 by(cases xs) auto

  1193

  1194 lemma set_subset_Cons: "set xs \<subseteq> set (x # xs)"

  1195 by auto

  1196

  1197 lemma set_ConsD: "y \<in> set (x # xs) \<Longrightarrow> y=x \<or> y \<in> set xs"

  1198 by auto

  1199

  1200 lemma set_empty [iff]: "(set xs = {}) = (xs = [])"

  1201 by (induct xs) auto

  1202

  1203 lemma set_empty2[iff]: "({} = set xs) = (xs = [])"

  1204 by(induct xs) auto

  1205

  1206 lemma set_rev [simp]: "set (rev xs) = set xs"

  1207 by (induct xs) auto

  1208

  1209 lemma set_map [simp]: "set (map f xs) = f(set xs)"

  1210 by (induct xs) auto

  1211

  1212 lemma set_filter [simp]: "set (filter P xs) = {x. x : set xs \<and> P x}"

  1213 by (induct xs) auto

  1214

  1215 lemma set_upt [simp]: "set[i..<j] = {i..<j}"

  1216 by (induct j) auto

  1217

  1218

  1219 lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"

  1220 proof (induct xs)

  1221   case Nil thus ?case by simp

  1222 next

  1223   case Cons thus ?case by (auto intro: Cons_eq_appendI)

  1224 qed

  1225

  1226 lemma in_set_conv_decomp: "x \<in> set xs \<longleftrightarrow> (\<exists>ys zs. xs = ys @ x # zs)"

  1227   by (auto elim: split_list)

  1228

  1229 lemma split_list_first: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys"

  1230 proof (induct xs)

  1231   case Nil thus ?case by simp

  1232 next

  1233   case (Cons a xs)

  1234   show ?case

  1235   proof cases

  1236     assume "x = a" thus ?case using Cons by fastforce

  1237   next

  1238     assume "x \<noteq> a" thus ?case using Cons by(fastforce intro!: Cons_eq_appendI)

  1239   qed

  1240 qed

  1241

  1242 lemma in_set_conv_decomp_first:

  1243   "(x : set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys)"

  1244   by (auto dest!: split_list_first)

  1245

  1246 lemma split_list_last: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs"

  1247 proof (induct xs rule: rev_induct)

  1248   case Nil thus ?case by simp

  1249 next

  1250   case (snoc a xs)

  1251   show ?case

  1252   proof cases

  1253     assume "x = a" thus ?case using snoc by (metis List.set.simps(1) emptyE)

  1254   next

  1255     assume "x \<noteq> a" thus ?case using snoc by fastforce

  1256   qed

  1257 qed

  1258

  1259 lemma in_set_conv_decomp_last:

  1260   "(x : set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs)"

  1261   by (auto dest!: split_list_last)

  1262

  1263 lemma split_list_prop: "\<exists>x \<in> set xs. P x \<Longrightarrow> \<exists>ys x zs. xs = ys @ x # zs & P x"

  1264 proof (induct xs)

  1265   case Nil thus ?case by simp

  1266 next

  1267   case Cons thus ?case

  1268     by(simp add:Bex_def)(metis append_Cons append.simps(1))

  1269 qed

  1270

  1271 lemma split_list_propE:

  1272   assumes "\<exists>x \<in> set xs. P x"

  1273   obtains ys x zs where "xs = ys @ x # zs" and "P x"

  1274 using split_list_prop [OF assms] by blast

  1275

  1276 lemma split_list_first_prop:

  1277   "\<exists>x \<in> set xs. P x \<Longrightarrow>

  1278    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"

  1279 proof (induct xs)

  1280   case Nil thus ?case by simp

  1281 next

  1282   case (Cons x xs)

  1283   show ?case

  1284   proof cases

  1285     assume "P x"

  1286     thus ?thesis by simp (metis Un_upper1 contra_subsetD in_set_conv_decomp_first self_append_conv2 set_append)

  1287   next

  1288     assume "\<not> P x"

  1289     hence "\<exists>x\<in>set xs. P x" using Cons(2) by simp

  1290     thus ?thesis using \<not> P x Cons(1) by (metis append_Cons set_ConsD)

  1291   qed

  1292 qed

  1293

  1294 lemma split_list_first_propE:

  1295   assumes "\<exists>x \<in> set xs. P x"

  1296   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>y \<in> set ys. \<not> P y"

  1297 using split_list_first_prop [OF assms] by blast

  1298

  1299 lemma split_list_first_prop_iff:

  1300   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>

  1301    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y))"

  1302 by (rule, erule split_list_first_prop) auto

  1303

  1304 lemma split_list_last_prop:

  1305   "\<exists>x \<in> set xs. P x \<Longrightarrow>

  1306    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z)"

  1307 proof(induct xs rule:rev_induct)

  1308   case Nil thus ?case by simp

  1309 next

  1310   case (snoc x xs)

  1311   show ?case

  1312   proof cases

  1313     assume "P x" thus ?thesis by (metis emptyE set_empty)

  1314   next

  1315     assume "\<not> P x"

  1316     hence "\<exists>x\<in>set xs. P x" using snoc(2) by simp

  1317     thus ?thesis using \<not> P x snoc(1) by fastforce

  1318   qed

  1319 qed

  1320

  1321 lemma split_list_last_propE:

  1322   assumes "\<exists>x \<in> set xs. P x"

  1323   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>z \<in> set zs. \<not> P z"

  1324 using split_list_last_prop [OF assms] by blast

  1325

  1326 lemma split_list_last_prop_iff:

  1327   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>

  1328    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"

  1329 by (metis split_list_last_prop [where P=P] in_set_conv_decomp)

  1330

  1331 lemma finite_list: "finite A ==> EX xs. set xs = A"

  1332   by (erule finite_induct)

  1333     (auto simp add: set.simps(2) [symmetric] simp del: set.simps(2))

  1334

  1335 lemma card_length: "card (set xs) \<le> length xs"

  1336 by (induct xs) (auto simp add: card_insert_if)

  1337

  1338 lemma set_minus_filter_out:

  1339   "set xs - {y} = set (filter (\<lambda>x. \<not> (x = y)) xs)"

  1340   by (induct xs) auto

  1341

  1342

  1343 subsubsection {* @{const filter} *}

  1344

  1345 lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"

  1346 by (induct xs) auto

  1347

  1348 lemma rev_filter: "rev (filter P xs) = filter P (rev xs)"

  1349 by (induct xs) simp_all

  1350

  1351 lemma filter_filter [simp]: "filter P (filter Q xs) = filter (\<lambda>x. Q x \<and> P x) xs"

  1352 by (induct xs) auto

  1353

  1354 lemma length_filter_le [simp]: "length (filter P xs) \<le> length xs"

  1355 by (induct xs) (auto simp add: le_SucI)

  1356

  1357 lemma sum_length_filter_compl:

  1358   "length(filter P xs) + length(filter (%x. ~P x) xs) = length xs"

  1359 by(induct xs) simp_all

  1360

  1361 lemma filter_True [simp]: "\<forall>x \<in> set xs. P x ==> filter P xs = xs"

  1362 by (induct xs) auto

  1363

  1364 lemma filter_False [simp]: "\<forall>x \<in> set xs. \<not> P x ==> filter P xs = []"

  1365 by (induct xs) auto

  1366

  1367 lemma filter_empty_conv: "(filter P xs = []) = (\<forall>x\<in>set xs. \<not> P x)"

  1368 by (induct xs) simp_all

  1369

  1370 lemma filter_id_conv: "(filter P xs = xs) = (\<forall>x\<in>set xs. P x)"

  1371 apply (induct xs)

  1372  apply auto

  1373 apply(cut_tac P=P and xs=xs in length_filter_le)

  1374 apply simp

  1375 done

  1376

  1377 lemma filter_map:

  1378   "filter P (map f xs) = map f (filter (P o f) xs)"

  1379 by (induct xs) simp_all

  1380

  1381 lemma length_filter_map[simp]:

  1382   "length (filter P (map f xs)) = length(filter (P o f) xs)"

  1383 by (simp add:filter_map)

  1384

  1385 lemma filter_is_subset [simp]: "set (filter P xs) \<le> set xs"

  1386 by auto

  1387

  1388 lemma length_filter_less:

  1389   "\<lbrakk> x : set xs; ~ P x \<rbrakk> \<Longrightarrow> length(filter P xs) < length xs"

  1390 proof (induct xs)

  1391   case Nil thus ?case by simp

  1392 next

  1393   case (Cons x xs) thus ?case

  1394     apply (auto split:split_if_asm)

  1395     using length_filter_le[of P xs] apply arith

  1396   done

  1397 qed

  1398

  1399 lemma length_filter_conv_card:

  1400  "length(filter p xs) = card{i. i < length xs & p(xs!i)}"

  1401 proof (induct xs)

  1402   case Nil thus ?case by simp

  1403 next

  1404   case (Cons x xs)

  1405   let ?S = "{i. i < length xs & p(xs!i)}"

  1406   have fin: "finite ?S" by(fast intro: bounded_nat_set_is_finite)

  1407   show ?case (is "?l = card ?S'")

  1408   proof (cases)

  1409     assume "p x"

  1410     hence eq: "?S' = insert 0 (Suc  ?S)"

  1411       by(auto simp: image_def split:nat.split dest:gr0_implies_Suc)

  1412     have "length (filter p (x # xs)) = Suc(card ?S)"

  1413       using Cons p x by simp

  1414     also have "\<dots> = Suc(card(Suc  ?S))" using fin

  1415       by (simp add: card_image)

  1416     also have "\<dots> = card ?S'" using eq fin

  1417       by (simp add:card_insert_if) (simp add:image_def)

  1418     finally show ?thesis .

  1419   next

  1420     assume "\<not> p x"

  1421     hence eq: "?S' = Suc  ?S"

  1422       by(auto simp add: image_def split:nat.split elim:lessE)

  1423     have "length (filter p (x # xs)) = card ?S"

  1424       using Cons \<not> p x by simp

  1425     also have "\<dots> = card(Suc  ?S)" using fin

  1426       by (simp add: card_image)

  1427     also have "\<dots> = card ?S'" using eq fin

  1428       by (simp add:card_insert_if)

  1429     finally show ?thesis .

  1430   qed

  1431 qed

  1432

  1433 lemma Cons_eq_filterD:

  1434  "x#xs = filter P ys \<Longrightarrow>

  1435   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"

  1436   (is "_ \<Longrightarrow> \<exists>us vs. ?P ys us vs")

  1437 proof(induct ys)

  1438   case Nil thus ?case by simp

  1439 next

  1440   case (Cons y ys)

  1441   show ?case (is "\<exists>x. ?Q x")

  1442   proof cases

  1443     assume Py: "P y"

  1444     show ?thesis

  1445     proof cases

  1446       assume "x = y"

  1447       with Py Cons.prems have "?Q []" by simp

  1448       then show ?thesis ..

  1449     next

  1450       assume "x \<noteq> y"

  1451       with Py Cons.prems show ?thesis by simp

  1452     qed

  1453   next

  1454     assume "\<not> P y"

  1455     with Cons obtain us vs where "?P (y#ys) (y#us) vs" by fastforce

  1456     then have "?Q (y#us)" by simp

  1457     then show ?thesis ..

  1458   qed

  1459 qed

  1460

  1461 lemma filter_eq_ConsD:

  1462  "filter P ys = x#xs \<Longrightarrow>

  1463   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"

  1464 by(rule Cons_eq_filterD) simp

  1465

  1466 lemma filter_eq_Cons_iff:

  1467  "(filter P ys = x#xs) =

  1468   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"

  1469 by(auto dest:filter_eq_ConsD)

  1470

  1471 lemma Cons_eq_filter_iff:

  1472  "(x#xs = filter P ys) =

  1473   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"

  1474 by(auto dest:Cons_eq_filterD)

  1475

  1476 lemma filter_cong[fundef_cong]:

  1477  "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x) \<Longrightarrow> filter P xs = filter Q ys"

  1478 apply simp

  1479 apply(erule thin_rl)

  1480 by (induct ys) simp_all

  1481

  1482

  1483 subsubsection {* List partitioning *}

  1484

  1485 primrec partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" where

  1486 "partition P [] = ([], [])" |

  1487 "partition P (x # xs) =

  1488   (let (yes, no) = partition P xs

  1489    in if P x then (x # yes, no) else (yes, x # no))"

  1490

  1491 lemma partition_filter1:

  1492     "fst (partition P xs) = filter P xs"

  1493 by (induct xs) (auto simp add: Let_def split_def)

  1494

  1495 lemma partition_filter2:

  1496     "snd (partition P xs) = filter (Not o P) xs"

  1497 by (induct xs) (auto simp add: Let_def split_def)

  1498

  1499 lemma partition_P:

  1500   assumes "partition P xs = (yes, no)"

  1501   shows "(\<forall>p \<in> set yes.  P p) \<and> (\<forall>p  \<in> set no. \<not> P p)"

  1502 proof -

  1503   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"

  1504     by simp_all

  1505   then show ?thesis by (simp_all add: partition_filter1 partition_filter2)

  1506 qed

  1507

  1508 lemma partition_set:

  1509   assumes "partition P xs = (yes, no)"

  1510   shows "set yes \<union> set no = set xs"

  1511 proof -

  1512   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"

  1513     by simp_all

  1514   then show ?thesis by (auto simp add: partition_filter1 partition_filter2)

  1515 qed

  1516

  1517 lemma partition_filter_conv[simp]:

  1518   "partition f xs = (filter f xs,filter (Not o f) xs)"

  1519 unfolding partition_filter2[symmetric]

  1520 unfolding partition_filter1[symmetric] by simp

  1521

  1522 declare partition.simps[simp del]

  1523

  1524

  1525 subsubsection {* @{const concat} *}

  1526

  1527 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"

  1528 by (induct xs) auto

  1529

  1530 lemma concat_eq_Nil_conv [simp]: "(concat xss = []) = (\<forall>xs \<in> set xss. xs = [])"

  1531 by (induct xss) auto

  1532

  1533 lemma Nil_eq_concat_conv [simp]: "([] = concat xss) = (\<forall>xs \<in> set xss. xs = [])"

  1534 by (induct xss) auto

  1535

  1536 lemma set_concat [simp]: "set (concat xs) = (UN x:set xs. set x)"

  1537 by (induct xs) auto

  1538

  1539 lemma concat_map_singleton[simp]: "concat(map (%x. [f x]) xs) = map f xs"

  1540 by (induct xs) auto

  1541

  1542 lemma map_concat: "map f (concat xs) = concat (map (map f) xs)"

  1543 by (induct xs) auto

  1544

  1545 lemma filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"

  1546 by (induct xs) auto

  1547

  1548 lemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"

  1549 by (induct xs) auto

  1550

  1551 lemma concat_eq_concat_iff: "\<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> length xs = length ys ==> (concat xs = concat ys) = (xs = ys)"

  1552 proof (induct xs arbitrary: ys)

  1553   case (Cons x xs ys)

  1554   thus ?case by (cases ys) auto

  1555 qed (auto)

  1556

  1557 lemma concat_injective: "concat xs = concat ys ==> length xs = length ys ==> \<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> xs = ys"

  1558 by (simp add: concat_eq_concat_iff)

  1559

  1560

  1561 subsubsection {* @{const nth} *}

  1562

  1563 lemma nth_Cons_0 [simp, code]: "(x # xs)!0 = x"

  1564 by auto

  1565

  1566 lemma nth_Cons_Suc [simp, code]: "(x # xs)!(Suc n) = xs!n"

  1567 by auto

  1568

  1569 declare nth.simps [simp del]

  1570

  1571 lemma nth_Cons_pos[simp]: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"

  1572 by(auto simp: Nat.gr0_conv_Suc)

  1573

  1574 lemma nth_append:

  1575   "(xs @ ys)!n = (if n < length xs then xs!n else ys!(n - length xs))"

  1576 apply (induct xs arbitrary: n, simp)

  1577 apply (case_tac n, auto)

  1578 done

  1579

  1580 lemma nth_append_length [simp]: "(xs @ x # ys) ! length xs = x"

  1581 by (induct xs) auto

  1582

  1583 lemma nth_append_length_plus[simp]: "(xs @ ys) ! (length xs + n) = ys ! n"

  1584 by (induct xs) auto

  1585

  1586 lemma nth_map [simp]: "n < length xs ==> (map f xs)!n = f(xs!n)"

  1587 apply (induct xs arbitrary: n, simp)

  1588 apply (case_tac n, auto)

  1589 done

  1590

  1591 lemma nth_tl:

  1592   assumes "n < length (tl x)" shows "tl x ! n = x ! Suc n"

  1593 using assms by (induct x) auto

  1594

  1595 lemma hd_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd xs = xs!0"

  1596 by(cases xs) simp_all

  1597

  1598

  1599 lemma list_eq_iff_nth_eq:

  1600  "(xs = ys) = (length xs = length ys \<and> (ALL i<length xs. xs!i = ys!i))"

  1601 apply(induct xs arbitrary: ys)

  1602  apply force

  1603 apply(case_tac ys)

  1604  apply simp

  1605 apply(simp add:nth_Cons split:nat.split)apply blast

  1606 done

  1607

  1608 lemma set_conv_nth: "set xs = {xs!i | i. i < length xs}"

  1609 apply (induct xs, simp, simp)

  1610 apply safe

  1611 apply (metis nat_case_0 nth.simps zero_less_Suc)

  1612 apply (metis less_Suc_eq_0_disj nth_Cons_Suc)

  1613 apply (case_tac i, simp)

  1614 apply (metis diff_Suc_Suc nat_case_Suc nth.simps zero_less_diff)

  1615 done

  1616

  1617 lemma in_set_conv_nth: "(x \<in> set xs) = (\<exists>i < length xs. xs!i = x)"

  1618 by(auto simp:set_conv_nth)

  1619

  1620 lemma nth_equal_first_eq:

  1621   assumes "x \<notin> set xs"

  1622   assumes "n \<le> length xs"

  1623   shows "(x # xs) ! n = x \<longleftrightarrow> n = 0" (is "?lhs \<longleftrightarrow> ?rhs")

  1624 proof

  1625   assume ?lhs

  1626   show ?rhs

  1627   proof (rule ccontr)

  1628     assume "n \<noteq> 0"

  1629     then have "n > 0" by simp

  1630     with ?lhs have "xs ! (n - 1) = x" by simp

  1631     moreover from n > 0 n \<le> length xs have "n - 1 < length xs" by simp

  1632     ultimately have "\<exists>i<length xs. xs ! i = x" by auto

  1633     with x \<notin> set xs in_set_conv_nth [of x xs] show False by simp

  1634   qed

  1635 next

  1636   assume ?rhs then show ?lhs by simp

  1637 qed

  1638

  1639 lemma nth_non_equal_first_eq:

  1640   assumes "x \<noteq> y"

  1641   shows "(x # xs) ! n = y \<longleftrightarrow> xs ! (n - 1) = y \<and> n > 0" (is "?lhs \<longleftrightarrow> ?rhs")

  1642 proof

  1643   assume "?lhs" with assms have "n > 0" by (cases n) simp_all

  1644   with ?lhs show ?rhs by simp

  1645 next

  1646   assume "?rhs" then show "?lhs" by simp

  1647 qed

  1648

  1649 lemma list_ball_nth: "[| n < length xs; !x : set xs. P x|] ==> P(xs!n)"

  1650 by (auto simp add: set_conv_nth)

  1651

  1652 lemma nth_mem [simp]: "n < length xs ==> xs!n : set xs"

  1653 by (auto simp add: set_conv_nth)

  1654

  1655 lemma all_nth_imp_all_set:

  1656 "[| !i < length xs. P(xs!i); x : set xs|] ==> P x"

  1657 by (auto simp add: set_conv_nth)

  1658

  1659 lemma all_set_conv_all_nth:

  1660 "(\<forall>x \<in> set xs. P x) = (\<forall>i. i < length xs --> P (xs ! i))"

  1661 by (auto simp add: set_conv_nth)

  1662

  1663 lemma rev_nth:

  1664   "n < size xs \<Longrightarrow> rev xs ! n = xs ! (length xs - Suc n)"

  1665 proof (induct xs arbitrary: n)

  1666   case Nil thus ?case by simp

  1667 next

  1668   case (Cons x xs)

  1669   hence n: "n < Suc (length xs)" by simp

  1670   moreover

  1671   { assume "n < length xs"

  1672     with n obtain n' where "length xs - n = Suc n'"

  1673       by (cases "length xs - n", auto)

  1674     moreover

  1675     then have "length xs - Suc n = n'" by simp

  1676     ultimately

  1677     have "xs ! (length xs - Suc n) = (x # xs) ! (length xs - n)" by simp

  1678   }

  1679   ultimately

  1680   show ?case by (clarsimp simp add: Cons nth_append)

  1681 qed

  1682

  1683 lemma Skolem_list_nth:

  1684   "(ALL i<k. EX x. P i x) = (EX xs. size xs = k & (ALL i<k. P i (xs!i)))"

  1685   (is "_ = (EX xs. ?P k xs)")

  1686 proof(induct k)

  1687   case 0 show ?case by simp

  1688 next

  1689   case (Suc k)

  1690   show ?case (is "?L = ?R" is "_ = (EX xs. ?P' xs)")

  1691   proof

  1692     assume "?R" thus "?L" using Suc by auto

  1693   next

  1694     assume "?L"

  1695     with Suc obtain x xs where "?P k xs & P k x" by (metis less_Suc_eq)

  1696     hence "?P'(xs@[x])" by(simp add:nth_append less_Suc_eq)

  1697     thus "?R" ..

  1698   qed

  1699 qed

  1700

  1701

  1702 subsubsection {* @{const list_update} *}

  1703

  1704 lemma length_list_update [simp]: "length(xs[i:=x]) = length xs"

  1705 by (induct xs arbitrary: i) (auto split: nat.split)

  1706

  1707 lemma nth_list_update:

  1708 "i < length xs==> (xs[i:=x])!j = (if i = j then x else xs!j)"

  1709 by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)

  1710

  1711 lemma nth_list_update_eq [simp]: "i < length xs ==> (xs[i:=x])!i = x"

  1712 by (simp add: nth_list_update)

  1713

  1714 lemma nth_list_update_neq [simp]: "i \<noteq> j ==> xs[i:=x]!j = xs!j"

  1715 by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)

  1716

  1717 lemma list_update_id[simp]: "xs[i := xs!i] = xs"

  1718 by (induct xs arbitrary: i) (simp_all split:nat.splits)

  1719

  1720 lemma list_update_beyond[simp]: "length xs \<le> i \<Longrightarrow> xs[i:=x] = xs"

  1721 apply (induct xs arbitrary: i)

  1722  apply simp

  1723 apply (case_tac i)

  1724 apply simp_all

  1725 done

  1726

  1727 lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"

  1728 by(metis length_0_conv length_list_update)

  1729

  1730 lemma list_update_same_conv:

  1731 "i < length xs ==> (xs[i := x] = xs) = (xs!i = x)"

  1732 by (induct xs arbitrary: i) (auto split: nat.split)

  1733

  1734 lemma list_update_append1:

  1735  "i < size xs \<Longrightarrow> (xs @ ys)[i:=x] = xs[i:=x] @ ys"

  1736 apply (induct xs arbitrary: i, simp)

  1737 apply(simp split:nat.split)

  1738 done

  1739

  1740 lemma list_update_append:

  1741   "(xs @ ys) [n:= x] =

  1742   (if n < length xs then xs[n:= x] @ ys else xs @ (ys [n-length xs:= x]))"

  1743 by (induct xs arbitrary: n) (auto split:nat.splits)

  1744

  1745 lemma list_update_length [simp]:

  1746  "(xs @ x # ys)[length xs := y] = (xs @ y # ys)"

  1747 by (induct xs, auto)

  1748

  1749 lemma map_update: "map f (xs[k:= y]) = (map f xs)[k := f y]"

  1750 by(induct xs arbitrary: k)(auto split:nat.splits)

  1751

  1752 lemma rev_update:

  1753   "k < length xs \<Longrightarrow> rev (xs[k:= y]) = (rev xs)[length xs - k - 1 := y]"

  1754 by (induct xs arbitrary: k) (auto simp: list_update_append split:nat.splits)

  1755

  1756 lemma update_zip:

  1757   "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"

  1758 by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)

  1759

  1760 lemma set_update_subset_insert: "set(xs[i:=x]) <= insert x (set xs)"

  1761 by (induct xs arbitrary: i) (auto split: nat.split)

  1762

  1763 lemma set_update_subsetI: "[| set xs <= A; x:A |] ==> set(xs[i := x]) <= A"

  1764 by (blast dest!: set_update_subset_insert [THEN subsetD])

  1765

  1766 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"

  1767 by (induct xs arbitrary: n) (auto split:nat.splits)

  1768

  1769 lemma list_update_overwrite[simp]:

  1770   "xs [i := x, i := y] = xs [i := y]"

  1771 apply (induct xs arbitrary: i) apply simp

  1772 apply (case_tac i, simp_all)

  1773 done

  1774

  1775 lemma list_update_swap:

  1776   "i \<noteq> i' \<Longrightarrow> xs [i := x, i' := x'] = xs [i' := x', i := x]"

  1777 apply (induct xs arbitrary: i i')

  1778 apply simp

  1779 apply (case_tac i, case_tac i')

  1780 apply auto

  1781 apply (case_tac i')

  1782 apply auto

  1783 done

  1784

  1785 lemma list_update_code [code]:

  1786   "[][i := y] = []"

  1787   "(x # xs)[0 := y] = y # xs"

  1788   "(x # xs)[Suc i := y] = x # xs[i := y]"

  1789   by simp_all

  1790

  1791

  1792 subsubsection {* @{const last} and @{const butlast} *}

  1793

  1794 lemma last_snoc [simp]: "last (xs @ [x]) = x"

  1795 by (induct xs) auto

  1796

  1797 lemma butlast_snoc [simp]: "butlast (xs @ [x]) = xs"

  1798 by (induct xs) auto

  1799

  1800 lemma last_ConsL: "xs = [] \<Longrightarrow> last(x#xs) = x"

  1801   by simp

  1802

  1803 lemma last_ConsR: "xs \<noteq> [] \<Longrightarrow> last(x#xs) = last xs"

  1804   by simp

  1805

  1806 lemma last_append: "last(xs @ ys) = (if ys = [] then last xs else last ys)"

  1807 by (induct xs) (auto)

  1808

  1809 lemma last_appendL[simp]: "ys = [] \<Longrightarrow> last(xs @ ys) = last xs"

  1810 by(simp add:last_append)

  1811

  1812 lemma last_appendR[simp]: "ys \<noteq> [] \<Longrightarrow> last(xs @ ys) = last ys"

  1813 by(simp add:last_append)

  1814

  1815 lemma last_tl: "xs = [] \<or> tl xs \<noteq> [] \<Longrightarrow>last (tl xs) = last xs"

  1816 by (induct xs) simp_all

  1817

  1818 lemma butlast_tl: "butlast (tl xs) = tl (butlast xs)"

  1819 by (induct xs) simp_all

  1820

  1821 lemma hd_rev: "xs \<noteq> [] \<Longrightarrow> hd(rev xs) = last xs"

  1822 by(rule rev_exhaust[of xs]) simp_all

  1823

  1824 lemma last_rev: "xs \<noteq> [] \<Longrightarrow> last(rev xs) = hd xs"

  1825 by(cases xs) simp_all

  1826

  1827 lemma last_in_set[simp]: "as \<noteq> [] \<Longrightarrow> last as \<in> set as"

  1828 by (induct as) auto

  1829

  1830 lemma length_butlast [simp]: "length (butlast xs) = length xs - 1"

  1831 by (induct xs rule: rev_induct) auto

  1832

  1833 lemma butlast_append:

  1834   "butlast (xs @ ys) = (if ys = [] then butlast xs else xs @ butlast ys)"

  1835 by (induct xs arbitrary: ys) auto

  1836

  1837 lemma append_butlast_last_id [simp]:

  1838 "xs \<noteq> [] ==> butlast xs @ [last xs] = xs"

  1839 by (induct xs) auto

  1840

  1841 lemma in_set_butlastD: "x : set (butlast xs) ==> x : set xs"

  1842 by (induct xs) (auto split: split_if_asm)

  1843

  1844 lemma in_set_butlast_appendI:

  1845 "x : set (butlast xs) | x : set (butlast ys) ==> x : set (butlast (xs @ ys))"

  1846 by (auto dest: in_set_butlastD simp add: butlast_append)

  1847

  1848 lemma last_drop[simp]: "n < length xs \<Longrightarrow> last (drop n xs) = last xs"

  1849 apply (induct xs arbitrary: n)

  1850  apply simp

  1851 apply (auto split:nat.split)

  1852 done

  1853

  1854 lemma nth_butlast:

  1855   assumes "n < length (butlast xs)" shows "butlast xs ! n = xs ! n"

  1856 proof (cases xs)

  1857   case (Cons y ys)

  1858   moreover from assms have "butlast xs ! n = (butlast xs @ [last xs]) ! n"

  1859     by (simp add: nth_append)

  1860   ultimately show ?thesis using append_butlast_last_id by simp

  1861 qed simp

  1862

  1863 lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - 1)"

  1864 by(induct xs)(auto simp:neq_Nil_conv)

  1865

  1866 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"

  1867 by (induct xs, simp, case_tac xs, simp_all)

  1868

  1869 lemma last_list_update:

  1870   "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"

  1871 by (auto simp: last_conv_nth)

  1872

  1873 lemma butlast_list_update:

  1874   "butlast(xs[k:=x]) =

  1875  (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"

  1876 apply(cases xs rule:rev_cases)

  1877 apply simp

  1878 apply(simp add:list_update_append split:nat.splits)

  1879 done

  1880

  1881 lemma last_map:

  1882   "xs \<noteq> [] \<Longrightarrow> last (map f xs) = f (last xs)"

  1883   by (cases xs rule: rev_cases) simp_all

  1884

  1885 lemma map_butlast:

  1886   "map f (butlast xs) = butlast (map f xs)"

  1887   by (induct xs) simp_all

  1888

  1889 lemma snoc_eq_iff_butlast:

  1890   "xs @ [x] = ys \<longleftrightarrow> (ys \<noteq> [] & butlast ys = xs & last ys = x)"

  1891 by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

  1892

  1893

  1894 subsubsection {* @{const take} and @{const drop} *}

  1895

  1896 lemma take_0 [simp]: "take 0 xs = []"

  1897 by (induct xs) auto

  1898

  1899 lemma drop_0 [simp]: "drop 0 xs = xs"

  1900 by (induct xs) auto

  1901

  1902 lemma take_Suc_Cons [simp]: "take (Suc n) (x # xs) = x # take n xs"

  1903 by simp

  1904

  1905 lemma drop_Suc_Cons [simp]: "drop (Suc n) (x # xs) = drop n xs"

  1906 by simp

  1907

  1908 declare take_Cons [simp del] and drop_Cons [simp del]

  1909

  1910 lemma take_1_Cons [simp]: "take 1 (x # xs) = [x]"

  1911   unfolding One_nat_def by simp

  1912

  1913 lemma drop_1_Cons [simp]: "drop 1 (x # xs) = xs"

  1914   unfolding One_nat_def by simp

  1915

  1916 lemma take_Suc: "xs ~= [] ==> take (Suc n) xs = hd xs # take n (tl xs)"

  1917 by(clarsimp simp add:neq_Nil_conv)

  1918

  1919 lemma drop_Suc: "drop (Suc n) xs = drop n (tl xs)"

  1920 by(cases xs, simp_all)

  1921

  1922 lemma take_tl: "take n (tl xs) = tl (take (Suc n) xs)"

  1923 by (induct xs arbitrary: n) simp_all

  1924

  1925 lemma drop_tl: "drop n (tl xs) = tl(drop n xs)"

  1926 by(induct xs arbitrary: n, simp_all add:drop_Cons drop_Suc split:nat.split)

  1927

  1928 lemma tl_take: "tl (take n xs) = take (n - 1) (tl xs)"

  1929 by (cases n, simp, cases xs, auto)

  1930

  1931 lemma tl_drop: "tl (drop n xs) = drop n (tl xs)"

  1932 by (simp only: drop_tl)

  1933

  1934 lemma nth_via_drop: "drop n xs = y#ys \<Longrightarrow> xs!n = y"

  1935 apply (induct xs arbitrary: n, simp)

  1936 apply(simp add:drop_Cons nth_Cons split:nat.splits)

  1937 done

  1938

  1939 lemma take_Suc_conv_app_nth:

  1940   "i < length xs \<Longrightarrow> take (Suc i) xs = take i xs @ [xs!i]"

  1941 apply (induct xs arbitrary: i, simp)

  1942 apply (case_tac i, auto)

  1943 done

  1944

  1945 lemma drop_Suc_conv_tl:

  1946   "i < length xs \<Longrightarrow> (xs!i) # (drop (Suc i) xs) = drop i xs"

  1947 apply (induct xs arbitrary: i, simp)

  1948 apply (case_tac i, auto)

  1949 done

  1950

  1951 lemma length_take [simp]: "length (take n xs) = min (length xs) n"

  1952 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1953

  1954 lemma length_drop [simp]: "length (drop n xs) = (length xs - n)"

  1955 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1956

  1957 lemma take_all [simp]: "length xs <= n ==> take n xs = xs"

  1958 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1959

  1960 lemma drop_all [simp]: "length xs <= n ==> drop n xs = []"

  1961 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1962

  1963 lemma take_append [simp]:

  1964   "take n (xs @ ys) = (take n xs @ take (n - length xs) ys)"

  1965 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1966

  1967 lemma drop_append [simp]:

  1968   "drop n (xs @ ys) = drop n xs @ drop (n - length xs) ys"

  1969 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1970

  1971 lemma take_take [simp]: "take n (take m xs) = take (min n m) xs"

  1972 apply (induct m arbitrary: xs n, auto)

  1973 apply (case_tac xs, auto)

  1974 apply (case_tac n, auto)

  1975 done

  1976

  1977 lemma drop_drop [simp]: "drop n (drop m xs) = drop (n + m) xs"

  1978 apply (induct m arbitrary: xs, auto)

  1979 apply (case_tac xs, auto)

  1980 done

  1981

  1982 lemma take_drop: "take n (drop m xs) = drop m (take (n + m) xs)"

  1983 apply (induct m arbitrary: xs n, auto)

  1984 apply (case_tac xs, auto)

  1985 done

  1986

  1987 lemma drop_take: "drop n (take m xs) = take (m-n) (drop n xs)"

  1988 apply(induct xs arbitrary: m n)

  1989  apply simp

  1990 apply(simp add: take_Cons drop_Cons split:nat.split)

  1991 done

  1992

  1993 lemma append_take_drop_id [simp]: "take n xs @ drop n xs = xs"

  1994 apply (induct n arbitrary: xs, auto)

  1995 apply (case_tac xs, auto)

  1996 done

  1997

  1998 lemma take_eq_Nil[simp]: "(take n xs = []) = (n = 0 \<or> xs = [])"

  1999 apply(induct xs arbitrary: n)

  2000  apply simp

  2001 apply(simp add:take_Cons split:nat.split)

  2002 done

  2003

  2004 lemma drop_eq_Nil[simp]: "(drop n xs = []) = (length xs <= n)"

  2005 apply(induct xs arbitrary: n)

  2006 apply simp

  2007 apply(simp add:drop_Cons split:nat.split)

  2008 done

  2009

  2010 lemma take_map: "take n (map f xs) = map f (take n xs)"

  2011 apply (induct n arbitrary: xs, auto)

  2012 apply (case_tac xs, auto)

  2013 done

  2014

  2015 lemma drop_map: "drop n (map f xs) = map f (drop n xs)"

  2016 apply (induct n arbitrary: xs, auto)

  2017 apply (case_tac xs, auto)

  2018 done

  2019

  2020 lemma rev_take: "rev (take i xs) = drop (length xs - i) (rev xs)"

  2021 apply (induct xs arbitrary: i, auto)

  2022 apply (case_tac i, auto)

  2023 done

  2024

  2025 lemma rev_drop: "rev (drop i xs) = take (length xs - i) (rev xs)"

  2026 apply (induct xs arbitrary: i, auto)

  2027 apply (case_tac i, auto)

  2028 done

  2029

  2030 lemma nth_take [simp]: "i < n ==> (take n xs)!i = xs!i"

  2031 apply (induct xs arbitrary: i n, auto)

  2032 apply (case_tac n, blast)

  2033 apply (case_tac i, auto)

  2034 done

  2035

  2036 lemma nth_drop [simp]:

  2037   "n + i <= length xs ==> (drop n xs)!i = xs!(n + i)"

  2038 apply (induct n arbitrary: xs i, auto)

  2039 apply (case_tac xs, auto)

  2040 done

  2041

  2042 lemma butlast_take:

  2043   "n <= length xs ==> butlast (take n xs) = take (n - 1) xs"

  2044 by (simp add: butlast_conv_take min_max.inf_absorb1 min_max.inf_absorb2)

  2045

  2046 lemma butlast_drop: "butlast (drop n xs) = drop n (butlast xs)"

  2047 by (simp add: butlast_conv_take drop_take add_ac)

  2048

  2049 lemma take_butlast: "n < length xs ==> take n (butlast xs) = take n xs"

  2050 by (simp add: butlast_conv_take min_max.inf_absorb1)

  2051

  2052 lemma drop_butlast: "drop n (butlast xs) = butlast (drop n xs)"

  2053 by (simp add: butlast_conv_take drop_take add_ac)

  2054

  2055 lemma hd_drop_conv_nth: "n < length xs \<Longrightarrow> hd(drop n xs) = xs!n"

  2056 by(simp add: hd_conv_nth)

  2057

  2058 lemma set_take_subset_set_take:

  2059   "m <= n \<Longrightarrow> set(take m xs) <= set(take n xs)"

  2060 apply (induct xs arbitrary: m n)

  2061 apply simp

  2062 apply (case_tac n)

  2063 apply (auto simp: take_Cons)

  2064 done

  2065

  2066 lemma set_take_subset: "set(take n xs) \<subseteq> set xs"

  2067 by(induct xs arbitrary: n)(auto simp:take_Cons split:nat.split)

  2068

  2069 lemma set_drop_subset: "set(drop n xs) \<subseteq> set xs"

  2070 by(induct xs arbitrary: n)(auto simp:drop_Cons split:nat.split)

  2071

  2072 lemma set_drop_subset_set_drop:

  2073   "m >= n \<Longrightarrow> set(drop m xs) <= set(drop n xs)"

  2074 apply(induct xs arbitrary: m n)

  2075 apply(auto simp:drop_Cons split:nat.split)

  2076 apply (metis set_drop_subset subset_iff)

  2077 done

  2078

  2079 lemma in_set_takeD: "x : set(take n xs) \<Longrightarrow> x : set xs"

  2080 using set_take_subset by fast

  2081

  2082 lemma in_set_dropD: "x : set(drop n xs) \<Longrightarrow> x : set xs"

  2083 using set_drop_subset by fast

  2084

  2085 lemma append_eq_conv_conj:

  2086   "(xs @ ys = zs) = (xs = take (length xs) zs \<and> ys = drop (length xs) zs)"

  2087 apply (induct xs arbitrary: zs, simp, clarsimp)

  2088 apply (case_tac zs, auto)

  2089 done

  2090

  2091 lemma take_add:

  2092   "take (i+j) xs = take i xs @ take j (drop i xs)"

  2093 apply (induct xs arbitrary: i, auto)

  2094 apply (case_tac i, simp_all)

  2095 done

  2096

  2097 lemma append_eq_append_conv_if:

  2098  "(xs\<^isub>1 @ xs\<^isub>2 = ys\<^isub>1 @ ys\<^isub>2) =

  2099   (if size xs\<^isub>1 \<le> size ys\<^isub>1

  2100    then xs\<^isub>1 = take (size xs\<^isub>1) ys\<^isub>1 \<and> xs\<^isub>2 = drop (size xs\<^isub>1) ys\<^isub>1 @ ys\<^isub>2

  2101    else take (size ys\<^isub>1) xs\<^isub>1 = ys\<^isub>1 \<and> drop (size ys\<^isub>1) xs\<^isub>1 @ xs\<^isub>2 = ys\<^isub>2)"

  2102 apply(induct xs\<^isub>1 arbitrary: ys\<^isub>1)

  2103  apply simp

  2104 apply(case_tac ys\<^isub>1)

  2105 apply simp_all

  2106 done

  2107

  2108 lemma take_hd_drop:

  2109   "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (Suc n) xs"

  2110 apply(induct xs arbitrary: n)

  2111 apply simp

  2112 apply(simp add:drop_Cons split:nat.split)

  2113 done

  2114

  2115 lemma id_take_nth_drop:

  2116  "i < length xs \<Longrightarrow> xs = take i xs @ xs!i # drop (Suc i) xs"

  2117 proof -

  2118   assume si: "i < length xs"

  2119   hence "xs = take (Suc i) xs @ drop (Suc i) xs" by auto

  2120   moreover

  2121   from si have "take (Suc i) xs = take i xs @ [xs!i]"

  2122     apply (rule_tac take_Suc_conv_app_nth) by arith

  2123   ultimately show ?thesis by auto

  2124 qed

  2125

  2126 lemma upd_conv_take_nth_drop:

  2127  "i < length xs \<Longrightarrow> xs[i:=a] = take i xs @ a # drop (Suc i) xs"

  2128 proof -

  2129   assume i: "i < length xs"

  2130   have "xs[i:=a] = (take i xs @ xs!i # drop (Suc i) xs)[i:=a]"

  2131     by(rule arg_cong[OF id_take_nth_drop[OF i]])

  2132   also have "\<dots> = take i xs @ a # drop (Suc i) xs"

  2133     using i by (simp add: list_update_append)

  2134   finally show ?thesis .

  2135 qed

  2136

  2137 lemma nth_drop':

  2138   "i < length xs \<Longrightarrow> xs ! i # drop (Suc i) xs = drop i xs"

  2139 apply (induct i arbitrary: xs)

  2140 apply (simp add: neq_Nil_conv)

  2141 apply (erule exE)+

  2142 apply simp

  2143 apply (case_tac xs)

  2144 apply simp_all

  2145 done

  2146

  2147

  2148 subsubsection {* @{const takeWhile} and @{const dropWhile} *}

  2149

  2150 lemma length_takeWhile_le: "length (takeWhile P xs) \<le> length xs"

  2151   by (induct xs) auto

  2152

  2153 lemma takeWhile_dropWhile_id [simp]: "takeWhile P xs @ dropWhile P xs = xs"

  2154 by (induct xs) auto

  2155

  2156 lemma takeWhile_append1 [simp]:

  2157 "[| x:set xs; ~P(x)|] ==> takeWhile P (xs @ ys) = takeWhile P xs"

  2158 by (induct xs) auto

  2159

  2160 lemma takeWhile_append2 [simp]:

  2161 "(!!x. x : set xs ==> P x) ==> takeWhile P (xs @ ys) = xs @ takeWhile P ys"

  2162 by (induct xs) auto

  2163

  2164 lemma takeWhile_tail: "\<not> P x ==> takeWhile P (xs @ (x#l)) = takeWhile P xs"

  2165 by (induct xs) auto

  2166

  2167 lemma takeWhile_nth: "j < length (takeWhile P xs) \<Longrightarrow> takeWhile P xs ! j = xs ! j"

  2168 apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by auto

  2169

  2170 lemma dropWhile_nth: "j < length (dropWhile P xs) \<Longrightarrow> dropWhile P xs ! j = xs ! (j + length (takeWhile P xs))"

  2171 apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by auto

  2172

  2173 lemma length_dropWhile_le: "length (dropWhile P xs) \<le> length xs"

  2174 by (induct xs) auto

  2175

  2176 lemma dropWhile_append1 [simp]:

  2177 "[| x : set xs; ~P(x)|] ==> dropWhile P (xs @ ys) = (dropWhile P xs)@ys"

  2178 by (induct xs) auto

  2179

  2180 lemma dropWhile_append2 [simp]:

  2181 "(!!x. x:set xs ==> P(x)) ==> dropWhile P (xs @ ys) = dropWhile P ys"

  2182 by (induct xs) auto

  2183

  2184 lemma dropWhile_append3:

  2185   "\<not> P y \<Longrightarrow>dropWhile P (xs @ y # ys) = dropWhile P xs @ y # ys"

  2186 by (induct xs) auto

  2187

  2188 lemma dropWhile_last:

  2189   "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> last (dropWhile P xs) = last xs"

  2190 by (auto simp add: dropWhile_append3 in_set_conv_decomp)

  2191

  2192 lemma set_dropWhileD: "x \<in> set (dropWhile P xs) \<Longrightarrow> x \<in> set xs"

  2193 by (induct xs) (auto split: split_if_asm)

  2194

  2195 lemma set_takeWhileD: "x : set (takeWhile P xs) ==> x : set xs \<and> P x"

  2196 by (induct xs) (auto split: split_if_asm)

  2197

  2198 lemma takeWhile_eq_all_conv[simp]:

  2199  "(takeWhile P xs = xs) = (\<forall>x \<in> set xs. P x)"

  2200 by(induct xs, auto)

  2201

  2202 lemma dropWhile_eq_Nil_conv[simp]:

  2203  "(dropWhile P xs = []) = (\<forall>x \<in> set xs. P x)"

  2204 by(induct xs, auto)

  2205

  2206 lemma dropWhile_eq_Cons_conv:

  2207  "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys & \<not> P y)"

  2208 by(induct xs, auto)

  2209

  2210 lemma distinct_takeWhile[simp]: "distinct xs ==> distinct (takeWhile P xs)"

  2211 by (induct xs) (auto dest: set_takeWhileD)

  2212

  2213 lemma distinct_dropWhile[simp]: "distinct xs ==> distinct (dropWhile P xs)"

  2214 by (induct xs) auto

  2215

  2216 lemma takeWhile_map: "takeWhile P (map f xs) = map f (takeWhile (P \<circ> f) xs)"

  2217 by (induct xs) auto

  2218

  2219 lemma dropWhile_map: "dropWhile P (map f xs) = map f (dropWhile (P \<circ> f) xs)"

  2220 by (induct xs) auto

  2221

  2222 lemma takeWhile_eq_take: "takeWhile P xs = take (length (takeWhile P xs)) xs"

  2223 by (induct xs) auto

  2224

  2225 lemma dropWhile_eq_drop: "dropWhile P xs = drop (length (takeWhile P xs)) xs"

  2226 by (induct xs) auto

  2227

  2228 lemma hd_dropWhile:

  2229   "dropWhile P xs \<noteq> [] \<Longrightarrow> \<not> P (hd (dropWhile P xs))"

  2230 using assms by (induct xs) auto

  2231

  2232 lemma takeWhile_eq_filter:

  2233   assumes "\<And> x. x \<in> set (dropWhile P xs) \<Longrightarrow> \<not> P x"

  2234   shows "takeWhile P xs = filter P xs"

  2235 proof -

  2236   have A: "filter P xs = filter P (takeWhile P xs @ dropWhile P xs)"

  2237     by simp

  2238   have B: "filter P (dropWhile P xs) = []"

  2239     unfolding filter_empty_conv using assms by blast

  2240   have "filter P xs = takeWhile P xs"

  2241     unfolding A filter_append B

  2242     by (auto simp add: filter_id_conv dest: set_takeWhileD)

  2243   thus ?thesis ..

  2244 qed

  2245

  2246 lemma takeWhile_eq_take_P_nth:

  2247   "\<lbrakk> \<And> i. \<lbrakk> i < n ; i < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) ; n < length xs \<Longrightarrow> \<not> P (xs ! n) \<rbrakk> \<Longrightarrow>

  2248   takeWhile P xs = take n xs"

  2249 proof (induct xs arbitrary: n)

  2250   case (Cons x xs)

  2251   thus ?case

  2252   proof (cases n)

  2253     case (Suc n') note this[simp]

  2254     have "P x" using Cons.prems(1)[of 0] by simp

  2255     moreover have "takeWhile P xs = take n' xs"

  2256     proof (rule Cons.hyps)

  2257       case goal1 thus "P (xs ! i)" using Cons.prems(1)[of "Suc i"] by simp

  2258     next case goal2 thus ?case using Cons by auto

  2259     qed

  2260     ultimately show ?thesis by simp

  2261    qed simp

  2262 qed simp

  2263

  2264 lemma nth_length_takeWhile:

  2265   "length (takeWhile P xs) < length xs \<Longrightarrow> \<not> P (xs ! length (takeWhile P xs))"

  2266 by (induct xs) auto

  2267

  2268 lemma length_takeWhile_less_P_nth:

  2269   assumes all: "\<And> i. i < j \<Longrightarrow> P (xs ! i)" and "j \<le> length xs"

  2270   shows "j \<le> length (takeWhile P xs)"

  2271 proof (rule classical)

  2272   assume "\<not> ?thesis"

  2273   hence "length (takeWhile P xs) < length xs" using assms by simp

  2274   thus ?thesis using all \<not> ?thesis nth_length_takeWhile[of P xs] by auto

  2275 qed

  2276

  2277 text{* The following two lemmmas could be generalized to an arbitrary

  2278 property. *}

  2279

  2280 lemma takeWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>

  2281  takeWhile (\<lambda>y. y \<noteq> x) (rev xs) = rev (tl (dropWhile (\<lambda>y. y \<noteq> x) xs))"

  2282 by(induct xs) (auto simp: takeWhile_tail[where l="[]"])

  2283

  2284 lemma dropWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>

  2285   dropWhile (\<lambda>y. y \<noteq> x) (rev xs) = x # rev (takeWhile (\<lambda>y. y \<noteq> x) xs)"

  2286 apply(induct xs)

  2287  apply simp

  2288 apply auto

  2289 apply(subst dropWhile_append2)

  2290 apply auto

  2291 done

  2292

  2293 lemma takeWhile_not_last:

  2294  "distinct xs \<Longrightarrow> takeWhile (\<lambda>y. y \<noteq> last xs) xs = butlast xs"

  2295 apply(induct xs)

  2296  apply simp

  2297 apply(case_tac xs)

  2298 apply(auto)

  2299 done

  2300

  2301 lemma takeWhile_cong [fundef_cong]:

  2302   "[| l = k; !!x. x : set l ==> P x = Q x |]

  2303   ==> takeWhile P l = takeWhile Q k"

  2304 by (induct k arbitrary: l) (simp_all)

  2305

  2306 lemma dropWhile_cong [fundef_cong]:

  2307   "[| l = k; !!x. x : set l ==> P x = Q x |]

  2308   ==> dropWhile P l = dropWhile Q k"

  2309 by (induct k arbitrary: l, simp_all)

  2310

  2311

  2312 subsubsection {* @{const zip} *}

  2313

  2314 lemma zip_Nil [simp]: "zip [] ys = []"

  2315 by (induct ys) auto

  2316

  2317 lemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"

  2318 by simp

  2319

  2320 declare zip_Cons [simp del]

  2321

  2322 lemma [code]:

  2323   "zip [] ys = []"

  2324   "zip xs [] = []"

  2325   "zip (x # xs) (y # ys) = (x, y) # zip xs ys"

  2326   by (fact zip_Nil zip.simps(1) zip_Cons_Cons)+

  2327

  2328 lemma zip_Cons1:

  2329  "zip (x#xs) ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x,y)#zip xs ys)"

  2330 by(auto split:list.split)

  2331

  2332 lemma length_zip [simp]:

  2333 "length (zip xs ys) = min (length xs) (length ys)"

  2334 by (induct xs ys rule:list_induct2') auto

  2335

  2336 lemma zip_obtain_same_length:

  2337   assumes "\<And>zs ws n. length zs = length ws \<Longrightarrow> n = min (length xs) (length ys)

  2338     \<Longrightarrow> zs = take n xs \<Longrightarrow> ws = take n ys \<Longrightarrow> P (zip zs ws)"

  2339   shows "P (zip xs ys)"

  2340 proof -

  2341   let ?n = "min (length xs) (length ys)"

  2342   have "P (zip (take ?n xs) (take ?n ys))"

  2343     by (rule assms) simp_all

  2344   moreover have "zip xs ys = zip (take ?n xs) (take ?n ys)"

  2345   proof (induct xs arbitrary: ys)

  2346     case Nil then show ?case by simp

  2347   next

  2348     case (Cons x xs) then show ?case by (cases ys) simp_all

  2349   qed

  2350   ultimately show ?thesis by simp

  2351 qed

  2352

  2353 lemma zip_append1:

  2354 "zip (xs @ ys) zs =

  2355 zip xs (take (length xs) zs) @ zip ys (drop (length xs) zs)"

  2356 by (induct xs zs rule:list_induct2') auto

  2357

  2358 lemma zip_append2:

  2359 "zip xs (ys @ zs) =

  2360 zip (take (length ys) xs) ys @ zip (drop (length ys) xs) zs"

  2361 by (induct xs ys rule:list_induct2') auto

  2362

  2363 lemma zip_append [simp]:

  2364  "[| length xs = length us |] ==>

  2365 zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"

  2366 by (simp add: zip_append1)

  2367

  2368 lemma zip_rev:

  2369 "length xs = length ys ==> zip (rev xs) (rev ys) = rev (zip xs ys)"

  2370 by (induct rule:list_induct2, simp_all)

  2371

  2372 lemma zip_map_map:

  2373   "zip (map f xs) (map g ys) = map (\<lambda> (x, y). (f x, g y)) (zip xs ys)"

  2374 proof (induct xs arbitrary: ys)

  2375   case (Cons x xs) note Cons_x_xs = Cons.hyps

  2376   show ?case

  2377   proof (cases ys)

  2378     case (Cons y ys')

  2379     show ?thesis unfolding Cons using Cons_x_xs by simp

  2380   qed simp

  2381 qed simp

  2382

  2383 lemma zip_map1:

  2384   "zip (map f xs) ys = map (\<lambda>(x, y). (f x, y)) (zip xs ys)"

  2385 using zip_map_map[of f xs "\<lambda>x. x" ys] by simp

  2386

  2387 lemma zip_map2:

  2388   "zip xs (map f ys) = map (\<lambda>(x, y). (x, f y)) (zip xs ys)"

  2389 using zip_map_map[of "\<lambda>x. x" xs f ys] by simp

  2390

  2391 lemma map_zip_map:

  2392   "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"

  2393 unfolding zip_map1 by auto

  2394

  2395 lemma map_zip_map2:

  2396   "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"

  2397 unfolding zip_map2 by auto

  2398

  2399 text{* Courtesy of Andreas Lochbihler: *}

  2400 lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"

  2401 by(induct xs) auto

  2402

  2403 lemma nth_zip [simp]:

  2404 "[| i < length xs; i < length ys|] ==> (zip xs ys)!i = (xs!i, ys!i)"

  2405 apply (induct ys arbitrary: i xs, simp)

  2406 apply (case_tac xs)

  2407  apply (simp_all add: nth.simps split: nat.split)

  2408 done

  2409

  2410 lemma set_zip:

  2411 "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"

  2412 by(simp add: set_conv_nth cong: rev_conj_cong)

  2413

  2414 lemma zip_same: "((a,b) \<in> set (zip xs xs)) = (a \<in> set xs \<and> a = b)"

  2415 by(induct xs) auto

  2416

  2417 lemma zip_update:

  2418   "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"

  2419 by(rule sym, simp add: update_zip)

  2420

  2421 lemma zip_replicate [simp]:

  2422   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"

  2423 apply (induct i arbitrary: j, auto)

  2424 apply (case_tac j, auto)

  2425 done

  2426

  2427 lemma take_zip:

  2428   "take n (zip xs ys) = zip (take n xs) (take n ys)"

  2429 apply (induct n arbitrary: xs ys)

  2430  apply simp

  2431 apply (case_tac xs, simp)

  2432 apply (case_tac ys, simp_all)

  2433 done

  2434

  2435 lemma drop_zip:

  2436   "drop n (zip xs ys) = zip (drop n xs) (drop n ys)"

  2437 apply (induct n arbitrary: xs ys)

  2438  apply simp

  2439 apply (case_tac xs, simp)

  2440 apply (case_tac ys, simp_all)

  2441 done

  2442

  2443 lemma zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P \<circ> fst) (zip xs ys)"

  2444 proof (induct xs arbitrary: ys)

  2445   case (Cons x xs) thus ?case by (cases ys) auto

  2446 qed simp

  2447

  2448 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"

  2449 proof (induct xs arbitrary: ys)

  2450   case (Cons x xs) thus ?case by (cases ys) auto

  2451 qed simp

  2452

  2453 lemma set_zip_leftD:

  2454   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"

  2455 by (induct xs ys rule:list_induct2') auto

  2456

  2457 lemma set_zip_rightD:

  2458   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"

  2459 by (induct xs ys rule:list_induct2') auto

  2460

  2461 lemma in_set_zipE:

  2462   "(x,y) : set(zip xs ys) \<Longrightarrow> (\<lbrakk> x : set xs; y : set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"

  2463 by(blast dest: set_zip_leftD set_zip_rightD)

  2464

  2465 lemma zip_map_fst_snd:

  2466   "zip (map fst zs) (map snd zs) = zs"

  2467   by (induct zs) simp_all

  2468

  2469 lemma zip_eq_conv:

  2470   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"

  2471   by (auto simp add: zip_map_fst_snd)

  2472

  2473 lemma in_set_zip:

  2474   "p \<in> set (zip xs ys) \<longleftrightarrow> (\<exists>n. xs ! n = fst p \<and> ys ! n = snd p

  2475     \<and> n < length xs \<and> n < length ys)"

  2476   by (cases p) (auto simp add: set_zip)

  2477

  2478 lemma pair_list_eqI:

  2479   assumes "map fst xs = map fst ys" and "map snd xs = map snd ys"

  2480   shows "xs = ys"

  2481 proof -

  2482   from assms(1) have "length xs = length ys" by (rule map_eq_imp_length_eq)

  2483   from this assms show ?thesis

  2484     by (induct xs ys rule: list_induct2) (simp_all add: prod_eqI)

  2485 qed

  2486

  2487

  2488 subsubsection {* @{const list_all2} *}

  2489

  2490 lemma list_all2_lengthD [intro?]:

  2491   "list_all2 P xs ys ==> length xs = length ys"

  2492 by (simp add: list_all2_def)

  2493

  2494 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"

  2495 by (simp add: list_all2_def)

  2496

  2497 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"

  2498 by (simp add: list_all2_def)

  2499

  2500 lemma list_all2_Cons [iff, code]:

  2501   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"

  2502 by (auto simp add: list_all2_def)

  2503

  2504 lemma list_all2_Cons1:

  2505 "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"

  2506 by (cases ys) auto

  2507

  2508 lemma list_all2_Cons2:

  2509 "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"

  2510 by (cases xs) auto

  2511

  2512 lemma list_all2_induct

  2513   [consumes 1, case_names Nil Cons, induct set: list_all2]:

  2514   assumes P: "list_all2 P xs ys"

  2515   assumes Nil: "R [] []"

  2516   assumes Cons: "\<And>x xs y ys.

  2517     \<lbrakk>P x y; list_all2 P xs ys; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"

  2518   shows "R xs ys"

  2519 using P

  2520 by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)

  2521

  2522 lemma list_all2_rev [iff]:

  2523 "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"

  2524 by (simp add: list_all2_def zip_rev cong: conj_cong)

  2525

  2526 lemma list_all2_rev1:

  2527 "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"

  2528 by (subst list_all2_rev [symmetric]) simp

  2529

  2530 lemma list_all2_append1:

  2531 "list_all2 P (xs @ ys) zs =

  2532 (EX us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>

  2533 list_all2 P xs us \<and> list_all2 P ys vs)"

  2534 apply (simp add: list_all2_def zip_append1)

  2535 apply (rule iffI)

  2536  apply (rule_tac x = "take (length xs) zs" in exI)

  2537  apply (rule_tac x = "drop (length xs) zs" in exI)

  2538  apply (force split: nat_diff_split simp add: min_def, clarify)

  2539 apply (simp add: ball_Un)

  2540 done

  2541

  2542 lemma list_all2_append2:

  2543 "list_all2 P xs (ys @ zs) =

  2544 (EX us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>

  2545 list_all2 P us ys \<and> list_all2 P vs zs)"

  2546 apply (simp add: list_all2_def zip_append2)

  2547 apply (rule iffI)

  2548  apply (rule_tac x = "take (length ys) xs" in exI)

  2549  apply (rule_tac x = "drop (length ys) xs" in exI)

  2550  apply (force split: nat_diff_split simp add: min_def, clarify)

  2551 apply (simp add: ball_Un)

  2552 done

  2553

  2554 lemma list_all2_append:

  2555   "length xs = length ys \<Longrightarrow>

  2556   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"

  2557 by (induct rule:list_induct2, simp_all)

  2558

  2559 lemma list_all2_appendI [intro?, trans]:

  2560   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"

  2561 by (simp add: list_all2_append list_all2_lengthD)

  2562

  2563 lemma list_all2_conv_all_nth:

  2564 "list_all2 P xs ys =

  2565 (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"

  2566 by (force simp add: list_all2_def set_zip)

  2567

  2568 lemma list_all2_trans:

  2569   assumes tr: "!!a b c. P1 a b ==> P2 b c ==> P3 a c"

  2570   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> list_all2 P3 as cs"

  2571         (is "!!bs cs. PROP ?Q as bs cs")

  2572 proof (induct as)

  2573   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"

  2574   show "!!cs. PROP ?Q (x # xs) bs cs"

  2575   proof (induct bs)

  2576     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"

  2577     show "PROP ?Q (x # xs) (y # ys) cs"

  2578       by (induct cs) (auto intro: tr I1 I2)

  2579   qed simp

  2580 qed simp

  2581

  2582 lemma list_all2_all_nthI [intro?]:

  2583   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"

  2584 by (simp add: list_all2_conv_all_nth)

  2585

  2586 lemma list_all2I:

  2587   "\<forall>x \<in> set (zip a b). split P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"

  2588 by (simp add: list_all2_def)

  2589

  2590 lemma list_all2_nthD:

  2591   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

  2592 by (simp add: list_all2_conv_all_nth)

  2593

  2594 lemma list_all2_nthD2:

  2595   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

  2596 by (frule list_all2_lengthD) (auto intro: list_all2_nthD)

  2597

  2598 lemma list_all2_map1:

  2599   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"

  2600 by (simp add: list_all2_conv_all_nth)

  2601

  2602 lemma list_all2_map2:

  2603   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"

  2604 by (auto simp add: list_all2_conv_all_nth)

  2605

  2606 lemma list_all2_refl [intro?]:

  2607   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"

  2608 by (simp add: list_all2_conv_all_nth)

  2609

  2610 lemma list_all2_update_cong:

  2611   "\<lbrakk> list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"

  2612 by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)

  2613

  2614 lemma list_all2_takeI [simp,intro?]:

  2615   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"

  2616 apply (induct xs arbitrary: n ys)

  2617  apply simp

  2618 apply (clarsimp simp add: list_all2_Cons1)

  2619 apply (case_tac n)

  2620 apply auto

  2621 done

  2622

  2623 lemma list_all2_dropI [simp,intro?]:

  2624   "list_all2 P as bs \<Longrightarrow> list_all2 P (drop n as) (drop n bs)"

  2625 apply (induct as arbitrary: n bs, simp)

  2626 apply (clarsimp simp add: list_all2_Cons1)

  2627 apply (case_tac n, simp, simp)

  2628 done

  2629

  2630 lemma list_all2_mono [intro?]:

  2631   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"

  2632 apply (induct xs arbitrary: ys, simp)

  2633 apply (case_tac ys, auto)

  2634 done

  2635

  2636 lemma list_all2_eq:

  2637   "xs = ys \<longleftrightarrow> list_all2 (op =) xs ys"

  2638 by (induct xs ys rule: list_induct2') auto

  2639

  2640 lemma list_eq_iff_zip_eq:

  2641   "xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x,y) \<in> set (zip xs ys). x = y)"

  2642 by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)

  2643

  2644

  2645 subsubsection {* @{const List.product} *}

  2646

  2647 lemma product_list_set:

  2648   "set (List.product xs ys) = set xs \<times> set ys"

  2649   by (induct xs) auto

  2650

  2651 lemma length_product [simp]:

  2652   "length (List.product xs ys) = length xs * length ys"

  2653   by (induct xs) simp_all

  2654

  2655 lemma product_nth:

  2656   assumes "n < length xs * length ys"

  2657   shows "List.product xs ys ! n = (xs ! (n div length ys), ys ! (n mod length ys))"

  2658 using assms proof (induct xs arbitrary: n)

  2659   case Nil then show ?case by simp

  2660 next

  2661   case (Cons x xs n)

  2662   then have "length ys > 0" by auto

  2663   with Cons show ?case

  2664     by (auto simp add: nth_append not_less le_mod_geq le_div_geq)

  2665 qed

  2666

  2667

  2668 subsubsection {* @{const fold} with natural argument order *}

  2669

  2670 lemma fold_simps [code]: -- {* eta-expanded variant for generated code -- enables tail-recursion optimisation in Scala *}

  2671   "fold f [] s = s"

  2672   "fold f (x # xs) s = fold f xs (f x s)"

  2673   by simp_all

  2674

  2675 lemma fold_remove1_split:

  2676   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"

  2677     and x: "x \<in> set xs"

  2678   shows "fold f xs = fold f (remove1 x xs) \<circ> f x"

  2679   using assms by (induct xs) (auto simp add: comp_assoc)

  2680

  2681 lemma fold_cong [fundef_cong]:

  2682   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)

  2683     \<Longrightarrow> fold f xs a = fold g ys b"

  2684   by (induct ys arbitrary: a b xs) simp_all

  2685

  2686 lemma fold_id:

  2687   assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"

  2688   shows "fold f xs = id"

  2689   using assms by (induct xs) simp_all

  2690

  2691 lemma fold_commute:

  2692   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"

  2693   shows "h \<circ> fold g xs = fold f xs \<circ> h"

  2694   using assms by (induct xs) (simp_all add: fun_eq_iff)

  2695

  2696 lemma fold_commute_apply:

  2697   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"

  2698   shows "h (fold g xs s) = fold f xs (h s)"

  2699 proof -

  2700   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)

  2701   then show ?thesis by (simp add: fun_eq_iff)

  2702 qed

  2703

  2704 lemma fold_invariant:

  2705   assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"

  2706     and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"

  2707   shows "P (fold f xs s)"

  2708   using assms by (induct xs arbitrary: s) simp_all

  2709

  2710 lemma fold_append [simp]:

  2711   "fold f (xs @ ys) = fold f ys \<circ> fold f xs"

  2712   by (induct xs) simp_all

  2713

  2714 lemma fold_map [code_unfold]:

  2715   "fold g (map f xs) = fold (g o f) xs"

  2716   by (induct xs) simp_all

  2717

  2718 lemma fold_rev:

  2719   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"

  2720   shows "fold f (rev xs) = fold f xs"

  2721 using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)

  2722

  2723 lemma fold_Cons_rev:

  2724   "fold Cons xs = append (rev xs)"

  2725   by (induct xs) simp_all

  2726

  2727 lemma rev_conv_fold [code]:

  2728   "rev xs = fold Cons xs []"

  2729   by (simp add: fold_Cons_rev)

  2730

  2731 lemma fold_append_concat_rev:

  2732   "fold append xss = append (concat (rev xss))"

  2733   by (induct xss) simp_all

  2734

  2735 text {* @{const Finite_Set.fold} and @{const fold} *}

  2736

  2737 lemma (in comp_fun_commute) fold_set_fold_remdups:

  2738   "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"

  2739   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm insert_absorb)

  2740

  2741 lemma (in comp_fun_idem) fold_set_fold:

  2742   "Finite_Set.fold f y (set xs) = fold f xs y"

  2743   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm)

  2744

  2745 lemma union_set_fold [code]:

  2746   "set xs \<union> A = fold Set.insert xs A"

  2747 proof -

  2748   interpret comp_fun_idem Set.insert

  2749     by (fact comp_fun_idem_insert)

  2750   show ?thesis by (simp add: union_fold_insert fold_set_fold)

  2751 qed

  2752

  2753 lemma union_coset_filter [code]:

  2754   "List.coset xs \<union> A = List.coset (List.filter (\<lambda>x. x \<notin> A) xs)"

  2755   by auto

  2756

  2757 lemma minus_set_fold [code]:

  2758   "A - set xs = fold Set.remove xs A"

  2759 proof -

  2760   interpret comp_fun_idem Set.remove

  2761     by (fact comp_fun_idem_remove)

  2762   show ?thesis

  2763     by (simp add: minus_fold_remove [of _ A] fold_set_fold)

  2764 qed

  2765

  2766 lemma minus_coset_filter [code]:

  2767   "A - List.coset xs = set (List.filter (\<lambda>x. x \<in> A) xs)"

  2768   by auto

  2769

  2770 lemma inter_set_filter [code]:

  2771   "A \<inter> set xs = set (List.filter (\<lambda>x. x \<in> A) xs)"

  2772   by auto

  2773

  2774 lemma inter_coset_fold [code]:

  2775   "A \<inter> List.coset xs = fold Set.remove xs A"

  2776   by (simp add: Diff_eq [symmetric] minus_set_fold)

  2777

  2778 lemma (in semilattice_set) set_eq_fold:

  2779   "F (set (x # xs)) = fold f xs x"

  2780 proof -

  2781   interpret comp_fun_idem f

  2782     by default (simp_all add: fun_eq_iff left_commute)

  2783   show ?thesis by (simp add: eq_fold fold_set_fold)

  2784 qed

  2785

  2786 declare Inf_fin.set_eq_fold [code]

  2787 declare Sup_fin.set_eq_fold [code]

  2788 declare Min.set_eq_fold [code]

  2789 declare Max.set_eq_fold [code]

  2790

  2791 lemma (in complete_lattice) Inf_set_fold:

  2792   "Inf (set xs) = fold inf xs top"

  2793 proof -

  2794   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2795     by (fact comp_fun_idem_inf)

  2796   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)

  2797 qed

  2798

  2799 declare Inf_set_fold [where 'a = "'a set", code]

  2800

  2801 lemma (in complete_lattice) Sup_set_fold:

  2802   "Sup (set xs) = fold sup xs bot"

  2803 proof -

  2804   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2805     by (fact comp_fun_idem_sup)

  2806   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)

  2807 qed

  2808

  2809 declare Sup_set_fold [where 'a = "'a set", code]

  2810

  2811 lemma (in complete_lattice) INF_set_fold:

  2812   "INFI (set xs) f = fold (inf \<circ> f) xs top"

  2813   unfolding INF_def set_map [symmetric] Inf_set_fold fold_map ..

  2814

  2815 declare INF_set_fold [code]

  2816

  2817 lemma (in complete_lattice) SUP_set_fold:

  2818   "SUPR (set xs) f = fold (sup \<circ> f) xs bot"

  2819   unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map ..

  2820

  2821 declare SUP_set_fold [code]

  2822

  2823

  2824 subsubsection {* Fold variants: @{const foldr} and @{const foldl} *}

  2825

  2826 text {* Correspondence *}

  2827

  2828 lemma foldr_conv_fold [code_abbrev]:

  2829   "foldr f xs = fold f (rev xs)"

  2830   by (induct xs) simp_all

  2831

  2832 lemma foldl_conv_fold:

  2833   "foldl f s xs = fold (\<lambda>x s. f s x) xs s"

  2834   by (induct xs arbitrary: s) simp_all

  2835

  2836 lemma foldr_conv_foldl: -- {* The Third Duality Theorem'' in Bird \& Wadler: *}

  2837   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"

  2838   by (simp add: foldr_conv_fold foldl_conv_fold)

  2839

  2840 lemma foldl_conv_foldr:

  2841   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"

  2842   by (simp add: foldr_conv_fold foldl_conv_fold)

  2843

  2844 lemma foldr_fold:

  2845   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"

  2846   shows "foldr f xs = fold f xs"

  2847   using assms unfolding foldr_conv_fold by (rule fold_rev)

  2848

  2849 lemma foldr_cong [fundef_cong]:

  2850   "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"

  2851   by (auto simp add: foldr_conv_fold intro!: fold_cong)

  2852

  2853 lemma foldl_cong [fundef_cong]:

  2854   "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"

  2855   by (auto simp add: foldl_conv_fold intro!: fold_cong)

  2856

  2857 lemma foldr_append [simp]:

  2858   "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"

  2859   by (simp add: foldr_conv_fold)

  2860

  2861 lemma foldl_append [simp]:

  2862   "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"

  2863   by (simp add: foldl_conv_fold)

  2864

  2865 lemma foldr_map [code_unfold]:

  2866   "foldr g (map f xs) a = foldr (g o f) xs a"

  2867   by (simp add: foldr_conv_fold fold_map rev_map)

  2868

  2869 lemma foldl_map [code_unfold]:

  2870   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"

  2871   by (simp add: foldl_conv_fold fold_map comp_def)

  2872

  2873 lemma concat_conv_foldr [code]:

  2874   "concat xss = foldr append xss []"

  2875   by (simp add: fold_append_concat_rev foldr_conv_fold)

  2876

  2877

  2878 subsubsection {* @{const upt} *}

  2879

  2880 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"

  2881 -- {* simp does not terminate! *}

  2882 by (induct j) auto

  2883

  2884 lemmas upt_rec_numeral[simp] = upt_rec[of "numeral m" "numeral n"] for m n

  2885

  2886 lemma upt_conv_Nil [simp]: "j <= i ==> [i..<j] = []"

  2887 by (subst upt_rec) simp

  2888

  2889 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j <= i)"

  2890 by(induct j)simp_all

  2891

  2892 lemma upt_eq_Cons_conv:

  2893  "([i..<j] = x#xs) = (i < j & i = x & [i+1..<j] = xs)"

  2894 apply(induct j arbitrary: x xs)

  2895  apply simp

  2896 apply(clarsimp simp add: append_eq_Cons_conv)

  2897 apply arith

  2898 done

  2899

  2900 lemma upt_Suc_append: "i <= j ==> [i..<(Suc j)] = [i..<j]@[j]"

  2901 -- {* Only needed if @{text upt_Suc} is deleted from the simpset. *}

  2902 by simp

  2903

  2904 lemma upt_conv_Cons: "i < j ==> [i..<j] = i # [Suc i..<j]"

  2905   by (simp add: upt_rec)

  2906

  2907 lemma upt_add_eq_append: "i<=j ==> [i..<j+k] = [i..<j]@[j..<j+k]"

  2908 -- {* LOOPS as a simprule, since @{text "j <= j"}. *}

  2909 by (induct k) auto

  2910

  2911 lemma length_upt [simp]: "length [i..<j] = j - i"

  2912 by (induct j) (auto simp add: Suc_diff_le)

  2913

  2914 lemma nth_upt [simp]: "i + k < j ==> [i..<j] ! k = i + k"

  2915 apply (induct j)

  2916 apply (auto simp add: less_Suc_eq nth_append split: nat_diff_split)

  2917 done

  2918

  2919

  2920 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"

  2921 by(simp add:upt_conv_Cons)

  2922

  2923 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"

  2924 apply(cases j)

  2925  apply simp

  2926 by(simp add:upt_Suc_append)

  2927

  2928 lemma take_upt [simp]: "i+m <= n ==> take m [i..<n] = [i..<i+m]"

  2929 apply (induct m arbitrary: i, simp)

  2930 apply (subst upt_rec)

  2931 apply (rule sym)

  2932 apply (subst upt_rec)

  2933 apply (simp del: upt.simps)

  2934 done

  2935

  2936 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"

  2937 apply(induct j)

  2938 apply auto

  2939 done

  2940

  2941 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"

  2942 by (induct n) auto

  2943

  2944 lemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"

  2945 apply (induct n m  arbitrary: i rule: diff_induct)

  2946 prefer 3 apply (subst map_Suc_upt[symmetric])

  2947 apply (auto simp add: less_diff_conv)

  2948 done

  2949

  2950 lemma nth_take_lemma:

  2951   "k <= length xs ==> k <= length ys ==>

  2952      (!!i. i < k --> xs!i = ys!i) ==> take k xs = take k ys"

  2953 apply (atomize, induct k arbitrary: xs ys)

  2954 apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib, clarify)

  2955 txt {* Both lists must be non-empty *}

  2956 apply (case_tac xs, simp)

  2957 apply (case_tac ys, clarify)

  2958  apply (simp (no_asm_use))

  2959 apply clarify

  2960 txt {* prenexing's needed, not miniscoping *}

  2961 apply (simp (no_asm_use) add: all_simps [symmetric] del: all_simps)

  2962 apply blast

  2963 done

  2964

  2965 lemma nth_equalityI:

  2966  "[| length xs = length ys; ALL i < length xs. xs!i = ys!i |] ==> xs = ys"

  2967   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all

  2968

  2969 lemma map_nth:

  2970   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"

  2971   by (rule nth_equalityI, auto)

  2972

  2973 (* needs nth_equalityI *)

  2974 lemma list_all2_antisym:

  2975   "\<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>

  2976   \<Longrightarrow> xs = ys"

  2977   apply (simp add: list_all2_conv_all_nth)

  2978   apply (rule nth_equalityI, blast, simp)

  2979   done

  2980

  2981 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) ==> xs = ys"

  2982 -- {* The famous take-lemma. *}

  2983 apply (drule_tac x = "max (length xs) (length ys)" in spec)

  2984 apply (simp add: le_max_iff_disj)

  2985 done

  2986

  2987

  2988 lemma take_Cons':

  2989      "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"

  2990 by (cases n) simp_all

  2991

  2992 lemma drop_Cons':

  2993      "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"

  2994 by (cases n) simp_all

  2995

  2996 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"

  2997 by (cases n) simp_all

  2998

  2999 lemma take_Cons_numeral [simp]:

  3000   "take (numeral v) (x # xs) = x # take (numeral v - 1) xs"

  3001 by (simp add: take_Cons')

  3002

  3003 lemma drop_Cons_numeral [simp]:

  3004   "drop (numeral v) (x # xs) = drop (numeral v - 1) xs"

  3005 by (simp add: drop_Cons')

  3006

  3007 lemma nth_Cons_numeral [simp]:

  3008   "(x # xs) ! numeral v = xs ! (numeral v - 1)"

  3009 by (simp add: nth_Cons')

  3010

  3011

  3012 subsubsection {* @{text upto}: interval-list on @{typ int} *}

  3013

  3014 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where

  3015   "upto i j = (if i \<le> j then i # [i+1..j] else [])"

  3016 by auto

  3017 termination

  3018 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto

  3019

  3020 declare upto.simps[simp del]

  3021

  3022 lemmas upto_rec_numeral [simp] =

  3023   upto.simps[of "numeral m" "numeral n"]

  3024   upto.simps[of "numeral m" "neg_numeral n"]

  3025   upto.simps[of "neg_numeral m" "numeral n"]

  3026   upto.simps[of "neg_numeral m" "neg_numeral n"] for m n

  3027

  3028 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"

  3029 by(simp add: upto.simps)

  3030

  3031 lemma upto_rec1: "i \<le> j \<Longrightarrow> [i..j] = i#[i+1..j]"

  3032 by(simp add: upto.simps)

  3033

  3034 lemma upto_rec2: "i \<le> j \<Longrightarrow> [i..j] = [i..j - 1]@[j]"

  3035 proof(induct "nat(j-i)" arbitrary: i j)

  3036   case 0 thus ?case by(simp add: upto.simps)

  3037 next

  3038   case (Suc n)

  3039   hence "n = nat (j - (i + 1))" "i < j" by linarith+

  3040   from this(2) Suc.hyps(1)[OF this(1)] Suc(2,3) upto_rec1 show ?case by simp

  3041 qed

  3042

  3043 lemma set_upto[simp]: "set[i..j] = {i..j}"

  3044 proof(induct i j rule:upto.induct)

  3045   case (1 i j)

  3046   from this show ?case

  3047     unfolding upto.simps[of i j] simp_from_to[of i j] by auto

  3048 qed

  3049

  3050 text{* Tail recursive version for code generation: *}

  3051

  3052 definition upto_aux :: "int \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list" where

  3053   "upto_aux i j js = [i..j] @ js"

  3054

  3055 lemma upto_aux_rec [code]:

  3056   "upto_aux i j js = (if j<i then js else upto_aux i (j - 1) (j#js))"

  3057   by (simp add: upto_aux_def upto_rec2)

  3058

  3059 lemma upto_code[code]: "[i..j] = upto_aux i j []"

  3060 by(simp add: upto_aux_def)

  3061

  3062

  3063 subsubsection {* @{const distinct} and @{const remdups} *}

  3064

  3065 lemma distinct_tl:

  3066   "distinct xs \<Longrightarrow> distinct (tl xs)"

  3067   by (cases xs) simp_all

  3068

  3069 lemma distinct_append [simp]:

  3070 "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"

  3071 by (induct xs) auto

  3072

  3073 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"

  3074 by(induct xs) auto

  3075

  3076 lemma set_remdups [simp]: "set (remdups xs) = set xs"

  3077 by (induct xs) (auto simp add: insert_absorb)

  3078

  3079 lemma distinct_remdups [iff]: "distinct (remdups xs)"

  3080 by (induct xs) auto

  3081

  3082 lemma distinct_remdups_id: "distinct xs ==> remdups xs = xs"

  3083 by (induct xs, auto)

  3084

  3085 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"

  3086 by (metis distinct_remdups distinct_remdups_id)

  3087

  3088 lemma finite_distinct_list: "finite A \<Longrightarrow> EX xs. set xs = A & distinct xs"

  3089 by (metis distinct_remdups finite_list set_remdups)

  3090

  3091 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"

  3092 by (induct x, auto)

  3093

  3094 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"

  3095 by (induct x, auto)

  3096

  3097 lemma length_remdups_leq[iff]: "length(remdups xs) <= length xs"

  3098 by (induct xs) auto

  3099

  3100 lemma length_remdups_eq[iff]:

  3101   "(length (remdups xs) = length xs) = (remdups xs = xs)"

  3102 apply(induct xs)

  3103  apply auto

  3104 apply(subgoal_tac "length (remdups xs) <= length xs")

  3105  apply arith

  3106 apply(rule length_remdups_leq)

  3107 done

  3108

  3109 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"

  3110 apply(induct xs)

  3111 apply auto

  3112 done

  3113

  3114 lemma distinct_map:

  3115   "distinct(map f xs) = (distinct xs & inj_on f (set xs))"

  3116 by (induct xs) auto

  3117

  3118 lemma distinct_filter [simp]: "distinct xs ==> distinct (filter P xs)"

  3119 by (induct xs) auto

  3120

  3121 lemma distinct_upt[simp]: "distinct[i..<j]"

  3122 by (induct j) auto

  3123

  3124 lemma distinct_upto[simp]: "distinct[i..j]"

  3125 apply(induct i j rule:upto.induct)

  3126 apply(subst upto.simps)

  3127 apply(simp)

  3128 done

  3129

  3130 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"

  3131 apply(induct xs arbitrary: i)

  3132  apply simp

  3133 apply (case_tac i)

  3134  apply simp_all

  3135 apply(blast dest:in_set_takeD)

  3136 done

  3137

  3138 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"

  3139 apply(induct xs arbitrary: i)

  3140  apply simp

  3141 apply (case_tac i)

  3142  apply simp_all

  3143 done

  3144

  3145 lemma distinct_list_update:

  3146 assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"

  3147 shows "distinct (xs[i:=a])"

  3148 proof (cases "i < length xs")

  3149   case True

  3150   with a have "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"

  3151     apply (drule_tac id_take_nth_drop) by simp

  3152   with d True show ?thesis

  3153     apply (simp add: upd_conv_take_nth_drop)

  3154     apply (drule subst [OF id_take_nth_drop]) apply assumption

  3155     apply simp apply (cases "a = xs!i") apply simp by blast

  3156 next

  3157   case False with d show ?thesis by auto

  3158 qed

  3159

  3160 lemma distinct_concat:

  3161   assumes "distinct xs"

  3162   and "\<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys"

  3163   and "\<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}"

  3164   shows "distinct (concat xs)"

  3165   using assms by (induct xs) auto

  3166

  3167 text {* It is best to avoid this indexed version of distinct, but

  3168 sometimes it is useful. *}

  3169

  3170 lemma distinct_conv_nth:

  3171 "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j --> xs!i \<noteq> xs!j)"

  3172 apply (induct xs, simp, simp)

  3173 apply (rule iffI, clarsimp)

  3174  apply (case_tac i)

  3175 apply (case_tac j, simp)

  3176 apply (simp add: set_conv_nth)

  3177  apply (case_tac j)

  3178 apply (clarsimp simp add: set_conv_nth, simp)

  3179 apply (rule conjI)

  3180 (*TOO SLOW

  3181 apply (metis Zero_neq_Suc gr0_conv_Suc in_set_conv_nth lessI less_trans_Suc nth_Cons' nth_Cons_Suc)

  3182 *)

  3183  apply (clarsimp simp add: set_conv_nth)

  3184  apply (erule_tac x = 0 in allE, simp)

  3185  apply (erule_tac x = "Suc i" in allE, simp, clarsimp)

  3186 (*TOO SLOW

  3187 apply (metis Suc_Suc_eq lessI less_trans_Suc nth_Cons_Suc)

  3188 *)

  3189 apply (erule_tac x = "Suc i" in allE, simp)

  3190 apply (erule_tac x = "Suc j" in allE, simp)

  3191 done

  3192

  3193 lemma nth_eq_iff_index_eq:

  3194  "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"

  3195 by(auto simp: distinct_conv_nth)

  3196

  3197 lemma distinct_card: "distinct xs ==> card (set xs) = size xs"

  3198 by (induct xs) auto

  3199

  3200 lemma card_distinct: "card (set xs) = size xs ==> distinct xs"

  3201 proof (induct xs)

  3202   case Nil thus ?case by simp

  3203 next

  3204   case (Cons x xs)

  3205   show ?case

  3206   proof (cases "x \<in> set xs")

  3207     case False with Cons show ?thesis by simp

  3208   next

  3209     case True with Cons.prems

  3210     have "card (set xs) = Suc (length xs)"

  3211       by (simp add: card_insert_if split: split_if_asm)

  3212     moreover have "card (set xs) \<le> length xs" by (rule card_length)

  3213     ultimately have False by simp

  3214     thus ?thesis ..

  3215   qed

  3216 qed

  3217

  3218 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"

  3219 by (induct xs) (auto)

  3220

  3221 lemma not_distinct_decomp: "~ distinct ws ==> EX xs ys zs y. ws = xs@[y]@ys@[y]@zs"

  3222 apply (induct n == "length ws" arbitrary:ws) apply simp

  3223 apply(case_tac ws) apply simp

  3224 apply (simp split:split_if_asm)

  3225 apply (metis Cons_eq_appendI eq_Nil_appendI split_list)

  3226 done

  3227

  3228 lemma not_distinct_conv_prefix:

  3229   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"

  3230   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")

  3231 proof

  3232   assume "?L" then show "?R"

  3233   proof (induct "length as" arbitrary: as rule: less_induct)

  3234     case less

  3235     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"

  3236       using not_distinct_decomp[OF less.prems] by auto

  3237     show ?case

  3238     proof (cases "distinct (xs @ y # ys)")

  3239       case True

  3240       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)

  3241       then show ?thesis by blast

  3242     next

  3243       case False

  3244       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"

  3245         by atomize_elim auto

  3246       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)

  3247       then show ?thesis by blast

  3248     qed

  3249   qed

  3250 qed (auto simp: dec_def)

  3251

  3252 lemma distinct_product:

  3253   assumes "distinct xs" and "distinct ys"

  3254   shows "distinct (List.product xs ys)"

  3255   using assms by (induct xs)

  3256     (auto intro: inj_onI simp add: product_list_set distinct_map)

  3257

  3258 lemma length_remdups_concat:

  3259   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"

  3260   by (simp add: distinct_card [symmetric])

  3261

  3262 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"

  3263 proof -

  3264   have xs: "concat[xs] = xs" by simp

  3265   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp

  3266 qed

  3267

  3268 lemma remdups_remdups:

  3269   "remdups (remdups xs) = remdups xs"

  3270   by (induct xs) simp_all

  3271

  3272 lemma distinct_butlast:

  3273   assumes "distinct xs"

  3274   shows "distinct (butlast xs)"

  3275 proof (cases "xs = []")

  3276   case False

  3277     from xs \<noteq> [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto

  3278     with distinct xs show ?thesis by simp

  3279 qed (auto)

  3280

  3281 lemma remdups_map_remdups:

  3282   "remdups (map f (remdups xs)) = remdups (map f xs)"

  3283   by (induct xs) simp_all

  3284

  3285 lemma distinct_zipI1:

  3286   assumes "distinct xs"

  3287   shows "distinct (zip xs ys)"

  3288 proof (rule zip_obtain_same_length)

  3289   fix xs' :: "'a list" and ys' :: "'b list" and n

  3290   assume "length xs' = length ys'"

  3291   assume "xs' = take n xs"

  3292   with assms have "distinct xs'" by simp

  3293   with length xs' = length ys' show "distinct (zip xs' ys')"

  3294     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)

  3295 qed

  3296

  3297 lemma distinct_zipI2:

  3298   assumes "distinct ys"

  3299   shows "distinct (zip xs ys)"

  3300 proof (rule zip_obtain_same_length)

  3301   fix xs' :: "'b list" and ys' :: "'a list" and n

  3302   assume "length xs' = length ys'"

  3303   assume "ys' = take n ys"

  3304   with assms have "distinct ys'" by simp

  3305   with length xs' = length ys' show "distinct (zip xs' ys')"

  3306     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)

  3307 qed

  3308

  3309 lemma set_take_disj_set_drop_if_distinct:

  3310   "distinct vs \<Longrightarrow> i \<le> j \<Longrightarrow> set (take i vs) \<inter> set (drop j vs) = {}"

  3311 by (auto simp: in_set_conv_nth distinct_conv_nth)

  3312

  3313 (* The next two lemmas help Sledgehammer. *)

  3314

  3315 lemma distinct_singleton: "distinct [x]" by simp

  3316

  3317 lemma distinct_length_2_or_more:

  3318 "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"

  3319 by (metis distinct.simps(2) hd.simps hd_in_set list.simps(2) set_ConsD set_rev_mp set_subset_Cons)

  3320

  3321

  3322 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}

  3323

  3324 lemma (in monoid_add) listsum_simps [simp]:

  3325   "listsum [] = 0"

  3326   "listsum (x # xs) = x + listsum xs"

  3327   by (simp_all add: listsum_def)

  3328

  3329 lemma (in monoid_add) listsum_append [simp]:

  3330   "listsum (xs @ ys) = listsum xs + listsum ys"

  3331   by (induct xs) (simp_all add: add.assoc)

  3332

  3333 lemma (in comm_monoid_add) listsum_rev [simp]:

  3334   "listsum (rev xs) = listsum xs"

  3335   by (simp add: listsum_def foldr_fold fold_rev fun_eq_iff add_ac)

  3336

  3337 lemma (in monoid_add) fold_plus_listsum_rev:

  3338   "fold plus xs = plus (listsum (rev xs))"

  3339 proof

  3340   fix x

  3341   have "fold plus xs x = fold plus xs (x + 0)" by simp

  3342   also have "\<dots> = fold plus (x # xs) 0" by simp

  3343   also have "\<dots> = foldr plus (rev xs @ [x]) 0" by (simp add: foldr_conv_fold)

  3344   also have "\<dots> = listsum (rev xs @ [x])" by (simp add: listsum_def)

  3345   also have "\<dots> = listsum (rev xs) + listsum [x]" by simp

  3346   finally show "fold plus xs x = listsum (rev xs) + x" by simp

  3347 qed

  3348

  3349 text{* Some syntactic sugar for summing a function over a list: *}

  3350

  3351 syntax

  3352   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)

  3353 syntax (xsymbols)

  3354   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

  3355 syntax (HTML output)

  3356   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

  3357

  3358 translations -- {* Beware of argument permutation! *}

  3359   "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)"

  3360   "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"

  3361

  3362 lemma (in comm_monoid_add) listsum_map_remove1:

  3363   "x \<in> set xs \<Longrightarrow> listsum (map f xs) = f x + listsum (map f (remove1 x xs))"

  3364   by (induct xs) (auto simp add: ac_simps)

  3365

  3366 lemma (in monoid_add) list_size_conv_listsum:

  3367   "list_size f xs = listsum (map f xs) + size xs"

  3368   by (induct xs) auto

  3369

  3370 lemma (in monoid_add) length_concat:

  3371   "length (concat xss) = listsum (map length xss)"

  3372   by (induct xss) simp_all

  3373

  3374 lemma (in monoid_add) listsum_map_filter:

  3375   assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"

  3376   shows "listsum (map f (filter P xs)) = listsum (map f xs)"

  3377   using assms by (induct xs) auto

  3378

  3379 lemma (in comm_monoid_add) distinct_listsum_conv_Setsum:

  3380   "distinct xs \<Longrightarrow> listsum xs = Setsum (set xs)"

  3381   by (induct xs) simp_all

  3382

  3383 lemma listsum_eq_0_nat_iff_nat [simp]:

  3384   "listsum ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"

  3385   by (induct ns) simp_all

  3386

  3387 lemma member_le_listsum_nat:

  3388   "(n :: nat) \<in> set ns \<Longrightarrow> n \<le> listsum ns"

  3389   by (induct ns) auto

  3390

  3391 lemma elem_le_listsum_nat:

  3392   "k < size ns \<Longrightarrow> ns ! k \<le> listsum (ns::nat list)"

  3393   by (rule member_le_listsum_nat) simp

  3394

  3395 lemma listsum_update_nat:

  3396   "k < size ns \<Longrightarrow> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"

  3397 apply(induct ns arbitrary:k)

  3398  apply (auto split:nat.split)

  3399 apply(drule elem_le_listsum_nat)

  3400 apply arith

  3401 done

  3402

  3403 lemma (in monoid_add) listsum_triv:

  3404   "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"

  3405   by (induct xs) (simp_all add: distrib_right)

  3406

  3407 lemma (in monoid_add) listsum_0 [simp]:

  3408   "(\<Sum>x\<leftarrow>xs. 0) = 0"

  3409   by (induct xs) (simp_all add: distrib_right)

  3410

  3411 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}

  3412 lemma (in ab_group_add) uminus_listsum_map:

  3413   "- listsum (map f xs) = listsum (map (uminus \<circ> f) xs)"

  3414   by (induct xs) simp_all

  3415

  3416 lemma (in comm_monoid_add) listsum_addf:

  3417   "(\<Sum>x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)"

  3418   by (induct xs) (simp_all add: algebra_simps)

  3419

  3420 lemma (in ab_group_add) listsum_subtractf:

  3421   "(\<Sum>x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)"

  3422   by (induct xs) (simp_all add: algebra_simps)

  3423

  3424 lemma (in semiring_0) listsum_const_mult:

  3425   "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"

  3426   by (induct xs) (simp_all add: algebra_simps)

  3427

  3428 lemma (in semiring_0) listsum_mult_const:

  3429   "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"

  3430   by (induct xs) (simp_all add: algebra_simps)

  3431

  3432 lemma (in ordered_ab_group_add_abs) listsum_abs:

  3433   "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"

  3434   by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])

  3435

  3436 lemma listsum_mono:

  3437   fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"

  3438   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)"

  3439   by (induct xs) (simp, simp add: add_mono)

  3440

  3441 lemma (in monoid_add) listsum_distinct_conv_setsum_set:

  3442   "distinct xs \<Longrightarrow> listsum (map f xs) = setsum f (set xs)"

  3443   by (induct xs) simp_all

  3444

  3445 lemma (in monoid_add) interv_listsum_conv_setsum_set_nat:

  3446   "listsum (map f [m..<n]) = setsum f (set [m..<n])"

  3447   by (simp add: listsum_distinct_conv_setsum_set)

  3448

  3449 lemma (in monoid_add) interv_listsum_conv_setsum_set_int:

  3450   "listsum (map f [k..l]) = setsum f (set [k..l])"

  3451   by (simp add: listsum_distinct_conv_setsum_set)

  3452

  3453 text {* General equivalence between @{const listsum} and @{const setsum} *}

  3454 lemma (in monoid_add) listsum_setsum_nth:

  3455   "listsum xs = (\<Sum> i = 0 ..< length xs. xs ! i)"

  3456   using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)

  3457

  3458

  3459 subsubsection {* @{const insert} *}

  3460

  3461 lemma in_set_insert [simp]:

  3462   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"

  3463   by (simp add: List.insert_def)

  3464

  3465 lemma not_in_set_insert [simp]:

  3466   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"

  3467   by (simp add: List.insert_def)

  3468

  3469 lemma insert_Nil [simp]:

  3470   "List.insert x [] = [x]"

  3471   by simp

  3472

  3473 lemma set_insert [simp]:

  3474   "set (List.insert x xs) = insert x (set xs)"

  3475   by (auto simp add: List.insert_def)

  3476

  3477 lemma distinct_insert [simp]:

  3478   "distinct xs \<Longrightarrow> distinct (List.insert x xs)"

  3479   by (simp add: List.insert_def)

  3480

  3481 lemma insert_remdups:

  3482   "List.insert x (remdups xs) = remdups (List.insert x xs)"

  3483   by (simp add: List.insert_def)

  3484

  3485

  3486 subsubsection {* @{const List.find} *}

  3487

  3488 lemma find_None_iff: "List.find P xs = None \<longleftrightarrow> \<not> (\<exists>x. x \<in> set xs \<and> P x)"

  3489 proof (induction xs)

  3490   case Nil thus ?case by simp

  3491 next

  3492   case (Cons x xs) thus ?case by (fastforce split: if_splits)

  3493 qed

  3494

  3495 lemma find_Some_iff:

  3496   "List.find P xs = Some x \<longleftrightarrow>

  3497   (\<exists>i<length xs. P (xs!i) \<and> x = xs!i \<and> (\<forall>j<i. \<not> P (xs!j)))"

  3498 proof (induction xs)

  3499   case Nil thus ?case by simp

  3500 next

  3501   case (Cons x xs) thus ?case

  3502     by(auto simp: nth_Cons' split: if_splits)

  3503       (metis One_nat_def diff_Suc_1 less_Suc_eq_0_disj)

  3504 qed

  3505

  3506 lemma find_cong[fundef_cong]:

  3507   assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x"

  3508   shows "List.find P xs = List.find Q ys"

  3509 proof (cases "List.find P xs")

  3510   case None thus ?thesis by (metis find_None_iff assms)

  3511 next

  3512   case (Some x)

  3513   hence "List.find Q ys = Some x" using assms

  3514     by (auto simp add: find_Some_iff)

  3515   thus ?thesis using Some by auto

  3516 qed

  3517

  3518 lemma find_dropWhile:

  3519   "List.find P xs = (case dropWhile (Not \<circ> P) xs

  3520    of [] \<Rightarrow> None

  3521     | x # _ \<Rightarrow> Some x)"

  3522   by (induct xs) simp_all

  3523

  3524

  3525 subsubsection {* @{const remove1} *}

  3526

  3527 lemma remove1_append:

  3528   "remove1 x (xs @ ys) =

  3529   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"

  3530 by (induct xs) auto

  3531

  3532 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"

  3533 by (induct zs) auto

  3534

  3535 lemma in_set_remove1[simp]:

  3536   "a \<noteq> b \<Longrightarrow> a : set(remove1 b xs) = (a : set xs)"

  3537 apply (induct xs)

  3538 apply auto

  3539 done

  3540

  3541 lemma set_remove1_subset: "set(remove1 x xs) <= set xs"

  3542 apply(induct xs)

  3543  apply simp

  3544 apply simp

  3545 apply blast

  3546 done

  3547

  3548 lemma set_remove1_eq [simp]: "distinct xs ==> set(remove1 x xs) = set xs - {x}"

  3549 apply(induct xs)

  3550  apply simp

  3551 apply simp

  3552 apply blast

  3553 done

  3554

  3555 lemma length_remove1:

  3556   "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"

  3557 apply (induct xs)

  3558  apply (auto dest!:length_pos_if_in_set)

  3559 done

  3560

  3561 lemma remove1_filter_not[simp]:

  3562   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"

  3563 by(induct xs) auto

  3564

  3565 lemma filter_remove1:

  3566   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"

  3567 by (induct xs) auto

  3568

  3569 lemma notin_set_remove1[simp]: "x ~: set xs ==> x ~: set(remove1 y xs)"

  3570 apply(insert set_remove1_subset)

  3571 apply fast

  3572 done

  3573

  3574 lemma distinct_remove1[simp]: "distinct xs ==> distinct(remove1 x xs)"

  3575 by (induct xs) simp_all

  3576

  3577 lemma remove1_remdups:

  3578   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"

  3579   by (induct xs) simp_all

  3580

  3581 lemma remove1_idem:

  3582   assumes "x \<notin> set xs"

  3583   shows "remove1 x xs = xs"

  3584   using assms by (induct xs) simp_all

  3585

  3586

  3587 subsubsection {* @{const removeAll} *}

  3588

  3589 lemma removeAll_filter_not_eq:

  3590   "removeAll x = filter (\<lambda>y. x \<noteq> y)"

  3591 proof

  3592   fix xs

  3593   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"

  3594     by (induct xs) auto

  3595 qed

  3596

  3597 lemma removeAll_append[simp]:

  3598   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"

  3599 by (induct xs) auto

  3600

  3601 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"

  3602 by (induct xs) auto

  3603

  3604 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"

  3605 by (induct xs) auto

  3606

  3607 (* Needs count:: 'a \<Rightarrow> 'a list \<Rightarrow> nat

  3608 lemma length_removeAll:

  3609   "length(removeAll x xs) = length xs - count x xs"

  3610 *)

  3611

  3612 lemma removeAll_filter_not[simp]:

  3613   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"

  3614 by(induct xs) auto

  3615

  3616 lemma distinct_removeAll:

  3617   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"

  3618   by (simp add: removeAll_filter_not_eq)

  3619

  3620 lemma distinct_remove1_removeAll:

  3621   "distinct xs ==> remove1 x xs = removeAll x xs"

  3622 by (induct xs) simp_all

  3623

  3624 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>

  3625   map f (removeAll x xs) = removeAll (f x) (map f xs)"

  3626 by (induct xs) (simp_all add:inj_on_def)

  3627

  3628 lemma map_removeAll_inj: "inj f \<Longrightarrow>

  3629   map f (removeAll x xs) = removeAll (f x) (map f xs)"

  3630 by(metis map_removeAll_inj_on subset_inj_on subset_UNIV)

  3631

  3632

  3633 subsubsection {* @{const replicate} *}

  3634

  3635 lemma length_replicate [simp]: "length (replicate n x) = n"

  3636 by (induct n) auto

  3637

  3638 lemma Ex_list_of_length: "\<exists>xs. length xs = n"

  3639 by (rule exI[of _ "replicate n undefined"]) simp

  3640

  3641 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"

  3642 by (induct n) auto

  3643

  3644 lemma map_replicate_const:

  3645   "map (\<lambda> x. k) lst = replicate (length lst) k"

  3646   by (induct lst) auto

  3647

  3648 lemma replicate_app_Cons_same:

  3649 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"

  3650 by (induct n) auto

  3651

  3652 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"

  3653 apply (induct n, simp)

  3654 apply (simp add: replicate_app_Cons_same)

  3655 done

  3656

  3657 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"

  3658 by (induct n) auto

  3659

  3660 text{* Courtesy of Matthias Daum: *}

  3661 lemma append_replicate_commute:

  3662   "replicate n x @ replicate k x = replicate k x @ replicate n x"

  3663 apply (simp add: replicate_add [THEN sym])

  3664 apply (simp add: add_commute)

  3665 done

  3666

  3667 text{* Courtesy of Andreas Lochbihler: *}

  3668 lemma filter_replicate:

  3669   "filter P (replicate n x) = (if P x then replicate n x else [])"

  3670 by(induct n) auto

  3671

  3672 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"

  3673 by (induct n) auto

  3674

  3675 lemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"

  3676 by (induct n) auto

  3677

  3678 lemma last_replicate [simp]: "n \<noteq> 0 ==> last (replicate n x) = x"

  3679 by (atomize (full), induct n) auto

  3680

  3681 lemma nth_replicate[simp]: "i < n ==> (replicate n x)!i = x"

  3682 apply (induct n arbitrary: i, simp)

  3683 apply (simp add: nth_Cons split: nat.split)

  3684 done

  3685

  3686 text{* Courtesy of Matthias Daum (2 lemmas): *}

  3687 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"

  3688 apply (case_tac "k \<le> i")

  3689  apply  (simp add: min_def)

  3690 apply (drule not_leE)

  3691 apply (simp add: min_def)

  3692 apply (subgoal_tac "replicate k x = replicate i x @ replicate (k - i) x")

  3693  apply  simp

  3694 apply (simp add: replicate_add [symmetric])

  3695 done

  3696

  3697 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"

  3698 apply (induct k arbitrary: i)

  3699  apply simp

  3700 apply clarsimp

  3701 apply (case_tac i)

  3702  apply simp

  3703 apply clarsimp

  3704 done

  3705

  3706

  3707 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"

  3708 by (induct n) auto

  3709

  3710 lemma set_replicate [simp]: "n \<noteq> 0 ==> set (replicate n x) = {x}"

  3711 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)

  3712

  3713 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"

  3714 by auto

  3715

  3716 lemma in_set_replicate[simp]: "(x : set (replicate n y)) = (x = y & n \<noteq> 0)"

  3717 by (simp add: set_replicate_conv_if)

  3718

  3719 lemma Ball_set_replicate[simp]:

  3720   "(ALL x : set(replicate n a). P x) = (P a | n=0)"

  3721 by(simp add: set_replicate_conv_if)

  3722

  3723 lemma Bex_set_replicate[simp]:

  3724   "(EX x : set(replicate n a). P x) = (P a & n\<noteq>0)"

  3725 by(simp add: set_replicate_conv_if)

  3726

  3727 lemma replicate_append_same:

  3728   "replicate i x @ [x] = x # replicate i x"

  3729   by (induct i) simp_all

  3730

  3731 lemma map_replicate_trivial:

  3732   "map (\<lambda>i. x) [0..<i] = replicate i x"

  3733   by (induct i) (simp_all add: replicate_append_same)

  3734

  3735 lemma concat_replicate_trivial[simp]:

  3736   "concat (replicate i []) = []"

  3737   by (induct i) (auto simp add: map_replicate_const)

  3738

  3739 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"

  3740 by (induct n) auto

  3741

  3742 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"

  3743 by (induct n) auto

  3744

  3745 lemma replicate_eq_replicate[simp]:

  3746   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n & (m\<noteq>0 \<longrightarrow> x=y))"

  3747 apply(induct m arbitrary: n)

  3748  apply simp

  3749 apply(induct_tac n)

  3750 apply auto

  3751 done

  3752

  3753 lemma replicate_length_filter:

  3754   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"

  3755   by (induct xs) auto

  3756

  3757 lemma comm_append_are_replicate:

  3758   fixes xs ys :: "'a list"

  3759   assumes "xs \<noteq> []" "ys \<noteq> []"

  3760   assumes "xs @ ys = ys @ xs"

  3761   shows "\<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"

  3762   using assms

  3763 proof (induct "length (xs @ ys)" arbitrary: xs ys rule: less_induct)

  3764   case less

  3765

  3766   def xs' \<equiv> "if (length xs \<le> length ys) then xs else ys"

  3767     and ys' \<equiv> "if (length xs \<le> length ys) then ys else xs"

  3768   then have

  3769     prems': "length xs' \<le> length ys'"

  3770             "xs' @ ys' = ys' @ xs'"

  3771       and "xs' \<noteq> []"

  3772       and len: "length (xs @ ys) = length (xs' @ ys')"

  3773     using less by (auto intro: less.hyps)

  3774

  3775   from prems'

  3776   obtain ws where "ys' = xs' @ ws"

  3777     by (auto simp: append_eq_append_conv2)

  3778

  3779   have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ys'"

  3780   proof (cases "ws = []")

  3781     case True

  3782     then have "concat (replicate 1 xs') = xs'"

  3783       and "concat (replicate 1 xs') = ys'"

  3784       using ys' = xs' @ ws by auto

  3785     then show ?thesis by blast

  3786   next

  3787     case False

  3788     from ys' = xs' @ ws and xs' @ ys' = ys' @ xs'

  3789     have "xs' @ ws = ws @ xs'" by simp

  3790     then have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ws"

  3791       using False and xs' \<noteq> [] and ys' = xs' @ ws and len

  3792       by (intro less.hyps) auto

  3793     then obtain m n zs where "concat (replicate m zs) = xs'"

  3794       and "concat (replicate n zs) = ws" by blast

  3795     moreover

  3796     then have "concat (replicate (m + n) zs) = ys'"

  3797       using ys' = xs' @ ws

  3798       by (simp add: replicate_add)

  3799     ultimately

  3800     show ?thesis by blast

  3801   qed

  3802   then show ?case

  3803     using xs'_def ys'_def by metis

  3804 qed

  3805

  3806 lemma comm_append_is_replicate:

  3807   fixes xs ys :: "'a list"

  3808   assumes "xs \<noteq> []" "ys \<noteq> []"

  3809   assumes "xs @ ys = ys @ xs"

  3810   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"

  3811

  3812 proof -

  3813   obtain m n zs where "concat (replicate m zs) = xs"

  3814     and "concat (replicate n zs) = ys"

  3815     using assms by (metis comm_append_are_replicate)

  3816   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"

  3817     using xs \<noteq> [] and ys \<noteq> []

  3818     by (auto simp: replicate_add)

  3819   then show ?thesis by blast

  3820 qed

  3821

  3822

  3823 subsubsection {* @{const enumerate} *}

  3824

  3825 lemma enumerate_simps [simp, code]:

  3826   "enumerate n [] = []"

  3827   "enumerate n (x # xs) = (n, x) # enumerate (Suc n) xs"

  3828   apply (auto simp add: enumerate_eq_zip not_le)

  3829   apply (cases "n < n + length xs")

  3830   apply (auto simp add: upt_conv_Cons)

  3831   done

  3832

  3833 lemma length_enumerate [simp]:

  3834   "length (enumerate n xs) = length xs"

  3835   by (simp add: enumerate_eq_zip)

  3836

  3837 lemma map_fst_enumerate [simp]:

  3838   "map fst (enumerate n xs) = [n..<n + length xs]"

  3839   by (simp add: enumerate_eq_zip)

  3840

  3841 lemma map_snd_enumerate [simp]:

  3842   "map snd (enumerate n xs) = xs"

  3843   by (simp add: enumerate_eq_zip)

  3844

  3845 lemma in_set_enumerate_eq:

  3846   "p \<in> set (enumerate n xs) \<longleftrightarrow> n \<le> fst p \<and> fst p < length xs + n \<and> nth xs (fst p - n) = snd p"

  3847 proof -

  3848   { fix m

  3849     assume "n \<le> m"

  3850     moreover assume "m < length xs + n"

  3851     ultimately have "[n..<n + length xs] ! (m - n) = m \<and>

  3852       xs ! (m - n) = xs ! (m - n) \<and> m - n < length xs" by auto

  3853     then have "\<exists>q. [n..<n + length xs] ! q = m \<and>

  3854         xs ! q = xs ! (m - n) \<and> q < length xs" ..

  3855   } then show ?thesis by (cases p) (auto simp add: enumerate_eq_zip in_set_zip)

  3856 qed

  3857

  3858 lemma nth_enumerate_eq:

  3859   assumes "m < length xs"

  3860   shows "enumerate n xs ! m = (n + m, xs ! m)"

  3861   using assms by (simp add: enumerate_eq_zip)

  3862

  3863 lemma enumerate_replicate_eq:

  3864   "enumerate n (replicate m a) = map (\<lambda>q. (q, a)) [n..<n + m]"

  3865   by (rule pair_list_eqI)

  3866     (simp_all add: enumerate_eq_zip comp_def map_replicate_const)

  3867

  3868 lemma enumerate_Suc_eq:

  3869   "enumerate (Suc n) xs = map (apfst Suc) (enumerate n xs)"

  3870   by (rule pair_list_eqI)

  3871     (simp_all add: not_le, simp del: map_map [simp del] add: map_Suc_upt map_map [symmetric])

  3872

  3873 lemma distinct_enumerate [simp]:

  3874   "distinct (enumerate n xs)"

  3875   by (simp add: enumerate_eq_zip distinct_zipI1)

  3876

  3877

  3878 subsubsection {* @{const rotate1} and @{const rotate} *}

  3879

  3880 lemma rotate0[simp]: "rotate 0 = id"

  3881 by(simp add:rotate_def)

  3882

  3883 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"

  3884 by(simp add:rotate_def)

  3885

  3886 lemma rotate_add:

  3887   "rotate (m+n) = rotate m o rotate n"

  3888 by(simp add:rotate_def funpow_add)

  3889

  3890 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"

  3891 by(simp add:rotate_add)

  3892

  3893 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"

  3894 by(simp add:rotate_def funpow_swap1)

  3895

  3896 lemma rotate1_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate1 xs = xs"

  3897 by(cases xs) simp_all

  3898

  3899 lemma rotate_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate n xs = xs"

  3900 apply(induct n)

  3901  apply simp

  3902 apply (simp add:rotate_def)

  3903 done

  3904

  3905 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"

  3906 by (cases xs) simp_all

  3907

  3908 lemma rotate_drop_take:

  3909   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"

  3910 apply(induct n)

  3911  apply simp

  3912 apply(simp add:rotate_def)

  3913 apply(cases "xs = []")

  3914  apply (simp)

  3915 apply(case_tac "n mod length xs = 0")

  3916  apply(simp add:mod_Suc)

  3917  apply(simp add: rotate1_hd_tl drop_Suc take_Suc)

  3918 apply(simp add:mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]

  3919                 take_hd_drop linorder_not_le)

  3920 done

  3921

  3922 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"

  3923 by(simp add:rotate_drop_take)

  3924

  3925 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"

  3926 by(simp add:rotate_drop_take)

  3927

  3928 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"

  3929 by (cases xs) simp_all

  3930

  3931 lemma length_rotate[simp]: "length(rotate n xs) = length xs"

  3932 by (induct n arbitrary: xs) (simp_all add:rotate_def)

  3933

  3934 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"

  3935 by (cases xs) auto

  3936

  3937 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"

  3938 by (induct n) (simp_all add:rotate_def)

  3939

  3940 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"

  3941 by(simp add:rotate_drop_take take_map drop_map)

  3942

  3943 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"

  3944 by (cases xs) auto

  3945

  3946 lemma set_rotate[simp]: "set(rotate n xs) = set xs"

  3947 by (induct n) (simp_all add:rotate_def)

  3948

  3949 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"

  3950 by (cases xs) auto

  3951

  3952 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"

  3953 by (induct n) (simp_all add:rotate_def)

  3954

  3955 lemma rotate_rev:

  3956   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"

  3957 apply(simp add:rotate_drop_take rev_drop rev_take)

  3958 apply(cases "length xs = 0")

  3959  apply simp

  3960 apply(cases "n mod length xs = 0")

  3961  apply simp

  3962 apply(simp add:rotate_drop_take rev_drop rev_take)

  3963 done

  3964

  3965 lemma hd_rotate_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd(rotate n xs) = xs!(n mod length xs)"

  3966 apply(simp add:rotate_drop_take hd_append hd_drop_conv_nth hd_conv_nth)

  3967 apply(subgoal_tac "length xs \<noteq> 0")

  3968  prefer 2 apply simp

  3969 using mod_less_divisor[of "length xs" n] by arith

  3970

  3971

  3972 subsubsection {* @{const sublist} --- a generalization of @{const nth} to sets *}

  3973

  3974 lemma sublist_empty [simp]: "sublist xs {} = []"

  3975 by (auto simp add: sublist_def)

  3976

  3977 lemma sublist_nil [simp]: "sublist [] A = []"

  3978 by (auto simp add: sublist_def)

  3979

  3980 lemma length_sublist:

  3981   "length(sublist xs I) = card{i. i < length xs \<and> i : I}"

  3982 by(simp add: sublist_def length_filter_conv_card cong:conj_cong)

  3983

  3984 lemma sublist_shift_lemma_Suc:

  3985   "map fst (filter (%p. P(Suc(snd p))) (zip xs is)) =

  3986    map fst (filter (%p. P(snd p)) (zip xs (map Suc is)))"

  3987 apply(induct xs arbitrary: "is")

  3988  apply simp

  3989 apply (case_tac "is")

  3990  apply simp

  3991 apply simp

  3992 done

  3993

  3994 lemma sublist_shift_lemma:

  3995      "map fst [p<-zip xs [i..<i + length xs] . snd p : A] =

  3996       map fst [p<-zip xs [0..<length xs] . snd p + i : A]"

  3997 by (induct xs rule: rev_induct) (simp_all add: add_commute)

  3998

  3999 lemma sublist_append:

  4000      "sublist (l @ l') A = sublist l A @ sublist l' {j. j + length l : A}"

  4001 apply (unfold sublist_def)

  4002 apply (induct l' rule: rev_induct, simp)

  4003 apply (simp add: upt_add_eq_append[of 0] sublist_shift_lemma)

  4004 apply (simp add: add_commute)

  4005 done

  4006

  4007 lemma sublist_Cons:

  4008 "sublist (x # l) A = (if 0:A then [x] else []) @ sublist l {j. Suc j : A}"

  4009 apply (induct l rule: rev_induct)

  4010  apply (simp add: sublist_def)

  4011 apply (simp del: append_Cons add: append_Cons[symmetric] sublist_append)

  4012 done

  4013

  4014 lemma set_sublist: "set(sublist xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"

  4015 apply(induct xs arbitrary: I)

  4016 apply(auto simp: sublist_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)

  4017 done

  4018

  4019 lemma set_sublist_subset: "set(sublist xs I) \<subseteq> set xs"

  4020 by(auto simp add:set_sublist)

  4021

  4022 lemma notin_set_sublistI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(sublist xs I)"

  4023 by(auto simp add:set_sublist)

  4024

  4025 lemma in_set_sublistD: "x \<in> set(sublist xs I) \<Longrightarrow> x \<in> set xs"

  4026 by(auto simp add:set_sublist)

  4027

  4028 lemma sublist_singleton [simp]: "sublist [x] A = (if 0 : A then [x] else [])"

  4029 by (simp add: sublist_Cons)

  4030

  4031

  4032 lemma distinct_sublistI[simp]: "distinct xs \<Longrightarrow> distinct(sublist xs I)"

  4033 apply(induct xs arbitrary: I)

  4034  apply simp

  4035 apply(auto simp add:sublist_Cons)

  4036 done

  4037

  4038

  4039 lemma sublist_upt_eq_take [simp]: "sublist l {..<n} = take n l"

  4040 apply (induct l rule: rev_induct, simp)

  4041 apply (simp split: nat_diff_split add: sublist_append)

  4042 done

  4043

  4044 lemma filter_in_sublist:

  4045  "distinct xs \<Longrightarrow> filter (%x. x \<in> set(sublist xs s)) xs = sublist xs s"

  4046 proof (induct xs arbitrary: s)

  4047   case Nil thus ?case by simp

  4048 next

  4049   case (Cons a xs)

  4050   moreover hence "!x. x: set xs \<longrightarrow> x \<noteq> a" by auto

  4051   ultimately show ?case by(simp add: sublist_Cons cong:filter_cong)

  4052 qed

  4053

  4054

  4055 subsubsection {* @{const sublists} and @{const List.n_lists} *}

  4056

  4057 lemma length_sublists:

  4058   "length (sublists xs) = 2 ^ length xs"

  4059   by (induct xs) (simp_all add: Let_def)

  4060

  4061 lemma sublists_powset:

  4062   "set  set (sublists xs) = Pow (set xs)"

  4063 proof -

  4064   have aux: "\<And>x A. set  Cons x  A = insert x  set  A"

  4065     by (auto simp add: image_def)

  4066   have "set (map set (sublists xs)) = Pow (set xs)"

  4067     by (induct xs)

  4068       (simp_all add: aux Let_def Pow_insert Un_commute comp_def del: map_map)

  4069   then show ?thesis by simp

  4070 qed

  4071

  4072 lemma distinct_set_sublists:

  4073   assumes "distinct xs"

  4074   shows "distinct (map set (sublists xs))"

  4075 proof (rule card_distinct)

  4076   have "finite (set xs)" by rule

  4077   then have "card (Pow (set xs)) = 2 ^ card (set xs)" by (rule card_Pow)

  4078   with assms distinct_card [of xs]

  4079     have "card (Pow (set xs)) = 2 ^ length xs" by simp

  4080   then show "card (set (map set (sublists xs))) = length (map set (sublists xs))"

  4081     by (simp add: sublists_powset length_sublists)

  4082 qed

  4083

  4084 lemma n_lists_Nil [simp]: "List.n_lists n [] = (if n = 0 then [[]] else [])"

  4085   by (induct n) simp_all

  4086

  4087 lemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n"

  4088   by (induct n) (auto simp add: length_concat o_def listsum_triv)

  4089

  4090 lemma length_n_lists_elem: "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"

  4091   by (induct n arbitrary: ys) auto

  4092

  4093 lemma set_n_lists: "set (List.n_lists n xs) = {ys. length ys = n \<and> set ys \<subseteq> set xs}"

  4094 proof (rule set_eqI)

  4095   fix ys :: "'a list"

  4096   show "ys \<in> set (List.n_lists n xs) \<longleftrightarrow> ys \<in> {ys. length ys = n \<and> set ys \<subseteq> set xs}"

  4097   proof -

  4098     have "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"

  4099       by (induct n arbitrary: ys) auto

  4100     moreover have "\<And>x. ys \<in> set (List.n_lists n xs) \<Longrightarrow> x \<in> set ys \<Longrightarrow> x \<in> set xs"

  4101       by (induct n arbitrary: ys) auto

  4102     moreover have "set ys \<subseteq> set xs \<Longrightarrow> ys \<in> set (List.n_lists (length ys) xs)"

  4103       by (induct ys) auto

  4104     ultimately show ?thesis by auto

  4105   qed

  4106 qed

  4107

  4108 lemma distinct_n_lists:

  4109   assumes "distinct xs"

  4110   shows "distinct (List.n_lists n xs)"

  4111 proof (rule card_distinct)

  4112   from assms have card_length: "card (set xs) = length xs" by (rule distinct_card)

  4113   have "card (set (List.n_lists n xs)) = card (set xs) ^ n"

  4114   proof (induct n)

  4115     case 0 then show ?case by simp

  4116   next

  4117     case (Suc n)

  4118     moreover have "card (\<Union>ys\<in>set (List.n_lists n xs). (\<lambda>y. y # ys)  set xs)

  4119       = (\<Sum>ys\<in>set (List.n_lists n xs). card ((\<lambda>y. y # ys)  set xs))"

  4120       by (rule card_UN_disjoint) auto

  4121     moreover have "\<And>ys. card ((\<lambda>y. y # ys)  set xs) = card (set xs)"

  4122       by (rule card_image) (simp add: inj_on_def)

  4123     ultimately show ?case by auto

  4124   qed

  4125   also have "\<dots> = length xs ^ n" by (simp add: card_length)

  4126   finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)"

  4127     by (simp add: length_n_lists)

  4128 qed

  4129

  4130

  4131 subsubsection {* @{const splice} *}

  4132

  4133 lemma splice_Nil2 [simp, code]: "splice xs [] = xs"

  4134 by (cases xs) simp_all

  4135

  4136 declare splice.simps(1,3)[code]

  4137 declare splice.simps(2)[simp del]

  4138

  4139 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"

  4140 by (induct xs ys rule: splice.induct) auto

  4141

  4142

  4143 subsubsection {* Transpose *}

  4144

  4145 function transpose where

  4146 "transpose []             = []" |

  4147 "transpose ([]     # xss) = transpose xss" |

  4148 "transpose ((x#xs) # xss) =

  4149   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"

  4150 by pat_completeness auto

  4151

  4152 lemma transpose_aux_filter_head:

  4153   "concat (map (list_case [] (\<lambda>h t. [h])) xss) =

  4154   map (\<lambda>xs. hd xs) [ys\<leftarrow>xss . ys \<noteq> []]"

  4155   by (induct xss) (auto split: list.split)

  4156

  4157 lemma transpose_aux_filter_tail:

  4158   "concat (map (list_case [] (\<lambda>h t. [t])) xss) =

  4159   map (\<lambda>xs. tl xs) [ys\<leftarrow>xss . ys \<noteq> []]"

  4160   by (induct xss) (auto split: list.split)

  4161

  4162 lemma transpose_aux_max:

  4163   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =

  4164   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) [ys\<leftarrow>xss . ys\<noteq>[]] 0))"

  4165   (is "max _ ?foldB = Suc (max _ ?foldA)")

  4166 proof (cases "[ys\<leftarrow>xss . ys\<noteq>[]] = []")

  4167   case True

  4168   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"

  4169   proof (induct xss)

  4170     case (Cons x xs)

  4171     moreover hence "x = []" by (cases x) auto

  4172     ultimately show ?case by auto

  4173   qed simp

  4174   thus ?thesis using True by simp

  4175 next

  4176   case False

  4177

  4178   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0 - 1"

  4179     by (induct xss) auto

  4180   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0"

  4181     by (induct xss) auto

  4182

  4183   have "0 < ?foldB"

  4184   proof -

  4185     from False

  4186     obtain z zs where zs: "[ys\<leftarrow>xss . ys \<noteq> []] = z#zs" by (auto simp: neq_Nil_conv)

  4187     hence "z \<in> set ([ys\<leftarrow>xss . ys \<noteq> []])" by auto

  4188     hence "z \<noteq> []" by auto

  4189     thus ?thesis

  4190       unfolding foldB zs

  4191       by (auto simp: max_def intro: less_le_trans)

  4192   qed

  4193   thus ?thesis

  4194     unfolding foldA foldB max_Suc_Suc[symmetric]

  4195     by simp

  4196 qed

  4197

  4198 termination transpose

  4199   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")

  4200      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)

  4201

  4202 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"

  4203   by (induct rule: transpose.induct) simp_all

  4204

  4205 lemma length_transpose:

  4206   fixes xs :: "'a list list"

  4207   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"

  4208   by (induct rule: transpose.induct)

  4209     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max

  4210                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)

  4211

  4212 lemma nth_transpose:

  4213   fixes xs :: "'a list list"

  4214   assumes "i < length (transpose xs)"

  4215   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) [ys \<leftarrow> xs. i < length ys]"

  4216 using assms proof (induct arbitrary: i rule: transpose.induct)

  4217   case (3 x xs xss)

  4218   def XS == "(x # xs) # xss"

  4219   hence [simp]: "XS \<noteq> []" by auto

  4220   thus ?case

  4221   proof (cases i)

  4222     case 0

  4223     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)

  4224   next

  4225     case (Suc j)

  4226     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp

  4227     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp

  4228     { fix x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"

  4229       by (cases x) simp_all

  4230     } note *** = this

  4231

  4232     have j_less: "j < length (transpose (xs # concat (map (list_case [] (\<lambda>h t. [t])) xss)))"

  4233       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)

  4234

  4235     show ?thesis

  4236       unfolding transpose.simps i = Suc j nth_Cons_Suc "3.hyps"[OF j_less]

  4237       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])

  4238       apply (rule_tac y=x in list.exhaust)

  4239       by auto

  4240   qed

  4241 qed simp_all

  4242

  4243 lemma transpose_map_map:

  4244   "transpose (map (map f) xs) = map (map f) (transpose xs)"

  4245 proof (rule nth_equalityI, safe)

  4246   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"

  4247     by (simp add: length_transpose foldr_map comp_def)

  4248   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp

  4249

  4250   fix i assume "i < length (transpose (map (map f) xs))"

  4251   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"

  4252     by (simp add: nth_transpose filter_map comp_def)

  4253 qed

  4254

  4255

  4256 subsubsection {* (In)finiteness *}

  4257

  4258 lemma finite_maxlen:

  4259   "finite (M::'a list set) ==> EX n. ALL s:M. size s < n"

  4260 proof (induct rule: finite.induct)

  4261   case emptyI show ?case by simp

  4262 next

  4263   case (insertI M xs)

  4264   then obtain n where "\<forall>s\<in>M. length s < n" by blast

  4265   hence "ALL s:insert xs M. size s < max n (size xs) + 1" by auto

  4266   thus ?case ..

  4267 qed

  4268

  4269 lemma lists_length_Suc_eq:

  4270   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =

  4271     (\<lambda>(xs, n). n#xs)  ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"

  4272   by (auto simp: length_Suc_conv)

  4273

  4274 lemma

  4275   assumes "finite A"

  4276   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"

  4277   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"

  4278   using finite A

  4279   by (induct n)

  4280      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)

  4281

  4282 lemma finite_lists_length_le:

  4283   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"

  4284  (is "finite ?S")

  4285 proof-

  4286   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto

  4287   thus ?thesis by (auto intro!: finite_lists_length_eq[OF finite A] simp only:)

  4288 qed

  4289

  4290 lemma card_lists_length_le:

  4291   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"

  4292 proof -

  4293   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"

  4294     using finite A

  4295     by (subst card_UN_disjoint)

  4296        (auto simp add: card_lists_length_eq finite_lists_length_eq)

  4297   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}"

  4298     by auto

  4299   finally show ?thesis by simp

  4300 qed

  4301

  4302 lemma card_lists_distinct_length_eq:

  4303   assumes "k < card A"

  4304   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"

  4305 using assms

  4306 proof (induct k)

  4307   case 0

  4308   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto

  4309   then show ?case by simp

  4310 next

  4311   case (Suc k)

  4312   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"

  4313   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto

  4314

  4315   from Suc have "k < card A" by simp

  4316   moreover have "finite A" using assms by (simp add: card_ge_0_finite)

  4317   moreover have "finite {xs. ?k_list k xs}"

  4318     using finite_lists_length_eq[OF finite A, of k]

  4319     by - (rule finite_subset, auto)

  4320   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"

  4321     by auto

  4322   moreover have "\<And>i. i \<in>Collect (?k_list k) \<Longrightarrow> card (A - set i) = card A - k"

  4323     by (simp add: card_Diff_subset distinct_card)

  4324   moreover have "{xs. ?k_list (Suc k) xs} =

  4325       (\<lambda>(xs, n). n#xs)  \<Union>((\<lambda>xs. {xs} \<times> (A - set xs))  {xs. ?k_list k xs})"

  4326     by (auto simp: length_Suc_conv)

  4327   moreover

  4328   have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp

  4329   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"

  4330     by (subst setprod_insert[symmetric]) (simp add: atLeastAtMost_insertL)+

  4331   ultimately show ?case

  4332     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)

  4333 qed

  4334

  4335 lemma infinite_UNIV_listI: "~ finite(UNIV::'a list set)"

  4336 apply(rule notI)

  4337 apply(drule finite_maxlen)

  4338 apply (metis UNIV_I length_replicate less_not_refl)

  4339 done

  4340

  4341

  4342 subsection {* Sorting *}

  4343

  4344 text{* Currently it is not shown that @{const sort} returns a

  4345 permutation of its input because the nicest proof is via multisets,

  4346 which are not yet available. Alternatively one could define a function

  4347 that counts the number of occurrences of an element in a list and use

  4348 that instead of multisets to state the correctness property. *}

  4349

  4350 context linorder

  4351 begin

  4352

  4353 lemma set_insort_key:

  4354   "set (insort_key f x xs) = insert x (set xs)"

  4355   by (induct xs) auto

  4356

  4357 lemma length_insort [simp]:

  4358   "length (insort_key f x xs) = Suc (length xs)"

  4359   by (induct xs) simp_all

  4360

  4361 lemma insort_key_left_comm:

  4362   assumes "f x \<noteq> f y"

  4363   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"

  4364   by (induct xs) (auto simp add: assms dest: antisym)

  4365

  4366 lemma insort_left_comm:

  4367   "insort x (insort y xs) = insort y (insort x xs)"

  4368   by (cases "x = y") (auto intro: insort_key_left_comm)

  4369

  4370 lemma comp_fun_commute_insort:

  4371   "comp_fun_commute insort"

  4372 proof

  4373 qed (simp add: insort_left_comm fun_eq_iff)

  4374

  4375 lemma sort_key_simps [simp]:

  4376   "sort_key f [] = []"

  4377   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"

  4378   by (simp_all add: sort_key_def)

  4379

  4380 lemma (in linorder) sort_key_conv_fold:

  4381   assumes "inj_on f (set xs)"

  4382   shows "sort_key f xs = fold (insort_key f) xs []"

  4383 proof -

  4384   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"

  4385   proof (rule fold_rev, rule ext)

  4386     fix zs

  4387     fix x y

  4388     assume "x \<in> set xs" "y \<in> set xs"

  4389     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)

  4390     have **: "x = y \<longleftrightarrow> y = x" by auto

  4391     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"

  4392       by (induct zs) (auto intro: * simp add: **)

  4393   qed

  4394   then show ?thesis by (simp add: sort_key_def foldr_conv_fold)

  4395 qed

  4396

  4397 lemma (in linorder) sort_conv_fold:

  4398   "sort xs = fold insort xs []"

  4399   by (rule sort_key_conv_fold) simp

  4400

  4401 lemma length_sort[simp]: "length (sort_key f xs) = length xs"

  4402 by (induct xs, auto)

  4403

  4404 lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"

  4405 apply(induct xs arbitrary: x) apply simp

  4406 by simp (blast intro: order_trans)

  4407

  4408 lemma sorted_tl:

  4409   "sorted xs \<Longrightarrow> sorted (tl xs)"

  4410   by (cases xs) (simp_all add: sorted_Cons)

  4411

  4412 lemma sorted_append:

  4413   "sorted (xs@ys) = (sorted xs & sorted ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"

  4414 by (induct xs) (auto simp add:sorted_Cons)

  4415

  4416 lemma sorted_nth_mono:

  4417   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"

  4418 by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)

  4419

  4420 lemma sorted_rev_nth_mono:

  4421   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"

  4422 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]

  4423       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]

  4424 by auto

  4425

  4426 lemma sorted_nth_monoI:

  4427   "(\<And> i j. \<lbrakk> i \<le> j ; j < length xs \<rbrakk> \<Longrightarrow> xs ! i \<le> xs ! j) \<Longrightarrow> sorted xs"

  4428 proof (induct xs)

  4429   case (Cons x xs)

  4430   have "sorted xs"

  4431   proof (rule Cons.hyps)

  4432     fix i j assume "i \<le> j" and "j < length xs"

  4433     with Cons.prems[of "Suc i" "Suc j"]

  4434     show "xs ! i \<le> xs ! j" by auto

  4435   qed

  4436   moreover

  4437   {

  4438     fix y assume "y \<in> set xs"

  4439     then obtain j where "j < length xs" and "xs ! j = y"

  4440       unfolding in_set_conv_nth by blast

  4441     with Cons.prems[of 0 "Suc j"]

  4442     have "x \<le> y"

  4443       by auto

  4444   }

  4445   ultimately

  4446   show ?case

  4447     unfolding sorted_Cons by auto

  4448 qed simp

  4449

  4450 lemma sorted_equals_nth_mono:

  4451   "sorted xs = (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"

  4452 by (auto intro: sorted_nth_monoI sorted_nth_mono)

  4453

  4454 lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"

  4455 by (induct xs) auto

  4456

  4457 lemma set_sort[simp]: "set(sort_key f xs) = set xs"

  4458 by (induct xs) (simp_all add:set_insort)

  4459

  4460 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"

  4461 by(induct xs)(auto simp:set_insort)

  4462

  4463 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"

  4464   by (induct xs) (simp_all add: distinct_insort)

  4465

  4466 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"

  4467   by (induct xs) (auto simp:sorted_Cons set_insort)

  4468

  4469 lemma sorted_insort: "sorted (insort x xs) = sorted xs"

  4470   using sorted_insort_key [where f="\<lambda>x. x"] by simp

  4471

  4472 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"

  4473   by (induct xs) (auto simp:sorted_insort_key)

  4474

  4475 theorem sorted_sort [simp]: "sorted (sort xs)"

  4476   using sorted_sort_key [where f="\<lambda>x. x"] by simp

  4477

  4478 lemma sorted_butlast:

  4479   assumes "xs \<noteq> []" and "sorted xs"

  4480   shows "sorted (butlast xs)"

  4481 proof -

  4482   from xs \<noteq> [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto

  4483   with sorted xs show ?thesis by (simp add: sorted_append)

  4484 qed

  4485

  4486 lemma insort_not_Nil [simp]:

  4487   "insort_key f a xs \<noteq> []"

  4488   by (induct xs) simp_all

  4489

  4490 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"

  4491 by (cases xs) auto

  4492

  4493 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"

  4494   by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)

  4495

  4496 lemma sorted_map_remove1:

  4497   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"

  4498   by (induct xs) (auto simp add: sorted_Cons)

  4499

  4500 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"

  4501   using sorted_map_remove1 [of "\<lambda>x. x"] by simp

  4502

  4503 lemma insort_key_remove1:

  4504   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"

  4505   shows "insort_key f a (remove1 a xs) = xs"

  4506 using assms proof (induct xs)

  4507   case (Cons x xs)

  4508   then show ?case

  4509   proof (cases "x = a")

  4510     case False

  4511     then have "f x \<noteq> f a" using Cons.prems by auto

  4512     then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons)

  4513     with f x \<noteq> f a show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons)

  4514   qed (auto simp: sorted_Cons insort_is_Cons)

  4515 qed simp

  4516

  4517 lemma insort_remove1:

  4518   assumes "a \<in> set xs" and "sorted xs"

  4519   shows "insort a (remove1 a xs) = xs"

  4520 proof (rule insort_key_remove1)

  4521   from a \<in> set xs show "a \<in> set xs" .

  4522   from sorted xs show "sorted (map (\<lambda>x. x) xs)" by simp

  4523   from a \<in> set xs have "a \<in> set (filter (op = a) xs)" by auto

  4524   then have "set (filter (op = a) xs) \<noteq> {}" by auto

  4525   then have "filter (op = a) xs \<noteq> []" by (auto simp only: set_empty)

  4526   then have "length (filter (op = a) xs) > 0" by simp

  4527   then obtain n where n: "Suc n = length (filter (op = a) xs)"

  4528     by (cases "length (filter (op = a) xs)") simp_all

  4529   moreover have "replicate (Suc n) a = a # replicate n a"

  4530     by simp

  4531   ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)

  4532 qed

  4533

  4534 lemma sorted_remdups[simp]:

  4535   "sorted l \<Longrightarrow> sorted (remdups l)"

  4536 by (induct l) (auto simp: sorted_Cons)

  4537

  4538 lemma sorted_distinct_set_unique:

  4539 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"

  4540 shows "xs = ys"

  4541 proof -

  4542   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)

  4543   from assms show ?thesis

  4544   proof(induct rule:list_induct2[OF 1])

  4545     case 1 show ?case by simp

  4546   next

  4547     case 2 thus ?case by (simp add:sorted_Cons)

  4548        (metis Diff_insert_absorb antisym insertE insert_iff)

  4549   qed

  4550 qed

  4551

  4552 lemma map_sorted_distinct_set_unique:

  4553   assumes "inj_on f (set xs \<union> set ys)"

  4554   assumes "sorted (map f xs)" "distinct (map f xs)"

  4555     "sorted (map f ys)" "distinct (map f ys)"

  4556   assumes "set xs = set ys"

  4557   shows "xs = ys"

  4558 proof -

  4559   from assms have "map f xs = map f ys"

  4560     by (simp add: sorted_distinct_set_unique)

  4561   moreover with inj_on f (set xs \<union> set ys) show "xs = ys"

  4562     by (blast intro: map_inj_on)

  4563 qed

  4564

  4565 lemma finite_sorted_distinct_unique:

  4566 shows "finite A \<Longrightarrow> EX! xs. set xs = A & sorted xs & distinct xs"

  4567 apply(drule finite_distinct_list)

  4568 apply clarify

  4569 apply(rule_tac a="sort xs" in ex1I)

  4570 apply (auto simp: sorted_distinct_set_unique)

  4571 done

  4572

  4573 lemma

  4574   assumes "sorted xs"

  4575   shows sorted_take: "sorted (take n xs)"

  4576   and sorted_drop: "sorted (drop n xs)"

  4577 proof -

  4578   from assms have "sorted (take n xs @ drop n xs)" by simp

  4579   then show "sorted (take n xs)" and "sorted (drop n xs)"

  4580     unfolding sorted_append by simp_all

  4581 qed

  4582

  4583 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"

  4584   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)

  4585

  4586 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"

  4587   by (subst takeWhile_eq_take) (auto dest: sorted_take)

  4588

  4589 lemma sorted_filter:

  4590   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"

  4591   by (induct xs) (simp_all add: sorted_Cons)

  4592

  4593 lemma foldr_max_sorted:

  4594   assumes "sorted (rev xs)"

  4595   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"

  4596 using assms proof (induct xs)

  4597   case (Cons x xs)

  4598   moreover hence "sorted (rev xs)" using sorted_append by auto

  4599   ultimately show ?case

  4600     by (cases xs, auto simp add: sorted_append max_def)

  4601 qed simp

  4602

  4603 lemma filter_equals_takeWhile_sorted_rev:

  4604   assumes sorted: "sorted (rev (map f xs))"

  4605   shows "[x \<leftarrow> xs. t < f x] = takeWhile (\<lambda> x. t < f x) xs"

  4606     (is "filter ?P xs = ?tW")

  4607 proof (rule takeWhile_eq_filter[symmetric])

  4608   let "?dW" = "dropWhile ?P xs"

  4609   fix x assume "x \<in> set ?dW"

  4610   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"

  4611     unfolding in_set_conv_nth by auto

  4612   hence "length ?tW + i < length (?tW @ ?dW)"

  4613     unfolding length_append by simp

  4614   hence i': "length (map f ?tW) + i < length (map f xs)" by simp

  4615   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>

  4616         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"

  4617     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]

  4618     unfolding map_append[symmetric] by simp

  4619   hence "f x \<le> f (?dW ! 0)"

  4620     unfolding nth_append_length_plus nth_i

  4621     using i preorder_class.le_less_trans[OF le0 i] by simp

  4622   also have "... \<le> t"

  4623     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]

  4624     using hd_conv_nth[of "?dW"] by simp

  4625   finally show "\<not> t < f x" by simp

  4626 qed

  4627

  4628 lemma insort_insert_key_triv:

  4629   "f x \<in> f  set xs \<Longrightarrow> insort_insert_key f x xs = xs"

  4630   by (simp add: insort_insert_key_def)

  4631

  4632 lemma insort_insert_triv:

  4633   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"

  4634   using insort_insert_key_triv [of "\<lambda>x. x"] by simp

  4635

  4636 lemma insort_insert_insort_key:

  4637   "f x \<notin> f  set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"

  4638   by (simp add: insort_insert_key_def)

  4639

  4640 lemma insort_insert_insort:

  4641   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"

  4642   using insort_insert_insort_key [of "\<lambda>x. x"] by simp

  4643

  4644 lemma set_insort_insert:

  4645   "set (insort_insert x xs) = insert x (set xs)"

  4646   by (auto simp add: insort_insert_key_def set_insort)

  4647

  4648 lemma distinct_insort_insert:

  4649   assumes "distinct xs"

  4650   shows "distinct (insort_insert_key f x xs)"

  4651   using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)

  4652

  4653 lemma sorted_insort_insert_key:

  4654   assumes "sorted (map f xs)"

  4655   shows "sorted (map f (insort_insert_key f x xs))"

  4656   using assms by (simp add: insort_insert_key_def sorted_insort_key)

  4657

  4658 lemma sorted_insort_insert:

  4659   assumes "sorted xs"

  4660   shows "sorted (insort_insert x xs)"

  4661   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp

  4662

  4663 lemma filter_insort_triv:

  4664   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"

  4665   by (induct xs) simp_all

  4666

  4667 lemma filter_insort:

  4668   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"

  4669   using assms by (induct xs)

  4670     (auto simp add: sorted_Cons, subst insort_is_Cons, auto)

  4671

  4672 lemma filter_sort:

  4673   "filter P (sort_key f xs) = sort_key f (filter P xs)"

  4674   by (induct xs) (simp_all add: filter_insort_triv filter_insort)

  4675

  4676 lemma sorted_map_same:

  4677   "sorted (map f [x\<leftarrow>xs. f x = g xs])"

  4678 proof (induct xs arbitrary: g)

  4679   case Nil then show ?case by simp

  4680 next

  4681   case (Cons x xs)

  4682   then have "sorted (map f [y\<leftarrow>xs . f y = (\<lambda>xs. f x) xs])" .

  4683   moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g \<circ> Cons x) xs])" .

  4684   ultimately show ?case by (simp_all add: sorted_Cons)

  4685 qed

  4686

  4687 lemma sorted_same:

  4688   "sorted [x\<leftarrow>xs. x = g xs]"

  4689   using sorted_map_same [of "\<lambda>x. x"] by simp

  4690

  4691 lemma remove1_insort [simp]:

  4692   "remove1 x (insort x xs) = xs"

  4693   by (induct xs) simp_all

  4694

  4695 end

  4696

  4697 lemma sorted_upt[simp]: "sorted[i..<j]"

  4698 by (induct j) (simp_all add:sorted_append)

  4699

  4700 lemma sorted_upto[simp]: "sorted[i..j]"

  4701 apply(induct i j rule:upto.induct)

  4702 apply(subst upto.simps)

  4703 apply(simp add:sorted_Cons)

  4704 done

  4705

  4706 lemma sorted_find_Min:

  4707   assumes "sorted xs"

  4708   assumes "\<exists>x \<in> set xs. P x"

  4709   shows "List.find P xs = Some (Min {x\<in>set xs. P x})"

  4710 using assms proof (induct xs rule: sorted.induct)

  4711   case Nil then show ?case by simp

  4712 next

  4713   case (Cons xs x) show ?case proof (cases "P x")

  4714     case True with Cons show ?thesis by (auto intro: Min_eqI [symmetric])

  4715   next

  4716     case False then have "{y. (y = x \<or> y \<in> set xs) \<and> P y} = {y \<in> set xs. P y}"

  4717       by auto

  4718     with Cons False show ?thesis by simp_all

  4719   qed

  4720 qed

  4721

  4722

  4723 subsubsection {* @{const transpose} on sorted lists *}

  4724

  4725 lemma sorted_transpose[simp]:

  4726   shows "sorted (rev (map length (transpose xs)))"

  4727   by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose

  4728     length_filter_conv_card intro: card_mono)

  4729

  4730 lemma transpose_max_length:

  4731   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x \<noteq> []]"

  4732   (is "?L = ?R")

  4733 proof (cases "transpose xs = []")

  4734   case False

  4735   have "?L = foldr max (map length (transpose xs)) 0"

  4736     by (simp add: foldr_map comp_def)

  4737   also have "... = length (transpose xs ! 0)"

  4738     using False sorted_transpose by (simp add: foldr_max_sorted)

  4739   finally show ?thesis

  4740     using False by (simp add: nth_transpose)

  4741 next

  4742   case True

  4743   hence "[x \<leftarrow> xs. x \<noteq> []] = []"

  4744     by (auto intro!: filter_False simp: transpose_empty)

  4745   thus ?thesis by (simp add: transpose_empty True)

  4746 qed

  4747

  4748 lemma length_transpose_sorted:

  4749   fixes xs :: "'a list list"

  4750   assumes sorted: "sorted (rev (map length xs))"

  4751   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"

  4752 proof (cases "xs = []")

  4753   case False

  4754   thus ?thesis

  4755     using foldr_max_sorted[OF sorted] False

  4756     unfolding length_transpose foldr_map comp_def

  4757     by simp

  4758 qed simp

  4759

  4760 lemma nth_nth_transpose_sorted[simp]:

  4761   fixes xs :: "'a list list"

  4762   assumes sorted: "sorted (rev (map length xs))"

  4763   and i: "i < length (transpose xs)"

  4764   and j: "j < length [ys \<leftarrow> xs. i < length ys]"

  4765   shows "transpose xs ! i ! j = xs ! j  ! i"

  4766   using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]

  4767     nth_transpose[OF i] nth_map[OF j]

  4768   by (simp add: takeWhile_nth)

  4769

  4770 lemma transpose_column_length:

  4771   fixes xs :: "'a list list"

  4772   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"

  4773   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"

  4774 proof -

  4775   have "xs \<noteq> []" using i < length xs by auto

  4776   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]

  4777   { fix j assume "j \<le> i"

  4778     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this i < length xs]

  4779   } note sortedE = this[consumes 1]

  4780

  4781   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}

  4782     = {..< length (xs ! i)}"

  4783   proof safe

  4784     fix j

  4785     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"

  4786     with this(2) nth_transpose[OF this(1)]

  4787     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp

  4788     from nth_mem[OF this] takeWhile_nth[OF this]

  4789     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)

  4790   next

  4791     fix j assume "j < length (xs ! i)"

  4792     thus "j < length (transpose xs)"

  4793       using foldr_max_sorted[OF sorted] xs \<noteq> [] sortedE[OF le0]

  4794       by (auto simp: length_transpose comp_def foldr_map)

  4795

  4796     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"

  4797       using i < length xs j < length (xs ! i) less_Suc_eq_le

  4798       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)

  4799     with nth_transpose[OF j < length (transpose xs)]

  4800     show "i < length (transpose xs ! j)" by simp

  4801   qed

  4802   thus ?thesis by (simp add: length_filter_conv_card)

  4803 qed

  4804

  4805 lemma transpose_column:

  4806   fixes xs :: "'a list list"

  4807   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"

  4808   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))

  4809     = xs ! i" (is "?R = _")

  4810 proof (rule nth_equalityI, safe)

  4811   show length: "length ?R = length (xs ! i)"

  4812     using transpose_column_length[OF assms] by simp

  4813

  4814   fix j assume j: "j < length ?R"

  4815   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]

  4816   from j have j_less: "j < length (xs ! i)" using length by simp

  4817   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"

  4818   proof (rule length_takeWhile_less_P_nth)

  4819     show "Suc i \<le> length xs" using i < length xs by simp

  4820     fix k assume "k < Suc i"

  4821     hence "k \<le> i" by auto

  4822     with sorted_rev_nth_mono[OF sorted this] i < length xs

  4823     have "length (xs ! i) \<le> length (xs ! k)" by simp

  4824     thus "Suc j \<le> length (xs ! k)" using j_less by simp

  4825   qed

  4826   have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]"

  4827     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]

  4828     using i_less_tW by (simp_all add: Suc_le_eq)

  4829   from j show "?R ! j = xs ! i ! j"

  4830     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]

  4831     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])

  4832 qed

  4833

  4834 lemma transpose_transpose:

  4835   fixes xs :: "'a list list"

  4836   assumes sorted: "sorted (rev (map length xs))"

  4837   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")

  4838 proof -

  4839   have len: "length ?L = length ?R"

  4840     unfolding length_transpose transpose_max_length

  4841     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]

  4842     by simp

  4843

  4844   { fix i assume "i < length ?R"

  4845     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]

  4846     have "i < length xs" by simp

  4847   } note * = this

  4848   show ?thesis

  4849     by (rule nth_equalityI)

  4850        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)

  4851 qed

  4852

  4853 theorem transpose_rectangle:

  4854   assumes "xs = [] \<Longrightarrow> n = 0"

  4855   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"

  4856   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"

  4857     (is "?trans = ?map")

  4858 proof (rule nth_equalityI)

  4859   have "sorted (rev (map length xs))"

  4860     by (auto simp: rev_nth rect intro!: sorted_nth_monoI)

  4861   from foldr_max_sorted[OF this] assms

  4862   show len: "length ?trans = length ?map"

  4863     by (simp_all add: length_transpose foldr_map comp_def)

  4864   moreover

  4865   { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs"

  4866       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }

  4867   ultimately show "\<forall>i < length ?trans. ?trans ! i = ?map ! i"

  4868     by (auto simp: nth_transpose intro: nth_equalityI)

  4869 qed

  4870

  4871

  4872 subsubsection {* @{text sorted_list_of_set} *}

  4873

  4874 text{* This function maps (finite) linearly ordered sets to sorted

  4875 lists. Warning: in most cases it is not a good idea to convert from

  4876 sets to lists but one should convert in the other direction (via

  4877 @{const set}). *}

  4878

  4879 subsubsection {* @{text sorted_list_of_set} *}

  4880

  4881 text{* This function maps (finite) linearly ordered sets to sorted

  4882 lists. Warning: in most cases it is not a good idea to convert from

  4883 sets to lists but one should convert in the other direction (via

  4884 @{const set}). *}

  4885

  4886 definition (in linorder) sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where

  4887   "sorted_list_of_set = folding.F insort []"

  4888

  4889 sublocale linorder < sorted_list_of_set!: folding insort Nil

  4890 where

  4891   "folding.F insort [] = sorted_list_of_set"

  4892 proof -

  4893   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)

  4894   show "folding insort" by default (fact comp_fun_commute)

  4895   show "folding.F insort [] = sorted_list_of_set" by (simp only: sorted_list_of_set_def)

  4896 qed

  4897

  4898 context linorder

  4899 begin

  4900

  4901 lemma sorted_list_of_set_empty:

  4902   "sorted_list_of_set {} = []"

  4903   by (fact sorted_list_of_set.empty)

  4904

  4905 lemma sorted_list_of_set_insert [simp]:

  4906   assumes "finite A"

  4907   shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"

  4908   using assms by (fact sorted_list_of_set.insert_remove)

  4909

  4910 lemma sorted_list_of_set_eq_Nil_iff [simp]:

  4911   "finite A \<Longrightarrow> sorted_list_of_set A = [] \<longleftrightarrow> A = {}"

  4912   using assms by (auto simp: sorted_list_of_set.remove)

  4913

  4914 lemma sorted_list_of_set [simp]:

  4915   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A)

  4916     \<and> distinct (sorted_list_of_set A)"

  4917   by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)

  4918

  4919 lemma distinct_sorted_list_of_set:

  4920   "distinct (sorted_list_of_set A)"

  4921   using sorted_list_of_set by (cases "finite A") auto

  4922

  4923 lemma sorted_list_of_set_sort_remdups [code]:

  4924   "sorted_list_of_set (set xs) = sort (remdups xs)"

  4925 proof -

  4926   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)

  4927   show ?thesis by (simp add: sorted_list_of_set.eq_fold sort_conv_fold fold_set_fold_remdups)

  4928 qed

  4929

  4930 lemma sorted_list_of_set_remove:

  4931   assumes "finite A"

  4932   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"

  4933 proof (cases "x \<in> A")

  4934   case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp

  4935   with False show ?thesis by (simp add: remove1_idem)

  4936 next

  4937   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)

  4938   with assms show ?thesis by simp

  4939 qed

  4940

  4941 end

  4942

  4943 lemma sorted_list_of_set_range [simp]:

  4944   "sorted_list_of_set {m..<n} = [m..<n]"

  4945   by (rule sorted_distinct_set_unique) simp_all

  4946

  4947

  4948 subsubsection {* @{text lists}: the list-forming operator over sets *}

  4949

  4950 inductive_set

  4951   lists :: "'a set => 'a list set"

  4952   for A :: "'a set"

  4953 where

  4954     Nil [intro!, simp]: "[]: lists A"

  4955   | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"

  4956

  4957 inductive_cases listsE [elim!,no_atp]: "x#l : lists A"

  4958 inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"

  4959

  4960 inductive_simps listsp_simps[code]:

  4961   "listsp A []"

  4962   "listsp A (x # xs)"

  4963

  4964 lemma listsp_mono [mono]: "A \<le> B ==> listsp A \<le> listsp B"

  4965 by (rule predicate1I, erule listsp.induct, blast+)

  4966

  4967 lemmas lists_mono = listsp_mono [to_set]

  4968

  4969 lemma listsp_infI:

  4970   assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using l

  4971 by induct blast+

  4972

  4973 lemmas lists_IntI = listsp_infI [to_set]

  4974

  4975 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"

  4976 proof (rule mono_inf [where f=listsp, THEN order_antisym])

  4977   show "mono listsp" by (simp add: mono_def listsp_mono)

  4978   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI)

  4979 qed

  4980

  4981 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]

  4982

  4983 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]

  4984

  4985 lemma Cons_in_lists_iff[simp]: "x#xs : lists A \<longleftrightarrow> x:A \<and> xs : lists A"

  4986 by auto

  4987

  4988 lemma append_in_listsp_conv [iff]:

  4989      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"

  4990 by (induct xs) auto

  4991

  4992 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]

  4993

  4994 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"

  4995 -- {* eliminate @{text listsp} in favour of @{text set} *}

  4996 by (induct xs) auto

  4997

  4998 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]

  4999

  5000 lemma in_listspD [dest!,no_atp]: "listsp A xs ==> \<forall>x\<in>set xs. A x"

  5001 by (rule in_listsp_conv_set [THEN iffD1])

  5002

  5003 lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]

  5004

  5005 lemma in_listspI [intro!,no_atp]: "\<forall>x\<in>set xs. A x ==> listsp A xs"

  5006 by (rule in_listsp_conv_set [THEN iffD2])

  5007

  5008 lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]

  5009

  5010 lemma lists_eq_set: "lists A = {xs. set xs <= A}"

  5011 by auto

  5012

  5013 lemma lists_empty [simp]: "lists {} = {[]}"

  5014 by auto

  5015

  5016 lemma lists_UNIV [simp]: "lists UNIV = UNIV"

  5017 by auto

  5018

  5019 lemma lists_image: "lists (fA) = map f  lists A"

  5020 proof -

  5021   { fix xs have "\<forall>x\<in>set xs. x \<in> f  A \<Longrightarrow> xs \<in> map f  lists A"

  5022       by (induct xs) (auto simp del: map.simps simp add: map.simps[symmetric] intro!: imageI) }

  5023   then show ?thesis by auto

  5024 qed

  5025

  5026 subsubsection {* Inductive definition for membership *}

  5027

  5028 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"

  5029 where

  5030     elem:  "ListMem x (x # xs)"

  5031   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"

  5032

  5033 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"

  5034 apply (rule iffI)

  5035  apply (induct set: ListMem)

  5036   apply auto

  5037 apply (induct xs)

  5038  apply (auto intro: ListMem.intros)

  5039 done

  5040

  5041

  5042 subsubsection {* Lists as Cartesian products *}

  5043

  5044 text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from

  5045 @{term A} and tail drawn from @{term Xs}.*}

  5046

  5047 definition set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where

  5048 "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"

  5049

  5050 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])A"

  5051 by (auto simp add: set_Cons_def)

  5052

  5053 text{*Yields the set of lists, all of the same length as the argument and

  5054 with elements drawn from the corresponding element of the argument.*}

  5055

  5056 primrec listset :: "'a set list \<Rightarrow> 'a list set" where

  5057 "listset [] = {[]}" |

  5058 "listset (A # As) = set_Cons A (listset As)"

  5059

  5060

  5061 subsection {* Relations on Lists *}

  5062

  5063 subsubsection {* Length Lexicographic Ordering *}

  5064

  5065 text{*These orderings preserve well-foundedness: shorter lists

  5066   precede longer lists. These ordering are not used in dictionaries.*}

  5067

  5068 primrec -- {*The lexicographic ordering for lists of the specified length*}

  5069   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where

  5070 "lexn r 0 = {}" |

  5071 "lexn r (Suc n) =

  5072   (map_pair (%(x, xs). x#xs) (%(x, xs). x#xs)  (r <*lex*> lexn r n)) Int

  5073   {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"

  5074

  5075 definition lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  5076 "lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}

  5077

  5078 definition lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where

  5079 "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"

  5080         -- {*Compares lists by their length and then lexicographically*}

  5081

  5082 lemma wf_lexn: "wf r ==> wf (lexn r n)"

  5083 apply (induct n, simp, simp)

  5084 apply(rule wf_subset)

  5085  prefer 2 apply (rule Int_lower1)

  5086 apply(rule wf_map_pair_image)

  5087  prefer 2 apply (rule inj_onI, auto)

  5088 done

  5089

  5090 lemma lexn_length:

  5091   "(xs, ys) : lexn r n ==> length xs = n \<and> length ys = n"

  5092 by (induct n arbitrary: xs ys) auto

  5093

  5094 lemma wf_lex [intro!]: "wf r ==> wf (lex r)"

  5095 apply (unfold lex_def)

  5096 apply (rule wf_UN)

  5097 apply (blast intro: wf_lexn, clarify)

  5098 apply (rename_tac m n)

  5099 apply (subgoal_tac "m \<noteq> n")

  5100  prefer 2 apply blast

  5101 apply (blast dest: lexn_length not_sym)

  5102 done

  5103

  5104 lemma lexn_conv:

  5105   "lexn r n =

  5106     {(xs,ys). length xs = n \<and> length ys = n \<and>

  5107     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y):r)}"

  5108 apply (induct n, simp)

  5109 apply (simp add: image_Collect lex_prod_def, safe, blast)

  5110  apply (rule_tac x = "ab # xys" in exI, simp)

  5111 apply (case_tac xys, simp_all, blast)

  5112 done

  5113

  5114 lemma lex_conv:

  5115   "lex r =

  5116     {(xs,ys). length xs = length ys \<and>

  5117     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y):r)}"

  5118 by (force simp add: lex_def lexn_conv)

  5119

  5120 lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"

  5121 by (unfold lenlex_def) blast

  5122

  5123 lemma lenlex_conv:

  5124     "lenlex r = {(xs,ys). length xs < length ys |

  5125                  length xs = length ys \<and> (xs, ys) : lex r}"

  5126 by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)

  5127

  5128 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"

  5129 by (simp add: lex_conv)

  5130

  5131 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"

  5132 by (simp add:lex_conv)

  5133

  5134 lemma Cons_in_lex [simp]:

  5135     "((x # xs, y # ys) : lex r) =

  5136       ((x, y) : r \<and> length xs = length ys | x = y \<and> (xs, ys) : lex r)"

  5137 apply (simp add: lex_conv)

  5138 apply (rule iffI)

  5139  prefer 2 apply (blast intro: Cons_eq_appendI, clarify)

  5140 apply (case_tac xys, simp, simp)

  5141 apply blast

  5142 done

  5143

  5144

  5145 subsubsection {* Lexicographic Ordering *}

  5146

  5147 text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".

  5148     This ordering does \emph{not} preserve well-foundedness.

  5149      Author: N. Voelker, March 2005. *}

  5150

  5151 definition lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  5152 "lexord r = {(x,y). \<exists> a v. y = x @ a # v \<or>

  5153             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"

  5154

  5155 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"

  5156 by (unfold lexord_def, induct_tac y, auto)

  5157

  5158 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"

  5159 by (unfold lexord_def, induct_tac x, auto)

  5160

  5161 lemma lexord_cons_cons[simp]:

  5162      "((a # x, b # y) \<in> lexord r) = ((a,b)\<in> r | (a = b & (x,y)\<in> lexord r))"

  5163   apply (unfold lexord_def, safe, simp_all)

  5164   apply (case_tac u, simp, simp)

  5165   apply (case_tac u, simp, clarsimp, blast, blast, clarsimp)

  5166   apply (erule_tac x="b # u" in allE)

  5167   by force

  5168

  5169 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons

  5170

  5171 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"

  5172 by (induct_tac x, auto)

  5173

  5174 lemma lexord_append_left_rightI:

  5175      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"

  5176 by (induct_tac u, auto)

  5177

  5178 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"

  5179 by (induct x, auto)

  5180

  5181 lemma lexord_append_leftD:

  5182      "\<lbrakk> (x @ u, x @ v) \<in> lexord r; (! a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"

  5183 by (erule rev_mp, induct_tac x, auto)

  5184

  5185 lemma lexord_take_index_conv:

  5186    "((x,y) : lexord r) =

  5187     ((length x < length y \<and> take (length x) y = x) \<or>

  5188      (\<exists>i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) \<in> r))"

  5189   apply (unfold lexord_def Let_def, clarsimp)

  5190   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)

  5191   apply auto

  5192   apply (rule_tac x="hd (drop (length x) y)" in exI)

  5193   apply (rule_tac x="tl (drop (length x) y)" in exI)

  5194   apply (erule subst, simp add: min_def)

  5195   apply (rule_tac x ="length u" in exI, simp)

  5196   apply (rule_tac x ="take i x" in exI)

  5197   apply (rule_tac x ="x ! i" in exI)

  5198   apply (rule_tac x ="y ! i" in exI, safe)

  5199   apply (rule_tac x="drop (Suc i) x" in exI)

  5200   apply (drule sym, simp add: drop_Suc_conv_tl)

  5201   apply (rule_tac x="drop (Suc i) y" in exI)

  5202   by (simp add: drop_Suc_conv_tl)

  5203

  5204 -- {* lexord is extension of partial ordering List.lex *}

  5205 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"

  5206   apply (rule_tac x = y in spec)

  5207   apply (induct_tac x, clarsimp)

  5208   by (clarify, case_tac x, simp, force)

  5209

  5210 lemma lexord_irreflexive: "ALL x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"

  5211 by (induct xs) auto

  5212

  5213 text{* By Ren\'e Thiemann: *}

  5214 lemma lexord_partial_trans:

  5215   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)

  5216    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"

  5217 proof (induct xs arbitrary: ys zs)

  5218   case Nil

  5219   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)

  5220 next

  5221   case (Cons x xs yys zzs)

  5222   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def

  5223     by (cases yys, auto)

  5224   note Cons = Cons[unfolded yys]

  5225   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto

  5226   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def

  5227     by (cases zzs, auto)

  5228   note Cons = Cons[unfolded zzs]

  5229   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto

  5230   {

  5231     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"

  5232     from Cons(1)[OF _ this] Cons(2)

  5233     have "(xs,zs) \<in> lexord r" by auto

  5234   } note ind1 = this

  5235   {

  5236     assume "(x,y) \<in> r" and "(y,z) \<in> r"

  5237     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto

  5238   } note ind2 = this

  5239   from one two ind1 ind2

  5240   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast

  5241   thus ?case unfolding zzs by auto

  5242 qed

  5243

  5244 lemma lexord_trans:

  5245     "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"

  5246 by(auto simp: trans_def intro:lexord_partial_trans)

  5247

  5248 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"

  5249 by (rule transI, drule lexord_trans, blast)

  5250

  5251 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"

  5252   apply (rule_tac x = y in spec)

  5253   apply (induct_tac x, rule allI)

  5254   apply (case_tac x, simp, simp)

  5255   apply (rule allI, case_tac x, simp, simp)

  5256   by blast

  5257

  5258

  5259 subsubsection {* Lexicographic combination of measure functions *}

  5260

  5261 text {* These are useful for termination proofs *}

  5262

  5263 definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"

  5264

  5265 lemma wf_measures[simp]: "wf (measures fs)"

  5266 unfolding measures_def

  5267 by blast

  5268

  5269 lemma in_measures[simp]:

  5270   "(x, y) \<in> measures [] = False"

  5271   "(x, y) \<in> measures (f # fs)

  5272          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"

  5273 unfolding measures_def

  5274 by auto

  5275

  5276 lemma measures_less: "f x < f y ==> (x, y) \<in> measures (f#fs)"

  5277 by simp

  5278

  5279 lemma measures_lesseq: "f x <= f y ==> (x, y) \<in> measures fs ==> (x, y) \<in> measures (f#fs)"

  5280 by auto

  5281

  5282

  5283 subsubsection {* Lifting Relations to Lists: one element *}

  5284

  5285 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  5286 "listrel1 r = {(xs,ys).

  5287    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"

  5288

  5289 lemma listrel1I:

  5290   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>

  5291   (xs, ys) \<in> listrel1 r"

  5292 unfolding listrel1_def by auto

  5293

  5294 lemma listrel1E:

  5295   "\<lbrakk> (xs, ys) \<in> listrel1 r;

  5296      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P

  5297    \<rbrakk> \<Longrightarrow> P"

  5298 unfolding listrel1_def by auto

  5299

  5300 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"

  5301 unfolding listrel1_def by blast

  5302

  5303 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"

  5304 unfolding listrel1_def by blast

  5305

  5306 lemma Cons_listrel1_Cons [iff]:

  5307   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>

  5308    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"

  5309 by (simp add: listrel1_def Cons_eq_append_conv) (blast)

  5310

  5311 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"

  5312 by (metis Cons_listrel1_Cons)

  5313

  5314 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"

  5315 by (metis Cons_listrel1_Cons)

  5316

  5317 lemma append_listrel1I:

  5318   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r

  5319     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"

  5320 unfolding listrel1_def

  5321 by auto (blast intro: append_eq_appendI)+

  5322

  5323 lemma Cons_listrel1E1[elim!]:

  5324   assumes "(x # xs, ys) \<in> listrel1 r"

  5325     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"

  5326     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"

  5327   shows R

  5328 using assms by (cases ys) blast+

  5329

  5330 lemma Cons_listrel1E2[elim!]:

  5331   assumes "(xs, y # ys) \<in> listrel1 r"

  5332     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"

  5333     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"

  5334   shows R

  5335 using assms by (cases xs) blast+

  5336

  5337 lemma snoc_listrel1_snoc_iff:

  5338   "(xs @ [x], ys @ [y]) \<in> listrel1 r

  5339     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")

  5340 proof

  5341   assume ?L thus ?R

  5342     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)

  5343 next

  5344   assume ?R then show ?L unfolding listrel1_def by force

  5345 qed

  5346

  5347 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"

  5348 unfolding listrel1_def by auto

  5349

  5350 lemma listrel1_mono:

  5351   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"

  5352 unfolding listrel1_def by blast

  5353

  5354

  5355 lemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"

  5356 unfolding listrel1_def by blast

  5357

  5358 lemma in_listrel1_converse:

  5359   "(x,y) : listrel1 (r^-1) \<longleftrightarrow> (x,y) : (listrel1 r)^-1"

  5360 unfolding listrel1_def by blast

  5361

  5362 lemma listrel1_iff_update:

  5363   "(xs,ys) \<in> (listrel1 r)

  5364    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")

  5365 proof

  5366   assume "?L"

  5367   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"

  5368     unfolding listrel1_def by auto

  5369   then have "ys = xs[length u := y]" and "length u < length xs"

  5370     and "(xs ! length u, y) \<in> r" by auto

  5371   then show "?R" by auto

  5372 next

  5373   assume "?R"

  5374   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"

  5375     by auto

  5376   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"

  5377     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)

  5378   then show "?L" by (auto simp: listrel1_def)

  5379 qed

  5380

  5381

  5382 text{* Accessible part and wellfoundedness: *}

  5383

  5384 lemma Cons_acc_listrel1I [intro!]:

  5385   "x \<in> acc r \<Longrightarrow> xs \<in> acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> acc (listrel1 r)"

  5386 apply (induct arbitrary: xs set: acc)

  5387 apply (erule thin_rl)

  5388 apply (erule acc_induct)

  5389 apply (rule accI)

  5390 apply (blast)

  5391 done

  5392

  5393 lemma lists_accD: "xs \<in> lists (acc r) \<Longrightarrow> xs \<in> acc (listrel1 r)"

  5394 apply (induct set: lists)

  5395  apply (rule accI)

  5396  apply simp

  5397 apply (rule accI)

  5398 apply (fast dest: acc_downward)

  5399 done

  5400

  5401 lemma lists_accI: "xs \<in> acc (listrel1 r) \<Longrightarrow> xs \<in> lists (acc r)"

  5402 apply (induct set: acc)

  5403 apply clarify

  5404 apply (rule accI)

  5405 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)

  5406 done

  5407

  5408 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"

  5409 by(metis wf_acc_iff in_lists_conv_set lists_accI lists_accD Cons_in_lists_iff)

  5410

  5411

  5412 subsubsection {* Lifting Relations to Lists: all elements *}

  5413

  5414 inductive_set

  5415   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"

  5416   for r :: "('a \<times> 'b) set"

  5417 where

  5418     Nil:  "([],[]) \<in> listrel r"

  5419   | Cons: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (x#xs, y#ys) \<in> listrel r"

  5420

  5421 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"

  5422 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"

  5423 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"

  5424 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"

  5425

  5426

  5427 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"

  5428 by(induct rule: listrel.induct) auto

  5429

  5430 lemma listrel_iff_zip [code_unfold]: "(xs,ys) : listrel r \<longleftrightarrow>

  5431   length xs = length ys & (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")

  5432 proof

  5433   assume ?L thus ?R by induct (auto intro: listrel_eq_len)

  5434 next

  5435   assume ?R thus ?L

  5436     apply (clarify)

  5437     by (induct rule: list_induct2) (auto intro: listrel.intros)

  5438 qed

  5439

  5440 lemma listrel_iff_nth: "(xs,ys) : listrel r \<longleftrightarrow>

  5441   length xs = length ys & (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")

  5442 by (auto simp add: all_set_conv_all_nth listrel_iff_zip)

  5443

  5444

  5445 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"

  5446 apply clarify

  5447 apply (erule listrel.induct)

  5448 apply (blast intro: listrel.intros)+

  5449 done

  5450

  5451 lemma listrel_subset: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"

  5452 apply clarify

  5453 apply (erule listrel.induct, auto)

  5454 done

  5455

  5456 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)"

  5457 apply (simp add: refl_on_def listrel_subset Ball_def)

  5458 apply (rule allI)

  5459 apply (induct_tac x)

  5460 apply (auto intro: listrel.intros)

  5461 done

  5462

  5463 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)"

  5464 apply (auto simp add: sym_def)

  5465 apply (erule listrel.induct)

  5466 apply (blast intro: listrel.intros)+

  5467 done

  5468

  5469 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)"

  5470 apply (simp add: trans_def)

  5471 apply (intro allI)

  5472 apply (rule impI)

  5473 apply (erule listrel.induct)

  5474 apply (blast intro: listrel.intros)+

  5475 done

  5476

  5477 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"

  5478 by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans)

  5479

  5480 lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"

  5481 using listrel_refl_on[of UNIV, OF refl_rtrancl]

  5482 by(auto simp: refl_on_def)

  5483

  5484 lemma listrel_rtrancl_trans:

  5485   "\<lbrakk> (xs,ys) : listrel(r^*);  (ys,zs) : listrel(r^*) \<rbrakk>

  5486   \<Longrightarrow> (xs,zs) : listrel(r^*)"

  5487 by (metis listrel_trans trans_def trans_rtrancl)

  5488

  5489

  5490 lemma listrel_Nil [simp]: "listrel r  {[]} = {[]}"

  5491 by (blast intro: listrel.intros)

  5492

  5493 lemma listrel_Cons:

  5494      "listrel r  {x#xs} = set_Cons (r{x}) (listrel r  {xs})"

  5495 by (auto simp add: set_Cons_def intro: listrel.intros)

  5496

  5497 text {* Relating @{term listrel1}, @{term listrel} and closures: *}

  5498

  5499 lemma listrel1_rtrancl_subset_rtrancl_listrel1:

  5500   "listrel1 (r^*) \<subseteq> (listrel1 r)^*"

  5501 proof (rule subrelI)

  5502   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r^*)"

  5503   { fix x y us vs

  5504     have "(x,y) : r^* \<Longrightarrow> (us @ x # vs, us @ y # vs) : (listrel1 r)^*"

  5505     proof(induct rule: rtrancl.induct)

  5506       case rtrancl_refl show ?case by simp

  5507     next

  5508       case rtrancl_into_rtrancl thus ?case

  5509         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)

  5510     qed }

  5511   thus "(xs,ys) \<in> (listrel1 r)^*" using 1 by(blast elim: listrel1E)

  5512 qed

  5513

  5514 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)^* \<Longrightarrow> length x = length y"

  5515 by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)

  5516

  5517 lemma rtrancl_listrel1_ConsI1:

  5518   "(xs,ys) : (listrel1 r)^* \<Longrightarrow> (x#xs,x#ys) : (listrel1 r)^*"

  5519 apply(induct rule: rtrancl.induct)

  5520  apply simp

  5521 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)

  5522

  5523 lemma rtrancl_listrel1_ConsI2:

  5524   "(x,y) \<in> r^* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)^*

  5525   \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)^*"

  5526   by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1

  5527     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])

  5528

  5529 lemma listrel1_subset_listrel:

  5530   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"

  5531 by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)

  5532

  5533 lemma listrel_reflcl_if_listrel1:

  5534   "(xs,ys) : listrel1 r \<Longrightarrow> (xs,ys) : listrel(r^*)"

  5535 by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)

  5536

  5537 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"

  5538 proof

  5539   { fix x y assume "(x,y) \<in> listrel (r^*)"

  5540     then have "(x,y) \<in> (listrel1 r)^*"

  5541     by induct (auto intro: rtrancl_listrel1_ConsI2) }

  5542   then show "listrel (r^*) \<subseteq> (listrel1 r)^*"

  5543     by (rule subrelI)

  5544 next

  5545   show "listrel (r^*) \<supseteq> (listrel1 r)^*"

  5546   proof(rule subrelI)

  5547     fix xs ys assume "(xs,ys) \<in> (listrel1 r)^*"

  5548     then show "(xs,ys) \<in> listrel (r^*)"

  5549     proof induct

  5550       case base show ?case by(auto simp add: listrel_iff_zip set_zip)

  5551     next

  5552       case (step ys zs)

  5553       thus ?case  by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)

  5554     qed

  5555   qed

  5556 qed

  5557

  5558 lemma rtrancl_listrel1_if_listrel:

  5559   "(xs,ys) : listrel r \<Longrightarrow> (xs,ys) : (listrel1 r)^*"

  5560 by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)

  5561

  5562 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)^*"

  5563 by(fast intro:rtrancl_listrel1_if_listrel)

  5564

  5565

  5566 subsection {* Size function *}

  5567

  5568 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"

  5569 by (rule is_measure_trivial)

  5570

  5571 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (option_size f)"

  5572 by (rule is_measure_trivial)

  5573

  5574 lemma list_size_estimation[termination_simp]:

  5575   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < list_size f xs"

  5576 by (induct xs) auto

  5577

  5578 lemma list_size_estimation'[termination_simp]:

  5579   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> list_size f xs"

  5580 by (induct xs) auto

  5581

  5582 lemma list_size_map[simp]: "list_size f (map g xs) = list_size (f o g) xs"

  5583 by (induct xs) auto

  5584

  5585 lemma list_size_append[simp]: "list_size f (xs @ ys) = list_size f xs + list_size f ys"

  5586 by (induct xs, auto)

  5587

  5588 lemma list_size_pointwise[termination_simp]:

  5589   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"

  5590 by (induct xs) force+

  5591

  5592

  5593 subsection {* Monad operation *}

  5594

  5595 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where

  5596 "bind xs f = concat (map f xs)"

  5597

  5598 hide_const (open) bind

  5599

  5600 lemma bind_simps [simp]:

  5601   "List.bind [] f = []"

  5602   "List.bind (x # xs) f = f x @ List.bind xs f"

  5603   by (simp_all add: bind_def)

  5604

  5605

  5606 subsection {* Transfer *}

  5607

  5608 definition embed_list :: "nat list \<Rightarrow> int list" where

  5609 "embed_list l = map int l"

  5610

  5611 definition nat_list :: "int list \<Rightarrow> bool" where

  5612 "nat_list l = nat_set (set l)"

  5613

  5614 definition return_list :: "int list \<Rightarrow> nat list" where

  5615 "return_list l = map nat l"

  5616

  5617 lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>

  5618     embed_list (return_list l) = l"

  5619   unfolding embed_list_def return_list_def nat_list_def nat_set_def

  5620   apply (induct l)

  5621   apply auto

  5622 done

  5623

  5624 lemma transfer_nat_int_list_functions:

  5625   "l @ m = return_list (embed_list l @ embed_list m)"

  5626   "[] = return_list []"

  5627   unfolding return_list_def embed_list_def

  5628   apply auto

  5629   apply (induct l, auto)

  5630   apply (induct m, auto)

  5631 done

  5632

  5633 (*

  5634 lemma transfer_nat_int_fold1: "fold f l x =

  5635     fold (%x. f (nat x)) (embed_list l) x";

  5636 *)

  5637

  5638

  5639 subsection {* Code generation *}

  5640

  5641

  5642 text{* Optional tail recursive version of @{const map}. Can avoid

  5643 stack overflow in some target languages. *}

  5644

  5645 fun map_tailrec_rev ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'b list" where

  5646 "map_tailrec_rev f [] bs = bs" |

  5647 "map_tailrec_rev f (a#as) bs = map_tailrec_rev f as (f a # bs)"

  5648

  5649 lemma map_tailrec_rev:

  5650   "map_tailrec_rev f as bs = rev(map f as) @ bs"

  5651 by(induction as arbitrary: bs) simp_all

  5652

  5653 definition map_tailrec :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5654 "map_tailrec f as = rev (map_tailrec_rev f as [])"

  5655

  5656 text{* Code equation: *}

  5657 lemma map_eq_map_tailrec: "map = map_tailrec"

  5658 by(simp add: fun_eq_iff map_tailrec_def map_tailrec_rev)

  5659

  5660

  5661 subsubsection {* Counterparts for set-related operations *}

  5662

  5663 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where

  5664 [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"

  5665

  5666 text {*

  5667   Use @{text member} only for generating executable code.  Otherwise use

  5668   @{prop "x \<in> set xs"} instead --- it is much easier to reason about.

  5669 *}

  5670

  5671 lemma member_rec [code]:

  5672   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"

  5673   "member [] y \<longleftrightarrow> False"

  5674   by (auto simp add: member_def)

  5675

  5676 lemma in_set_member (* FIXME delete candidate *):

  5677   "x \<in> set xs \<longleftrightarrow> member xs x"

  5678   by (simp add: member_def)

  5679

  5680 definition list_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5681 list_all_iff [code_abbrev]: "list_all P xs \<longleftrightarrow> Ball (set xs) P"

  5682

  5683 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5684 list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"

  5685

  5686 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5687 list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"

  5688

  5689 text {*

  5690   Usually you should prefer @{text "\<forall>x\<in>set xs"}, @{text "\<exists>x\<in>set xs"}

  5691   and @{text "\<exists>!x. x\<in>set xs \<and> _"} over @{const list_all}, @{const list_ex}

  5692   and @{const list_ex1} in specifications.

  5693 *}

  5694

  5695 lemma list_all_simps [simp, code]:

  5696   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"

  5697   "list_all P [] \<longleftrightarrow> True"

  5698   by (simp_all add: list_all_iff)

  5699

  5700 lemma list_ex_simps [simp, code]:

  5701   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"

  5702   "list_ex P [] \<longleftrightarrow> False"

  5703   by (simp_all add: list_ex_iff)

  5704

  5705 lemma list_ex1_simps [simp, code]:

  5706   "list_ex1 P [] = False"

  5707   "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)"

  5708   by (auto simp add: list_ex1_iff list_all_iff)

  5709

  5710 lemma Ball_set_list_all: (* FIXME delete candidate *)

  5711   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  5712   by (simp add: list_all_iff)

  5713

  5714 lemma Bex_set_list_ex: (* FIXME delete candidate *)

  5715   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  5716   by (simp add: list_ex_iff)

  5717

  5718 lemma list_all_append [simp]:

  5719   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"

  5720   by (auto simp add: list_all_iff)

  5721

  5722 lemma list_ex_append [simp]:

  5723   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"

  5724   by (auto simp add: list_ex_iff)

  5725

  5726 lemma list_all_rev [simp]:

  5727   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"

  5728   by (simp add: list_all_iff)

  5729

  5730 lemma list_ex_rev [simp]:

  5731   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"

  5732   by (simp add: list_ex_iff)

  5733

  5734 lemma list_all_length:

  5735   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"

  5736   by (auto simp add: list_all_iff set_conv_nth)

  5737

  5738 lemma list_ex_length:

  5739   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"

  5740   by (auto simp add: list_ex_iff set_conv_nth)

  5741

  5742 lemma list_all_cong [fundef_cong]:

  5743   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_all f xs = list_all g ys"

  5744   by (simp add: list_all_iff)

  5745

  5746 lemma list_ex_cong [fundef_cong]:

  5747   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"

  5748 by (simp add: list_ex_iff)

  5749

  5750 definition can_select :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where

  5751 [code_abbrev]: "can_select P A = (\<exists>!x\<in>A. P x)"

  5752

  5753 lemma can_select_set_list_ex1 [code]:

  5754   "can_select P (set A) = list_ex1 P A"

  5755   by (simp add: list_ex1_iff can_select_def)

  5756

  5757

  5758 text {* Executable checks for relations on sets *}

  5759

  5760 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where

  5761 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"

  5762

  5763 lemma [code_unfold]:

  5764   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"

  5765 unfolding listrel1p_def by auto

  5766

  5767 lemma [code]:

  5768   "listrel1p r [] xs = False"

  5769   "listrel1p r xs [] =  False"

  5770   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>

  5771      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"

  5772 by (simp add: listrel1p_def)+

  5773

  5774 definition

  5775   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where

  5776   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"

  5777

  5778 lemma [code_unfold]:

  5779   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"

  5780 unfolding lexordp_def by auto

  5781

  5782 lemma [code]:

  5783   "lexordp r xs [] = False"

  5784   "lexordp r [] (y#ys) = True"

  5785   "lexordp r (x # xs) (y # ys) = (r x y | (x = y & lexordp r xs ys))"

  5786 unfolding lexordp_def by auto

  5787

  5788 text {* Bounded quantification and summation over nats. *}

  5789

  5790 lemma atMost_upto [code_unfold]:

  5791   "{..n} = set [0..<Suc n]"

  5792   by auto

  5793

  5794 lemma atLeast_upt [code_unfold]:

  5795   "{..<n} = set [0..<n]"

  5796   by auto

  5797

  5798 lemma greaterThanLessThan_upt [code_unfold]:

  5799   "{n<..<m} = set [Suc n..<m]"

  5800   by auto

  5801

  5802 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]

  5803

  5804 lemma greaterThanAtMost_upt [code_unfold]:

  5805   "{n<..m} = set [Suc n..<Suc m]"

  5806   by auto

  5807

  5808 lemma atLeastAtMost_upt [code_unfold]:

  5809   "{n..m} = set [n..<Suc m]"

  5810   by auto

  5811

  5812 lemma all_nat_less_eq [code_unfold]:

  5813   "(\<forall>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"

  5814   by auto

  5815

  5816 lemma ex_nat_less_eq [code_unfold]:

  5817   "(\<exists>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"

  5818   by auto

  5819

  5820 lemma all_nat_less [code_unfold]:

  5821   "(\<forall>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"

  5822   by auto

  5823

  5824 lemma ex_nat_less [code_unfold]:

  5825   "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"

  5826   by auto

  5827

  5828 lemma setsum_set_upt_conv_listsum_nat [code_unfold]:

  5829   "setsum f (set [m..<n]) = listsum (map f [m..<n])"

  5830   by (simp add: interv_listsum_conv_setsum_set_nat)

  5831

  5832 text {* Summation over ints. *}

  5833

  5834 lemma greaterThanLessThan_upto [code_unfold]:

  5835   "{i<..<j::int} = set [i+1..j - 1]"

  5836 by auto

  5837

  5838 lemma atLeastLessThan_upto [code_unfold]:

  5839   "{i..<j::int} = set [i..j - 1]"

  5840 by auto

  5841

  5842 lemma greaterThanAtMost_upto [code_unfold]:

  5843   "{i<..j::int} = set [i+1..j]"

  5844 by auto

  5845

  5846 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]

  5847

  5848 lemma setsum_set_upto_conv_listsum_int [code_unfold]:

  5849   "setsum f (set [i..j::int]) = listsum (map f [i..j])"

  5850   by (simp add: interv_listsum_conv_setsum_set_int)

  5851

  5852

  5853 subsubsection {* Optimizing by rewriting *}

  5854

  5855 definition null :: "'a list \<Rightarrow> bool" where

  5856   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"

  5857

  5858 text {*

  5859   Efficient emptyness check is implemented by @{const null}.

  5860 *}

  5861

  5862 lemma null_rec [code]:

  5863   "null (x # xs) \<longleftrightarrow> False"

  5864   "null [] \<longleftrightarrow> True"

  5865   by (simp_all add: null_def)

  5866

  5867 lemma eq_Nil_null: (* FIXME delete candidate *)

  5868   "xs = [] \<longleftrightarrow> null xs"

  5869   by (simp add: null_def)

  5870

  5871 lemma equal_Nil_null [code_unfold]:

  5872   "HOL.equal xs [] \<longleftrightarrow> null xs"

  5873   by (simp add: equal eq_Nil_null)

  5874

  5875 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5876   [code_abbrev]: "maps f xs = concat (map f xs)"

  5877

  5878 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5879   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"

  5880

  5881 text {*

  5882   Operations @{const maps} and @{const map_filter} avoid

  5883   intermediate lists on execution -- do not use for proving.

  5884 *}

  5885

  5886 lemma maps_simps [code]:

  5887   "maps f (x # xs) = f x @ maps f xs"

  5888   "maps f [] = []"

  5889   by (simp_all add: maps_def)

  5890

  5891 lemma map_filter_simps [code]:

  5892   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"

  5893   "map_filter f [] = []"

  5894   by (simp_all add: map_filter_def split: option.split)

  5895

  5896 lemma concat_map_maps: (* FIXME delete candidate *)

  5897   "concat (map f xs) = maps f xs"

  5898   by (simp add: maps_def)

  5899

  5900 lemma map_filter_map_filter [code_unfold]:

  5901   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"

  5902   by (simp add: map_filter_def)

  5903

  5904 text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}

  5905 and similiarly for @{text"\<exists>"}. *}

  5906

  5907 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where

  5908   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"

  5909

  5910 lemma [code]:

  5911   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"

  5912 proof -

  5913   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"

  5914   proof -

  5915     fix n

  5916     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"

  5917     then show "P n" by (cases "n = i") simp_all

  5918   qed

  5919   show ?thesis by (auto simp add: all_interval_nat_def intro: *)

  5920 qed

  5921

  5922 lemma list_all_iff_all_interval_nat [code_unfold]:

  5923   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"

  5924   by (simp add: list_all_iff all_interval_nat_def)

  5925

  5926 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:

  5927   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"

  5928   by (simp add: list_ex_iff all_interval_nat_def)

  5929

  5930 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where

  5931   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"

  5932

  5933 lemma [code]:

  5934   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"

  5935 proof -

  5936   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"

  5937   proof -

  5938     fix k

  5939     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"

  5940     then show "P k" by (cases "k = i") simp_all

  5941   qed

  5942   show ?thesis by (auto simp add: all_interval_int_def intro: *)

  5943 qed

  5944

  5945 lemma list_all_iff_all_interval_int [code_unfold]:

  5946   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"

  5947   by (simp add: list_all_iff all_interval_int_def)

  5948

  5949 lemma list_ex_iff_not_all_inverval_int [code_unfold]:

  5950   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"

  5951   by (simp add: list_ex_iff all_interval_int_def)

  5952

  5953 text {* optimized code (tail-recursive) for @{term length} *}

  5954

  5955 definition gen_length :: "nat \<Rightarrow> 'a list \<Rightarrow> nat"

  5956 where "gen_length n xs = n + length xs"

  5957

  5958 lemma gen_length_code [code]:

  5959   "gen_length n [] = n"

  5960   "gen_length n (x # xs) = gen_length (Suc n) xs"

  5961 by(simp_all add: gen_length_def)

  5962

  5963 declare list.size(3-4)[code del]

  5964

  5965 lemma length_code [code]: "length = gen_length 0"

  5966 by(simp add: gen_length_def fun_eq_iff)

  5967

  5968 hide_const (open) member null maps map_filter all_interval_nat all_interval_int gen_length

  5969

  5970

  5971 subsubsection {* Pretty lists *}

  5972

  5973 ML {*

  5974 (* Code generation for list literals. *)

  5975

  5976 signature LIST_CODE =

  5977 sig

  5978   val implode_list: string -> string -> Code_Thingol.iterm -> Code_Thingol.iterm list option

  5979   val default_list: int * string

  5980     -> (Code_Printer.fixity -> Code_Thingol.iterm -> Pretty.T)

  5981     -> Code_Printer.fixity -> Code_Thingol.iterm -> Code_Thingol.iterm -> Pretty.T

  5982   val add_literal_list: string -> theory -> theory

  5983 end;

  5984

  5985 structure List_Code : LIST_CODE =

  5986 struct

  5987

  5988 open Basic_Code_Thingol;

  5989

  5990 fun implode_list nil' cons' t =

  5991   let

  5992     fun dest_cons (IConst { name = c, ... } $t1 $ t2) =

  5993           if c = cons'

  5994           then SOME (t1, t2)

  5995           else NONE

  5996       | dest_cons _ = NONE;

  5997     val (ts, t') = Code_Thingol.unfoldr dest_cons t;

  5998   in case t'

  5999    of IConst { name = c, ... } => if c = nil' then SOME ts else NONE

  6000     | _ => NONE

  6001   end;

  6002

  6003 fun default_list (target_fxy, target_cons) pr fxy t1 t2 =

  6004   Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (

  6005     pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,

  6006     Code_Printer.str target_cons,

  6007     pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2

  6008   );

  6009

  6010 fun add_literal_list target =

  6011   let

  6012     fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =

  6013       case Option.map (cons t1) (implode_list nil' cons' t2)

  6014        of SOME ts =>

  6015             Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)

  6016         | NONE =>

  6017             default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;

  6018   in Code_Target.add_const_syntax target @{const_name Cons}

  6019     (SOME (Code_Printer.complex_const_syntax (2, ([@{const_name Nil}, @{const_name Cons}], pretty))))

  6020   end

  6021

  6022 end;

  6023 *}

  6024

  6025 code_type list

  6026   (SML "_ list")

  6027   (OCaml "_ list")

  6028   (Haskell "![(_)]")

  6029   (Scala "List[(_)]")

  6030

  6031 code_const Nil

  6032   (SML "[]")

  6033   (OCaml "[]")

  6034   (Haskell "[]")

  6035   (Scala "!Nil")

  6036

  6037 code_instance list :: equal

  6038   (Haskell -)

  6039

  6040 code_const "HOL.equal \<Colon> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"

  6041   (Haskell infix 4 "==")

  6042

  6043 code_reserved SML

  6044   list

  6045

  6046 code_reserved OCaml

  6047   list

  6048

  6049 setup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}

  6050

  6051

  6052 subsubsection {* Use convenient predefined operations *}

  6053

  6054 code_const "op @"

  6055   (SML infixr 7 "@")

  6056   (OCaml infixr 6 "@")

  6057   (Haskell infixr 5 "++")

  6058   (Scala infixl 7 "++")

  6059

  6060 code_const map

  6061   (Haskell "map")

  6062

  6063 code_const filter

  6064   (Haskell "filter")

  6065

  6066 code_const concat

  6067   (Haskell "concat")

  6068

  6069 code_const List.maps

  6070   (Haskell "concatMap")

  6071

  6072 code_const rev

  6073   (Haskell "reverse")

  6074

  6075 code_const zip

  6076   (Haskell "zip")

  6077

  6078 code_const List.null

  6079   (Haskell "null")

  6080

  6081 code_const takeWhile

  6082   (Haskell "takeWhile")

  6083

  6084 code_const dropWhile

  6085   (Haskell "dropWhile")

  6086

  6087 code_const list_all

  6088   (Haskell "all")

  6089

  6090 code_const list_ex

  6091   (Haskell "any")

  6092

  6093

  6094 subsubsection {* Implementation of sets by lists *}

  6095

  6096 lemma is_empty_set [code]:

  6097   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"

  6098   by (simp add: Set.is_empty_def null_def)

  6099

  6100 lemma empty_set [code]:

  6101   "{} = set []"

  6102   by simp

  6103

  6104 lemma UNIV_coset [code]:

  6105   "UNIV = List.coset []"

  6106   by simp

  6107

  6108 lemma compl_set [code]:

  6109   "- set xs = List.coset xs"

  6110   by simp

  6111

  6112 lemma compl_coset [code]:

  6113   "- List.coset xs = set xs"

  6114   by simp

  6115

  6116 lemma [code]:

  6117   "x \<in> set xs \<longleftrightarrow> List.member xs x"

  6118   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"

  6119   by (simp_all add: member_def)

  6120

  6121 lemma insert_code [code]:

  6122   "insert x (set xs) = set (List.insert x xs)"

  6123   "insert x (List.coset xs) = List.coset (removeAll x xs)"

  6124   by simp_all

  6125

  6126 lemma remove_code [code]:

  6127   "Set.remove x (set xs) = set (removeAll x xs)"

  6128   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"

  6129   by (simp_all add: remove_def Compl_insert)

  6130

  6131 lemma filter_set [code]:

  6132   "Set.filter P (set xs) = set (filter P xs)"

  6133   by auto

  6134

  6135 lemma image_set [code]:

  6136   "image f (set xs) = set (map f xs)"

  6137   by simp

  6138

  6139 lemma subset_code [code]:

  6140   "set xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> B)"

  6141   "A \<le> List.coset ys \<longleftrightarrow> (\<forall>y\<in>set ys. y \<notin> A)"

  6142   "List.coset [] \<le> set [] \<longleftrightarrow> False"

  6143   by auto

  6144

  6145 text {* A frequent case – avoid intermediate sets *}

  6146 lemma [code_unfold]:

  6147   "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"

  6148   by (auto simp: list_all_iff)

  6149

  6150 lemma Ball_set [code]:

  6151   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  6152   by (simp add: list_all_iff)

  6153

  6154 lemma Bex_set [code]:

  6155   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  6156   by (simp add: list_ex_iff)

  6157

  6158 lemma card_set [code]:

  6159   "card (set xs) = length (remdups xs)"

  6160 proof -

  6161   have "card (set (remdups xs)) = length (remdups xs)"

  6162     by (rule distinct_card) simp

  6163   then show ?thesis by simp

  6164 qed

  6165

  6166 lemma the_elem_set [code]:

  6167   "the_elem (set [x]) = x"

  6168   by simp

  6169

  6170 lemma Pow_set [code]:

  6171   "Pow (set []) = {{}}"

  6172   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x  A)"

  6173   by (simp_all add: Pow_insert Let_def)

  6174

  6175 lemma setsum_code [code]:

  6176   "setsum f (set xs) = listsum (map f (remdups xs))"

  6177 by (simp add: listsum_distinct_conv_setsum_set)

  6178

  6179 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where

  6180   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"

  6181

  6182 lemma [code]:

  6183   "map_project f (set xs) = set (List.map_filter f xs)"

  6184   by (auto simp add: map_project_def map_filter_def image_def)

  6185

  6186 hide_const (open) map_project

  6187

  6188

  6189 text {* Operations on relations *}

  6190

  6191 lemma product_code [code]:

  6192   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"

  6193   by (auto simp add: Product_Type.product_def)

  6194

  6195 lemma Id_on_set [code]:

  6196   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"

  6197   by (auto simp add: Id_on_def)

  6198

  6199 lemma [code]:

  6200   "R  S = List.map_project (%(x, y). if x : S then Some y else None) R"

  6201 unfolding map_project_def by (auto split: prod.split split_if_asm)

  6202

  6203 lemma trancl_set_ntrancl [code]:

  6204   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"

  6205   by (simp add: finite_trancl_ntranl)

  6206

  6207 lemma set_relcomp [code]:

  6208   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"

  6209   by (auto simp add: Bex_def)

  6210

  6211 lemma wf_set [code]:

  6212   "wf (set xs) = acyclic (set xs)"

  6213   by (simp add: wf_iff_acyclic_if_finite)

  6214

  6215 end

  6216
`