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