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