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