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