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