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