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