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