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