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