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