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