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