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