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