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