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