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