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