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