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