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