src/HOL/List.thy
 author nipkow Mon Feb 27 09:01:49 2012 +0100 (2012-02-27) changeset 46698 f1dfcf8be88d parent 46669 c1d2ab32174a child 46884 154dc6ec0041 permissions -rw-r--r--
converting "set [...]" to "{...}" in evaluation results
     1 (*  Title:      HOL/List.thy

     2     Author:     Tobias Nipkow

     3 *)

     4

     5 header {* The datatype of finite lists *}

     6

     7 theory List

     8 imports Plain Presburger Code_Numeral Quotient ATP

     9 uses

    10   ("Tools/list_code.ML")

    11   ("Tools/list_to_set_comprehension.ML")

    12 begin

    13

    14 datatype 'a list =

    15     Nil    ("[]")

    16   | Cons 'a  "'a list"    (infixr "#" 65)

    17

    18 syntax

    19   -- {* list Enumeration *}

    20   "_list" :: "args => 'a list"    ("[(_)]")

    21

    22 translations

    23   "[x, xs]" == "x#[xs]"

    24   "[x]" == "x#[]"

    25

    26

    27 subsection {* Basic list processing functions *}

    28

    29 primrec

    30   hd :: "'a list \<Rightarrow> 'a" where

    31   "hd (x # xs) = x"

    32

    33 primrec

    34   tl :: "'a list \<Rightarrow> 'a list" where

    35     "tl [] = []"

    36   | "tl (x # xs) = xs"

    37

    38 primrec

    39   last :: "'a list \<Rightarrow> 'a" where

    40   "last (x # xs) = (if xs = [] then x else last xs)"

    41

    42 primrec

    43   butlast :: "'a list \<Rightarrow> 'a list" where

    44     "butlast []= []"

    45   | "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"

    46

    47 primrec

    48   set :: "'a list \<Rightarrow> 'a set" where

    49     "set [] = {}"

    50   | "set (x # xs) = insert x (set xs)"

    51

    52 definition

    53   coset :: "'a list \<Rightarrow> 'a set" where

    54   [simp]: "coset xs = - set xs"

    55

    56 primrec

    57   map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

    58     "map f [] = []"

    59   | "map f (x # xs) = f x # map f xs"

    60

    61 primrec

    62   append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where

    63     append_Nil:"[] @ ys = ys"

    64   | append_Cons: "(x#xs) @ ys = x # xs @ ys"

    65

    66 primrec

    67   rev :: "'a list \<Rightarrow> 'a list" where

    68     "rev [] = []"

    69   | "rev (x # xs) = rev xs @ [x]"

    70

    71 primrec

    72   filter:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where

    73     "filter P [] = []"

    74   | "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"

    75

    76 syntax

    77   -- {* Special syntax for filter *}

    78   "_filter" :: "[pttrn, 'a list, bool] => 'a list"    ("(1[_<-_./ _])")

    79

    80 translations

    81   "[x<-xs . P]"== "CONST filter (%x. P) xs"

    82

    83 syntax (xsymbols)

    84   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")

    85 syntax (HTML output)

    86   "_filter" :: "[pttrn, 'a list, bool] => 'a list"("(1[_\<leftarrow>_ ./ _])")

    87

    88 primrec -- {* canonical argument order *}

    89   fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where

    90     "fold f [] = id"

    91   | "fold f (x # xs) = fold f xs \<circ> f x"

    92

    93 definition

    94   foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where

    95   [code_abbrev]: "foldr f xs = fold f (rev xs)"

    96

    97 definition

    98   foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where

    99   "foldl f s xs = fold (\<lambda>x s. f s x)  xs s"

   100

   101 primrec

   102   concat:: "'a list list \<Rightarrow> 'a list" where

   103     "concat [] = []"

   104   | "concat (x # xs) = x @ concat xs"

   105

   106 definition (in monoid_add)

   107   listsum :: "'a list \<Rightarrow> 'a" where

   108   "listsum xs = foldr plus xs 0"

   109

   110 primrec

   111   drop:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   112     drop_Nil: "drop n [] = []"

   113   | drop_Cons: "drop n (x # xs) = (case n of 0 \<Rightarrow> x # xs | Suc m \<Rightarrow> drop m xs)"

   114   -- {*Warning: simpset does not contain this definition, but separate

   115        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}

   116

   117 primrec

   118   take:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   119     take_Nil:"take n [] = []"

   120   | take_Cons: "take n (x # xs) = (case n of 0 \<Rightarrow> [] | Suc m \<Rightarrow> x # take m xs)"

   121   -- {*Warning: simpset does not contain this definition, but separate

   122        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}

   123

   124 primrec

   125   nth :: "'a list => nat => 'a" (infixl "!" 100) where

   126   nth_Cons: "(x # xs) ! n = (case n of 0 \<Rightarrow> x | Suc k \<Rightarrow> xs ! k)"

   127   -- {*Warning: simpset does not contain this definition, but separate

   128        theorems for @{text "n = 0"} and @{text "n = Suc k"} *}

   129

   130 primrec

   131   list_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where

   132     "list_update [] i v = []"

   133   | "list_update (x # xs) i v = (case i of 0 \<Rightarrow> v # xs | Suc j \<Rightarrow> x # list_update xs j v)"

   134

   135 nonterminal lupdbinds and lupdbind

   136

   137 syntax

   138   "_lupdbind":: "['a, 'a] => lupdbind"    ("(2_ :=/ _)")

   139   "" :: "lupdbind => lupdbinds"    ("_")

   140   "_lupdbinds" :: "[lupdbind, lupdbinds] => lupdbinds"    ("_,/ _")

   141   "_LUpdate" :: "['a, lupdbinds] => 'a"    ("_/[(_)]" [900,0] 900)

   142

   143 translations

   144   "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"

   145   "xs[i:=x]" == "CONST list_update xs i x"

   146

   147 primrec

   148   takeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   149     "takeWhile P [] = []"

   150   | "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"

   151

   152 primrec

   153   dropWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   154     "dropWhile P [] = []"

   155   | "dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"

   156

   157 primrec

   158   zip :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where

   159     "zip xs [] = []"

   160   | zip_Cons: "zip xs (y # ys) = (case xs of [] => [] | z # zs => (z, y) # zip zs ys)"

   161   -- {*Warning: simpset does not contain this definition, but separate

   162        theorems for @{text "xs = []"} and @{text "xs = z # zs"} *}

   163

   164 primrec

   165   upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_..</_'])") where

   166     upt_0: "[i..<0] = []"

   167   | upt_Suc: "[i..<(Suc j)] = (if i <= j then [i..<j] @ [j] else [])"

   168

   169 definition

   170   insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   171   "insert x xs = (if x \<in> set xs then xs else x # xs)"

   172

   173 hide_const (open) insert

   174 hide_fact (open) insert_def

   175

   176 primrec

   177   remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   178     "remove1 x [] = []"

   179   | "remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"

   180

   181 primrec

   182   removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   183     "removeAll x [] = []"

   184   | "removeAll x (y # xs) = (if x = y then removeAll x xs else y # removeAll x xs)"

   185

   186 primrec

   187   distinct :: "'a list \<Rightarrow> bool" where

   188     "distinct [] \<longleftrightarrow> True"

   189   | "distinct (x # xs) \<longleftrightarrow> x \<notin> set xs \<and> distinct xs"

   190

   191 primrec

   192   remdups :: "'a list \<Rightarrow> 'a list" where

   193     "remdups [] = []"

   194   | "remdups (x # xs) = (if x \<in> set xs then remdups xs else x # remdups xs)"

   195

   196 primrec

   197   replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where

   198     replicate_0: "replicate 0 x = []"

   199   | replicate_Suc: "replicate (Suc n) x = x # replicate n x"

   200

   201 text {*

   202   Function @{text size} is overloaded for all datatypes. Users may

   203   refer to the list version as @{text length}. *}

   204

   205 abbreviation

   206   length :: "'a list \<Rightarrow> nat" where

   207   "length \<equiv> size"

   208

   209 primrec rotate1 :: "'a list \<Rightarrow> 'a list" where

   210   "rotate1 [] = []" |

   211   "rotate1 (x # xs) = xs @ [x]"

   212

   213 definition

   214   rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   215   "rotate n = rotate1 ^^ n"

   216

   217 definition

   218   list_all2 :: "('a => 'b => bool) => 'a list => 'b list => bool" where

   219   "list_all2 P xs ys =

   220     (length xs = length ys \<and> (\<forall>(x, y) \<in> set (zip xs ys). P x y))"

   221

   222 definition

   223   sublist :: "'a list => nat set => 'a list" where

   224   "sublist xs A = map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [0..<size xs]))"

   225

   226 fun splice :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   227 "splice [] ys = ys" |

   228 "splice xs [] = xs" |

   229 "splice (x#xs) (y#ys) = x # y # splice xs ys"

   230

   231 text{*

   232 \begin{figure}[htbp]

   233 \fbox{

   234 \begin{tabular}{l}

   235 @{lemma "[a,b]@[c,d] = [a,b,c,d]" by simp}\\

   236 @{lemma "length [a,b,c] = 3" by simp}\\

   237 @{lemma "set [a,b,c] = {a,b,c}" by simp}\\

   238 @{lemma "map f [a,b,c] = [f a, f b, f c]" by simp}\\

   239 @{lemma "rev [a,b,c] = [c,b,a]" by simp}\\

   240 @{lemma "hd [a,b,c,d] = a" by simp}\\

   241 @{lemma "tl [a,b,c,d] = [b,c,d]" by simp}\\

   242 @{lemma "last [a,b,c,d] = d" by simp}\\

   243 @{lemma "butlast [a,b,c,d] = [a,b,c]" by simp}\\

   244 @{lemma[source] "filter (\<lambda>n::nat. n<2) [0,2,1] = [0,1]" by simp}\\

   245 @{lemma "concat [[a,b],[c,d,e],[],[f]] = [a,b,c,d,e,f]" by simp}\\

   246 @{lemma "fold f [a,b,c] x = f c (f b (f a x))" by simp}\\

   247 @{lemma "foldr f [a,b,c] x = f a (f b (f c x))" by (simp add: foldr_def)}\\

   248 @{lemma "foldl f x [a,b,c] = f (f (f x a) b) c" by (simp add: foldl_def)}\\

   249 @{lemma "zip [a,b,c] [x,y,z] = [(a,x),(b,y),(c,z)]" by simp}\\

   250 @{lemma "zip [a,b] [x,y,z] = [(a,x),(b,y)]" by simp}\\

   251 @{lemma "splice [a,b,c] [x,y,z] = [a,x,b,y,c,z]" by simp}\\

   252 @{lemma "splice [a,b,c,d] [x,y] = [a,x,b,y,c,d]" by simp}\\

   253 @{lemma "take 2 [a,b,c,d] = [a,b]" by simp}\\

   254 @{lemma "take 6 [a,b,c,d] = [a,b,c,d]" by simp}\\

   255 @{lemma "drop 2 [a,b,c,d] = [c,d]" by simp}\\

   256 @{lemma "drop 6 [a,b,c,d] = []" by simp}\\

   257 @{lemma "takeWhile (%n::nat. n<3) [1,2,3,0] = [1,2]" by simp}\\

   258 @{lemma "dropWhile (%n::nat. n<3) [1,2,3,0] = [3,0]" by simp}\\

   259 @{lemma "distinct [2,0,1::nat]" by simp}\\

   260 @{lemma "remdups [2,0,2,1::nat,2] = [0,1,2]" by simp}\\

   261 @{lemma "List.insert 2 [0::nat,1,2] = [0,1,2]" by (simp add: List.insert_def)}\\

   262 @{lemma "List.insert 3 [0::nat,1,2] = [3,0,1,2]" by (simp add: List.insert_def)}\\

   263 @{lemma "remove1 2 [2,0,2,1::nat,2] = [0,2,1,2]" by simp}\\

   264 @{lemma "removeAll 2 [2,0,2,1::nat,2] = [0,1]" by simp}\\

   265 @{lemma "nth [a,b,c,d] 2 = c" by simp}\\

   266 @{lemma "[a,b,c,d][2 := x] = [a,b,x,d]" by simp}\\

   267 @{lemma "sublist [a,b,c,d,e] {0,2,3} = [a,c,d]" by (simp add:sublist_def)}\\

   268 @{lemma "rotate1 [a,b,c,d] = [b,c,d,a]" by simp}\\

   269 @{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate_def eval_nat_numeral)}\\

   270 @{lemma "replicate 4 a = [a,a,a,a]" by (simp add:eval_nat_numeral)}\\

   271 @{lemma "[2..<5] = [2,3,4]" by (simp add:eval_nat_numeral)}\\

   272 @{lemma "listsum [1,2,3::nat] = 6" by (simp add: listsum_def foldr_def)}

   273 \end{tabular}}

   274 \caption{Characteristic examples}

   275 \label{fig:Characteristic}

   276 \end{figure}

   277 Figure~\ref{fig:Characteristic} shows characteristic examples

   278 that should give an intuitive understanding of the above functions.

   279 *}

   280

   281 text{* The following simple sort functions are intended for proofs,

   282 not for efficient implementations. *}

   283

   284 context linorder

   285 begin

   286

   287 inductive sorted :: "'a list \<Rightarrow> bool" where

   288   Nil [iff]: "sorted []"

   289 | Cons: "\<forall>y\<in>set xs. x \<le> y \<Longrightarrow> sorted xs \<Longrightarrow> sorted (x # xs)"

   290

   291 lemma sorted_single [iff]:

   292   "sorted [x]"

   293   by (rule sorted.Cons) auto

   294

   295 lemma sorted_many:

   296   "x \<le> y \<Longrightarrow> sorted (y # zs) \<Longrightarrow> sorted (x # y # zs)"

   297   by (rule sorted.Cons) (cases "y # zs" rule: sorted.cases, auto)

   298

   299 lemma sorted_many_eq [simp, code]:

   300   "sorted (x # y # zs) \<longleftrightarrow> x \<le> y \<and> sorted (y # zs)"

   301   by (auto intro: sorted_many elim: sorted.cases)

   302

   303 lemma [code]:

   304   "sorted [] \<longleftrightarrow> True"

   305   "sorted [x] \<longleftrightarrow> True"

   306   by simp_all

   307

   308 primrec insort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where

   309   "insort_key f x [] = [x]" |

   310   "insort_key f x (y#ys) = (if f x \<le> f y then (x#y#ys) else y#(insort_key f x ys))"

   311

   312 definition sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where

   313   "sort_key f xs = foldr (insort_key f) xs []"

   314

   315 definition insort_insert_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where

   316   "insort_insert_key f x xs = (if f x \<in> f  set xs then xs else insort_key f x xs)"

   317

   318 abbreviation "sort \<equiv> sort_key (\<lambda>x. x)"

   319 abbreviation "insort \<equiv> insort_key (\<lambda>x. x)"

   320 abbreviation "insort_insert \<equiv> insort_insert_key (\<lambda>x. x)"

   321

   322 end

   323

   324

   325 subsubsection {* List comprehension *}

   326

   327 text{* Input syntax for Haskell-like list comprehension notation.

   328 Typical example: @{text"[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x \<noteq> y]"},

   329 the list of all pairs of distinct elements from @{text xs} and @{text ys}.

   330 The syntax is as in Haskell, except that @{text"|"} becomes a dot

   331 (like in Isabelle's set comprehension): @{text"[e. x \<leftarrow> xs, \<dots>]"} rather than

   332 \verb![e| x <- xs, ...]!.

   333

   334 The qualifiers after the dot are

   335 \begin{description}

   336 \item[generators] @{text"p \<leftarrow> xs"},

   337  where @{text p} is a pattern and @{text xs} an expression of list type, or

   338 \item[guards] @{text"b"}, where @{text b} is a boolean expression.

   339 %\item[local bindings] @ {text"let x = e"}.

   340 \end{description}

   341

   342 Just like in Haskell, list comprehension is just a shorthand. To avoid

   343 misunderstandings, the translation into desugared form is not reversed

   344 upon output. Note that the translation of @{text"[e. x \<leftarrow> xs]"} is

   345 optmized to @{term"map (%x. e) xs"}.

   346

   347 It is easy to write short list comprehensions which stand for complex

   348 expressions. During proofs, they may become unreadable (and

   349 mangled). In such cases it can be advisable to introduce separate

   350 definitions for the list comprehensions in question.  *}

   351

   352 nonterminal lc_qual and lc_quals

   353

   354 syntax

   355   "_listcompr" :: "'a \<Rightarrow> lc_qual \<Rightarrow> lc_quals \<Rightarrow> 'a list"  ("[_ . __")

   356   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ <- _")

   357   "_lc_test" :: "bool \<Rightarrow> lc_qual" ("_")

   358   (*"_lc_let" :: "letbinds => lc_qual"  ("let _")*)

   359   "_lc_end" :: "lc_quals" ("]")

   360   "_lc_quals" :: "lc_qual \<Rightarrow> lc_quals \<Rightarrow> lc_quals"  (", __")

   361   "_lc_abs" :: "'a => 'b list => 'b list"

   362

   363 (* These are easier than ML code but cannot express the optimized

   364    translation of [e. p<-xs]

   365 translations

   366   "[e. p<-xs]" => "concat(map (_lc_abs p [e]) xs)"

   367   "_listcompr e (_lc_gen p xs) (_lc_quals Q Qs)"

   368    => "concat (map (_lc_abs p (_listcompr e Q Qs)) xs)"

   369   "[e. P]" => "if P then [e] else []"

   370   "_listcompr e (_lc_test P) (_lc_quals Q Qs)"

   371    => "if P then (_listcompr e Q Qs) else []"

   372   "_listcompr e (_lc_let b) (_lc_quals Q Qs)"

   373    => "_Let b (_listcompr e Q Qs)"

   374 *)

   375

   376 syntax (xsymbols)

   377   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")

   378 syntax (HTML output)

   379   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")

   380

   381 parse_translation (advanced) {*

   382   let

   383     val NilC = Syntax.const @{const_syntax Nil};

   384     val ConsC = Syntax.const @{const_syntax Cons};

   385     val mapC = Syntax.const @{const_syntax map};

   386     val concatC = Syntax.const @{const_syntax concat};

   387     val IfC = Syntax.const @{const_syntax If};

   388

   389     fun single x = ConsC $x$ NilC;

   390

   391     fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)

   392       let

   393         (* FIXME proper name context!? *)

   394         val x =

   395           Free (singleton (Name.variant_list (fold Term.add_free_names [p, e] [])) "x", dummyT);

   396         val e = if opti then single e else e;

   397         val case1 = Syntax.const @{syntax_const "_case1"} $p$ e;

   398         val case2 =

   399           Syntax.const @{syntax_const "_case1"} $  400 Syntax.const @{const_syntax dummy_pattern}$ NilC;

   401         val cs = Syntax.const @{syntax_const "_case2"} $case1$ case2;

   402       in Syntax_Trans.abs_tr [x, Datatype_Case.case_tr false ctxt [x, cs]] end;

   403

   404     fun abs_tr ctxt p e opti =

   405       (case Term_Position.strip_positions p of

   406         Free (s, T) =>

   407           let

   408             val thy = Proof_Context.theory_of ctxt;

   409             val s' = Proof_Context.intern_const ctxt s;

   410           in

   411             if Sign.declared_const thy s'

   412             then (pat_tr ctxt p e opti, false)

   413             else (Syntax_Trans.abs_tr [p, e], true)

   414           end

   415       | _ => (pat_tr ctxt p e opti, false));

   416

   417     fun lc_tr ctxt [e, Const (@{syntax_const "_lc_test"}, _) $b, qs] =   418 let   419 val res =   420 (case qs of   421 Const (@{syntax_const "_lc_end"}, _) => single e   422 | Const (@{syntax_const "_lc_quals"}, _)$ q $qs => lc_tr ctxt [e, q, qs]);   423 in IfC$ b $res$ NilC end

   424       | lc_tr ctxt

   425             [e, Const (@{syntax_const "_lc_gen"}, _) $p$ es,

   426               Const(@{syntax_const "_lc_end"}, _)] =

   427           (case abs_tr ctxt p e true of

   428             (f, true) => mapC $f$ es

   429           | (f, false) => concatC $(mapC$ f $es))   430 | lc_tr ctxt   431 [e, Const (@{syntax_const "_lc_gen"}, _)$ p $es,   432 Const (@{syntax_const "_lc_quals"}, _)$ q $qs] =   433 let val e' = lc_tr ctxt [e, q, qs];   434 in concatC$ (mapC $(fst (abs_tr ctxt p e' false))$ es) end;

   435

   436   in [(@{syntax_const "_listcompr"}, lc_tr)] end

   437 *}

   438

   439 ML {*

   440   let

   441     val read = Syntax.read_term @{context};

   442     fun check s1 s2 = read s1 aconv read s2 orelse error ("Check failed: " ^ quote s1);

   443   in

   444     check "[(x,y,z). b]" "if b then [(x, y, z)] else []";

   445     check "[(x,y,z). x\<leftarrow>xs]" "map (\<lambda>x. (x, y, z)) xs";

   446     check "[e x y. x\<leftarrow>xs, y\<leftarrow>ys]" "concat (map (\<lambda>x. map (\<lambda>y. e x y) ys) xs)";

   447     check "[(x,y,z). x<a, x>b]" "if x < a then if b < x then [(x, y, z)] else [] else []";

   448     check "[(x,y,z). x\<leftarrow>xs, x>b]" "concat (map (\<lambda>x. if b < x then [(x, y, z)] else []) xs)";

   449     check "[(x,y,z). x<a, x\<leftarrow>xs]" "if x < a then map (\<lambda>x. (x, y, z)) xs else []";

   450     check "[(x,y). Cons True x \<leftarrow> xs]"

   451       "concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | True # x \<Rightarrow> [(x, y)] | False # x \<Rightarrow> []) xs)";

   452     check "[(x,y,z). Cons x [] \<leftarrow> xs]"

   453       "concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | [x] \<Rightarrow> [(x, y, z)] | x # aa # lista \<Rightarrow> []) xs)";

   454     check "[(x,y,z). x<a, x>b, x=d]"

   455       "if x < a then if b < x then if x = d then [(x, y, z)] else [] else [] else []";

   456     check "[(x,y,z). x<a, x>b, y\<leftarrow>ys]"

   457       "if x < a then if b < x then map (\<lambda>y. (x, y, z)) ys else [] else []";

   458     check "[(x,y,z). x<a, x\<leftarrow>xs,y>b]"

   459       "if x < a then concat (map (\<lambda>x. if b < y then [(x, y, z)] else []) xs) else []";

   460     check "[(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys]"

   461       "if x < a then concat (map (\<lambda>x. map (\<lambda>y. (x, y, z)) ys) xs) else []";

   462     check "[(x,y,z). x\<leftarrow>xs, x>b, y<a]"

   463       "concat (map (\<lambda>x. if b < x then if y < a then [(x, y, z)] else [] else []) xs)";

   464     check "[(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys]"

   465       "concat (map (\<lambda>x. if b < x then map (\<lambda>y. (x, y, z)) ys else []) xs)";

   466     check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x]"

   467       "concat (map (\<lambda>x. concat (map (\<lambda>y. if x < y then [(x, y, z)] else []) ys)) xs)";

   468     check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs]"

   469       "concat (map (\<lambda>x. concat (map (\<lambda>y. map (\<lambda>z. (x, y, z)) zs) ys)) xs)"

   470   end;

   471 *}

   472

   473 (*

   474 term "[(x,y). x\<leftarrow>xs, let xx = x+x, y\<leftarrow>ys, y \<noteq> xx]"

   475 *)

   476

   477

   478 use "Tools/list_to_set_comprehension.ML"

   479

   480 simproc_setup list_to_set_comprehension ("set xs") = {* K List_to_Set_Comprehension.simproc *}

   481

   482 code_datatype set coset

   483

   484 hide_const (open) coset

   485

   486 subsubsection {* @{const Nil} and @{const Cons} *}

   487

   488 lemma not_Cons_self [simp]:

   489   "xs \<noteq> x # xs"

   490 by (induct xs) auto

   491

   492 lemma not_Cons_self2 [simp]:

   493   "x # xs \<noteq> xs"

   494 by (rule not_Cons_self [symmetric])

   495

   496 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"

   497 by (induct xs) auto

   498

   499 lemma length_induct:

   500   "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"

   501 by (rule measure_induct [of length]) iprover

   502

   503 lemma list_nonempty_induct [consumes 1, case_names single cons]:

   504   assumes "xs \<noteq> []"

   505   assumes single: "\<And>x. P [x]"

   506   assumes cons: "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)"

   507   shows "P xs"

   508 using xs \<noteq> [] proof (induct xs)

   509   case Nil then show ?case by simp

   510 next

   511   case (Cons x xs) show ?case proof (cases xs)

   512     case Nil with single show ?thesis by simp

   513   next

   514     case Cons then have "xs \<noteq> []" by simp

   515     moreover with Cons.hyps have "P xs" .

   516     ultimately show ?thesis by (rule cons)

   517   qed

   518 qed

   519

   520 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"

   521   by (auto intro!: inj_onI)

   522

   523 subsubsection {* @{const length} *}

   524

   525 text {*

   526   Needs to come before @{text "@"} because of theorem @{text

   527   append_eq_append_conv}.

   528 *}

   529

   530 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"

   531 by (induct xs) auto

   532

   533 lemma length_map [simp]: "length (map f xs) = length xs"

   534 by (induct xs) auto

   535

   536 lemma length_rev [simp]: "length (rev xs) = length xs"

   537 by (induct xs) auto

   538

   539 lemma length_tl [simp]: "length (tl xs) = length xs - 1"

   540 by (cases xs) auto

   541

   542 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"

   543 by (induct xs) auto

   544

   545 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"

   546 by (induct xs) auto

   547

   548 lemma length_pos_if_in_set: "x : set xs \<Longrightarrow> length xs > 0"

   549 by auto

   550

   551 lemma length_Suc_conv:

   552 "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"

   553 by (induct xs) auto

   554

   555 lemma Suc_length_conv:

   556 "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"

   557 apply (induct xs, simp, simp)

   558 apply blast

   559 done

   560

   561 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False"

   562   by (induct xs) auto

   563

   564 lemma list_induct2 [consumes 1, case_names Nil Cons]:

   565   "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>

   566    (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))

   567    \<Longrightarrow> P xs ys"

   568 proof (induct xs arbitrary: ys)

   569   case Nil then show ?case by simp

   570 next

   571   case (Cons x xs ys) then show ?case by (cases ys) simp_all

   572 qed

   573

   574 lemma list_induct3 [consumes 2, case_names Nil Cons]:

   575   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>

   576    (\<And>x xs y ys z zs. length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P xs ys zs \<Longrightarrow> P (x#xs) (y#ys) (z#zs))

   577    \<Longrightarrow> P xs ys zs"

   578 proof (induct xs arbitrary: ys zs)

   579   case Nil then show ?case by simp

   580 next

   581   case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)

   582     (cases zs, simp_all)

   583 qed

   584

   585 lemma list_induct4 [consumes 3, case_names Nil Cons]:

   586   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>

   587    P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>

   588    length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>

   589    P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"

   590 proof (induct xs arbitrary: ys zs ws)

   591   case Nil then show ?case by simp

   592 next

   593   case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)

   594 qed

   595

   596 lemma list_induct2':

   597   "\<lbrakk> P [] [];

   598   \<And>x xs. P (x#xs) [];

   599   \<And>y ys. P [] (y#ys);

   600    \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>

   601  \<Longrightarrow> P xs ys"

   602 by (induct xs arbitrary: ys) (case_tac x, auto)+

   603

   604 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"

   605 by (rule Eq_FalseI) auto

   606

   607 simproc_setup list_neq ("(xs::'a list) = ys") = {*

   608 (*

   609 Reduces xs=ys to False if xs and ys cannot be of the same length.

   610 This is the case if the atomic sublists of one are a submultiset

   611 of those of the other list and there are fewer Cons's in one than the other.

   612 *)

   613

   614 let

   615

   616 fun len (Const(@{const_name Nil},_)) acc = acc

   617   | len (Const(@{const_name Cons},_) $_$ xs) (ts,n) = len xs (ts,n+1)

   618   | len (Const(@{const_name append},_) $xs$ ys) acc = len xs (len ys acc)

   619   | len (Const(@{const_name rev},_) $xs) acc = len xs acc   620 | len (Const(@{const_name map},_)$ _ $xs) acc = len xs acc   621 | len t (ts,n) = (t::ts,n);   622   623 fun list_neq _ ss ct =   624 let   625 val (Const(_,eqT)$ lhs $rhs) = Thm.term_of ct;   626 val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);   627 fun prove_neq() =   628 let   629 val Type(_,listT::_) = eqT;   630 val size = HOLogic.size_const listT;   631 val eq_len = HOLogic.mk_eq (size$ lhs, size $rhs);   632 val neq_len = HOLogic.mk_Trueprop (HOLogic.Not$ eq_len);

   633         val thm = Goal.prove (Simplifier.the_context ss) [] [] neq_len

   634           (K (simp_tac (Simplifier.inherit_context ss @{simpset}) 1));

   635       in SOME (thm RS @{thm neq_if_length_neq}) end

   636   in

   637     if m < n andalso submultiset (op aconv) (ls,rs) orelse

   638        n < m andalso submultiset (op aconv) (rs,ls)

   639     then prove_neq() else NONE

   640   end;

   641 in list_neq end;

   642 *}

   643

   644

   645 subsubsection {* @{text "@"} -- append *}

   646

   647 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"

   648 by (induct xs) auto

   649

   650 lemma append_Nil2 [simp]: "xs @ [] = xs"

   651 by (induct xs) auto

   652

   653 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"

   654 by (induct xs) auto

   655

   656 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"

   657 by (induct xs) auto

   658

   659 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"

   660 by (induct xs) auto

   661

   662 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"

   663 by (induct xs) auto

   664

   665 lemma append_eq_append_conv [simp, no_atp]:

   666  "length xs = length ys \<or> length us = length vs

   667  ==> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"

   668 apply (induct xs arbitrary: ys)

   669  apply (case_tac ys, simp, force)

   670 apply (case_tac ys, force, simp)

   671 done

   672

   673 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =

   674   (EX us. xs = zs @ us & us @ ys = ts | xs @ us = zs & ys = us@ ts)"

   675 apply (induct xs arbitrary: ys zs ts)

   676  apply fastforce

   677 apply(case_tac zs)

   678  apply simp

   679 apply fastforce

   680 done

   681

   682 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"

   683 by simp

   684

   685 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"

   686 by simp

   687

   688 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"

   689 by simp

   690

   691 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"

   692 using append_same_eq [of _ _ "[]"] by auto

   693

   694 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"

   695 using append_same_eq [of "[]"] by auto

   696

   697 lemma hd_Cons_tl [simp,no_atp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"

   698 by (induct xs) auto

   699

   700 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"

   701 by (induct xs) auto

   702

   703 lemma hd_append2 [simp]: "xs \<noteq> [] ==> hd (xs @ ys) = hd xs"

   704 by (simp add: hd_append split: list.split)

   705

   706 lemma tl_append: "tl (xs @ ys) = (case xs of [] => tl ys | z#zs => zs @ ys)"

   707 by (simp split: list.split)

   708

   709 lemma tl_append2 [simp]: "xs \<noteq> [] ==> tl (xs @ ys) = tl xs @ ys"

   710 by (simp add: tl_append split: list.split)

   711

   712

   713 lemma Cons_eq_append_conv: "x#xs = ys@zs =

   714  (ys = [] & x#xs = zs | (EX ys'. x#ys' = ys & xs = ys'@zs))"

   715 by(cases ys) auto

   716

   717 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =

   718  (ys = [] & zs = x#xs | (EX ys'. ys = x#ys' & ys'@zs = xs))"

   719 by(cases ys) auto

   720

   721

   722 text {* Trivial rules for solving @{text "@"}-equations automatically. *}

   723

   724 lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"

   725 by simp

   726

   727 lemma Cons_eq_appendI:

   728 "[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"

   729 by (drule sym) simp

   730

   731 lemma append_eq_appendI:

   732 "[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"

   733 by (drule sym) simp

   734

   735

   736 text {*

   737 Simplification procedure for all list equalities.

   738 Currently only tries to rearrange @{text "@"} to see if

   739 - both lists end in a singleton list,

   740 - or both lists end in the same list.

   741 *}

   742

   743 simproc_setup list_eq ("(xs::'a list) = ys")  = {*

   744   let

   745     fun last (cons as Const (@{const_name Cons}, _) $_$ xs) =

   746           (case xs of Const (@{const_name Nil}, _) => cons | _ => last xs)

   747       | last (Const(@{const_name append},_) $_$ ys) = last ys

   748       | last t = t;

   749

   750     fun list1 (Const(@{const_name Cons},_) $_$ Const(@{const_name Nil},_)) = true

   751       | list1 _ = false;

   752

   753     fun butlast ((cons as Const(@{const_name Cons},_) $x)$ xs) =

   754           (case xs of Const (@{const_name Nil}, _) => xs | _ => cons $butlast xs)   755 | butlast ((app as Const (@{const_name append}, _)$ xs) $ys) = app$ butlast ys

   756       | butlast xs = Const(@{const_name Nil}, fastype_of xs);

   757

   758     val rearr_ss =

   759       HOL_basic_ss addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}];

   760

   761     fun list_eq ss (F as (eq as Const(_,eqT)) $lhs$ rhs) =

   762       let

   763         val lastl = last lhs and lastr = last rhs;

   764         fun rearr conv =

   765           let

   766             val lhs1 = butlast lhs and rhs1 = butlast rhs;

   767             val Type(_,listT::_) = eqT

   768             val appT = [listT,listT] ---> listT

   769             val app = Const(@{const_name append},appT)

   770             val F2 = eq $(app$lhs1$lastl)$ (app$rhs1$lastr)

   771             val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (F,F2));

   772             val thm = Goal.prove (Simplifier.the_context ss) [] [] eq

   773               (K (simp_tac (Simplifier.inherit_context ss rearr_ss) 1));

   774           in SOME ((conv RS (thm RS trans)) RS eq_reflection) end;

   775       in

   776         if list1 lastl andalso list1 lastr then rearr @{thm append1_eq_conv}

   777         else if lastl aconv lastr then rearr @{thm append_same_eq}

   778         else NONE

   779       end;

   780   in fn _ => fn ss => fn ct => list_eq ss (term_of ct) end;

   781 *}

   782

   783

   784 subsubsection {* @{text map} *}

   785

   786 lemma hd_map:

   787   "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"

   788   by (cases xs) simp_all

   789

   790 lemma map_tl:

   791   "map f (tl xs) = tl (map f xs)"

   792   by (cases xs) simp_all

   793

   794 lemma map_ext: "(!!x. x : set xs --> f x = g x) ==> map f xs = map g xs"

   795 by (induct xs) simp_all

   796

   797 lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"

   798 by (rule ext, induct_tac xs) auto

   799

   800 lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"

   801 by (induct xs) auto

   802

   803 lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"

   804 by (induct xs) auto

   805

   806 lemma map_comp_map[simp]: "((map f) o (map g)) = map(f o g)"

   807 apply(rule ext)

   808 apply(simp)

   809 done

   810

   811 lemma rev_map: "rev (map f xs) = map f (rev xs)"

   812 by (induct xs) auto

   813

   814 lemma map_eq_conv[simp]: "(map f xs = map g xs) = (!x : set xs. f x = g x)"

   815 by (induct xs) auto

   816

   817 lemma map_cong [fundef_cong]:

   818   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g ys"

   819   by simp

   820

   821 lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"

   822 by (cases xs) auto

   823

   824 lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"

   825 by (cases xs) auto

   826

   827 lemma map_eq_Cons_conv:

   828  "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"

   829 by (cases xs) auto

   830

   831 lemma Cons_eq_map_conv:

   832  "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"

   833 by (cases ys) auto

   834

   835 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]

   836 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]

   837 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]

   838

   839 lemma ex_map_conv:

   840   "(EX xs. ys = map f xs) = (ALL y : set ys. EX x. y = f x)"

   841 by(induct ys, auto simp add: Cons_eq_map_conv)

   842

   843 lemma map_eq_imp_length_eq:

   844   assumes "map f xs = map g ys"

   845   shows "length xs = length ys"

   846 using assms proof (induct ys arbitrary: xs)

   847   case Nil then show ?case by simp

   848 next

   849   case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto

   850   from Cons xs have "map f zs = map g ys" by simp

   851   moreover with Cons have "length zs = length ys" by blast

   852   with xs show ?case by simp

   853 qed

   854

   855 lemma map_inj_on:

   856  "[| map f xs = map f ys; inj_on f (set xs Un set ys) |]

   857   ==> xs = ys"

   858 apply(frule map_eq_imp_length_eq)

   859 apply(rotate_tac -1)

   860 apply(induct rule:list_induct2)

   861  apply simp

   862 apply(simp)

   863 apply (blast intro:sym)

   864 done

   865

   866 lemma inj_on_map_eq_map:

   867  "inj_on f (set xs Un set ys) \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"

   868 by(blast dest:map_inj_on)

   869

   870 lemma map_injective:

   871  "map f xs = map f ys ==> inj f ==> xs = ys"

   872 by (induct ys arbitrary: xs) (auto dest!:injD)

   873

   874 lemma inj_map_eq_map[simp]: "inj f \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"

   875 by(blast dest:map_injective)

   876

   877 lemma inj_mapI: "inj f ==> inj (map f)"

   878 by (iprover dest: map_injective injD intro: inj_onI)

   879

   880 lemma inj_mapD: "inj (map f) ==> inj f"

   881 apply (unfold inj_on_def, clarify)

   882 apply (erule_tac x = "[x]" in ballE)

   883  apply (erule_tac x = "[y]" in ballE, simp, blast)

   884 apply blast

   885 done

   886

   887 lemma inj_map[iff]: "inj (map f) = inj f"

   888 by (blast dest: inj_mapD intro: inj_mapI)

   889

   890 lemma inj_on_mapI: "inj_on f (\<Union>(set  A)) \<Longrightarrow> inj_on (map f) A"

   891 apply(rule inj_onI)

   892 apply(erule map_inj_on)

   893 apply(blast intro:inj_onI dest:inj_onD)

   894 done

   895

   896 lemma map_idI: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = x) \<Longrightarrow> map f xs = xs"

   897 by (induct xs, auto)

   898

   899 lemma map_fun_upd [simp]: "y \<notin> set xs \<Longrightarrow> map (f(y:=v)) xs = map f xs"

   900 by (induct xs) auto

   901

   902 lemma map_fst_zip[simp]:

   903   "length xs = length ys \<Longrightarrow> map fst (zip xs ys) = xs"

   904 by (induct rule:list_induct2, simp_all)

   905

   906 lemma map_snd_zip[simp]:

   907   "length xs = length ys \<Longrightarrow> map snd (zip xs ys) = ys"

   908 by (induct rule:list_induct2, simp_all)

   909

   910 enriched_type map: map

   911   by (simp_all add: fun_eq_iff id_def)

   912

   913

   914 subsubsection {* @{text rev} *}

   915

   916 lemma rev_append [simp]: "rev (xs @ ys) = rev ys @ rev xs"

   917 by (induct xs) auto

   918

   919 lemma rev_rev_ident [simp]: "rev (rev xs) = xs"

   920 by (induct xs) auto

   921

   922 lemma rev_swap: "(rev xs = ys) = (xs = rev ys)"

   923 by auto

   924

   925 lemma rev_is_Nil_conv [iff]: "(rev xs = []) = (xs = [])"

   926 by (induct xs) auto

   927

   928 lemma Nil_is_rev_conv [iff]: "([] = rev xs) = (xs = [])"

   929 by (induct xs) auto

   930

   931 lemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"

   932 by (cases xs) auto

   933

   934 lemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"

   935 by (cases xs) auto

   936

   937 lemma rev_is_rev_conv [iff, no_atp]: "(rev xs = rev ys) = (xs = ys)"

   938 apply (induct xs arbitrary: ys, force)

   939 apply (case_tac ys, simp, force)

   940 done

   941

   942 lemma inj_on_rev[iff]: "inj_on rev A"

   943 by(simp add:inj_on_def)

   944

   945 lemma rev_induct [case_names Nil snoc]:

   946   "[| P []; !!x xs. P xs ==> P (xs @ [x]) |] ==> P xs"

   947 apply(simplesubst rev_rev_ident[symmetric])

   948 apply(rule_tac list = "rev xs" in list.induct, simp_all)

   949 done

   950

   951 lemma rev_exhaust [case_names Nil snoc]:

   952   "(xs = [] ==> P) ==>(!!ys y. xs = ys @ [y] ==> P) ==> P"

   953 by (induct xs rule: rev_induct) auto

   954

   955 lemmas rev_cases = rev_exhaust

   956

   957 lemma rev_eq_Cons_iff[iff]: "(rev xs = y#ys) = (xs = rev ys @ [y])"

   958 by(rule rev_cases[of xs]) auto

   959

   960

   961 subsubsection {* @{text set} *}

   962

   963 declare set.simps [code_post]  --"pretty output"

   964

   965 lemma finite_set [iff]: "finite (set xs)"

   966 by (induct xs) auto

   967

   968 lemma set_append [simp]: "set (xs @ ys) = (set xs \<union> set ys)"

   969 by (induct xs) auto

   970

   971 lemma hd_in_set[simp]: "xs \<noteq> [] \<Longrightarrow> hd xs : set xs"

   972 by(cases xs) auto

   973

   974 lemma set_subset_Cons: "set xs \<subseteq> set (x # xs)"

   975 by auto

   976

   977 lemma set_ConsD: "y \<in> set (x # xs) \<Longrightarrow> y=x \<or> y \<in> set xs"

   978 by auto

   979

   980 lemma set_empty [iff]: "(set xs = {}) = (xs = [])"

   981 by (induct xs) auto

   982

   983 lemma set_empty2[iff]: "({} = set xs) = (xs = [])"

   984 by(induct xs) auto

   985

   986 lemma set_rev [simp]: "set (rev xs) = set xs"

   987 by (induct xs) auto

   988

   989 lemma set_map [simp]: "set (map f xs) = f(set xs)"

   990 by (induct xs) auto

   991

   992 lemma set_filter [simp]: "set (filter P xs) = {x. x : set xs \<and> P x}"

   993 by (induct xs) auto

   994

   995 lemma set_upt [simp]: "set[i..<j] = {i..<j}"

   996 by (induct j) auto

   997

   998

   999 lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"

  1000 proof (induct xs)

  1001   case Nil thus ?case by simp

  1002 next

  1003   case Cons thus ?case by (auto intro: Cons_eq_appendI)

  1004 qed

  1005

  1006 lemma in_set_conv_decomp: "x \<in> set xs \<longleftrightarrow> (\<exists>ys zs. xs = ys @ x # zs)"

  1007   by (auto elim: split_list)

  1008

  1009 lemma split_list_first: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys"

  1010 proof (induct xs)

  1011   case Nil thus ?case by simp

  1012 next

  1013   case (Cons a xs)

  1014   show ?case

  1015   proof cases

  1016     assume "x = a" thus ?case using Cons by fastforce

  1017   next

  1018     assume "x \<noteq> a" thus ?case using Cons by(fastforce intro!: Cons_eq_appendI)

  1019   qed

  1020 qed

  1021

  1022 lemma in_set_conv_decomp_first:

  1023   "(x : set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys)"

  1024   by (auto dest!: split_list_first)

  1025

  1026 lemma split_list_last: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs"

  1027 proof (induct xs rule: rev_induct)

  1028   case Nil thus ?case by simp

  1029 next

  1030   case (snoc a xs)

  1031   show ?case

  1032   proof cases

  1033     assume "x = a" thus ?case using snoc by (metis List.set.simps(1) emptyE)

  1034   next

  1035     assume "x \<noteq> a" thus ?case using snoc by fastforce

  1036   qed

  1037 qed

  1038

  1039 lemma in_set_conv_decomp_last:

  1040   "(x : set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs)"

  1041   by (auto dest!: split_list_last)

  1042

  1043 lemma split_list_prop: "\<exists>x \<in> set xs. P x \<Longrightarrow> \<exists>ys x zs. xs = ys @ x # zs & P x"

  1044 proof (induct xs)

  1045   case Nil thus ?case by simp

  1046 next

  1047   case Cons thus ?case

  1048     by(simp add:Bex_def)(metis append_Cons append.simps(1))

  1049 qed

  1050

  1051 lemma split_list_propE:

  1052   assumes "\<exists>x \<in> set xs. P x"

  1053   obtains ys x zs where "xs = ys @ x # zs" and "P x"

  1054 using split_list_prop [OF assms] by blast

  1055

  1056 lemma split_list_first_prop:

  1057   "\<exists>x \<in> set xs. P x \<Longrightarrow>

  1058    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"

  1059 proof (induct xs)

  1060   case Nil thus ?case by simp

  1061 next

  1062   case (Cons x xs)

  1063   show ?case

  1064   proof cases

  1065     assume "P x"

  1066     thus ?thesis by simp (metis Un_upper1 contra_subsetD in_set_conv_decomp_first self_append_conv2 set_append)

  1067   next

  1068     assume "\<not> P x"

  1069     hence "\<exists>x\<in>set xs. P x" using Cons(2) by simp

  1070     thus ?thesis using \<not> P x Cons(1) by (metis append_Cons set_ConsD)

  1071   qed

  1072 qed

  1073

  1074 lemma split_list_first_propE:

  1075   assumes "\<exists>x \<in> set xs. P x"

  1076   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>y \<in> set ys. \<not> P y"

  1077 using split_list_first_prop [OF assms] by blast

  1078

  1079 lemma split_list_first_prop_iff:

  1080   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>

  1081    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y))"

  1082 by (rule, erule split_list_first_prop) auto

  1083

  1084 lemma split_list_last_prop:

  1085   "\<exists>x \<in> set xs. P x \<Longrightarrow>

  1086    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z)"

  1087 proof(induct xs rule:rev_induct)

  1088   case Nil thus ?case by simp

  1089 next

  1090   case (snoc x xs)

  1091   show ?case

  1092   proof cases

  1093     assume "P x" thus ?thesis by (metis emptyE set_empty)

  1094   next

  1095     assume "\<not> P x"

  1096     hence "\<exists>x\<in>set xs. P x" using snoc(2) by simp

  1097     thus ?thesis using \<not> P x snoc(1) by fastforce

  1098   qed

  1099 qed

  1100

  1101 lemma split_list_last_propE:

  1102   assumes "\<exists>x \<in> set xs. P x"

  1103   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>z \<in> set zs. \<not> P z"

  1104 using split_list_last_prop [OF assms] by blast

  1105

  1106 lemma split_list_last_prop_iff:

  1107   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>

  1108    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"

  1109 by (metis split_list_last_prop [where P=P] in_set_conv_decomp)

  1110

  1111 lemma finite_list: "finite A ==> EX xs. set xs = A"

  1112   by (erule finite_induct)

  1113     (auto simp add: set.simps(2) [symmetric] simp del: set.simps(2))

  1114

  1115 lemma card_length: "card (set xs) \<le> length xs"

  1116 by (induct xs) (auto simp add: card_insert_if)

  1117

  1118 lemma set_minus_filter_out:

  1119   "set xs - {y} = set (filter (\<lambda>x. \<not> (x = y)) xs)"

  1120   by (induct xs) auto

  1121

  1122

  1123 subsubsection {* @{text filter} *}

  1124

  1125 lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"

  1126 by (induct xs) auto

  1127

  1128 lemma rev_filter: "rev (filter P xs) = filter P (rev xs)"

  1129 by (induct xs) simp_all

  1130

  1131 lemma filter_filter [simp]: "filter P (filter Q xs) = filter (\<lambda>x. Q x \<and> P x) xs"

  1132 by (induct xs) auto

  1133

  1134 lemma length_filter_le [simp]: "length (filter P xs) \<le> length xs"

  1135 by (induct xs) (auto simp add: le_SucI)

  1136

  1137 lemma sum_length_filter_compl:

  1138   "length(filter P xs) + length(filter (%x. ~P x) xs) = length xs"

  1139 by(induct xs) simp_all

  1140

  1141 lemma filter_True [simp]: "\<forall>x \<in> set xs. P x ==> filter P xs = xs"

  1142 by (induct xs) auto

  1143

  1144 lemma filter_False [simp]: "\<forall>x \<in> set xs. \<not> P x ==> filter P xs = []"

  1145 by (induct xs) auto

  1146

  1147 lemma filter_empty_conv: "(filter P xs = []) = (\<forall>x\<in>set xs. \<not> P x)"

  1148 by (induct xs) simp_all

  1149

  1150 lemma filter_id_conv: "(filter P xs = xs) = (\<forall>x\<in>set xs. P x)"

  1151 apply (induct xs)

  1152  apply auto

  1153 apply(cut_tac P=P and xs=xs in length_filter_le)

  1154 apply simp

  1155 done

  1156

  1157 lemma filter_map:

  1158   "filter P (map f xs) = map f (filter (P o f) xs)"

  1159 by (induct xs) simp_all

  1160

  1161 lemma length_filter_map[simp]:

  1162   "length (filter P (map f xs)) = length(filter (P o f) xs)"

  1163 by (simp add:filter_map)

  1164

  1165 lemma filter_is_subset [simp]: "set (filter P xs) \<le> set xs"

  1166 by auto

  1167

  1168 lemma length_filter_less:

  1169   "\<lbrakk> x : set xs; ~ P x \<rbrakk> \<Longrightarrow> length(filter P xs) < length xs"

  1170 proof (induct xs)

  1171   case Nil thus ?case by simp

  1172 next

  1173   case (Cons x xs) thus ?case

  1174     apply (auto split:split_if_asm)

  1175     using length_filter_le[of P xs] apply arith

  1176   done

  1177 qed

  1178

  1179 lemma length_filter_conv_card:

  1180  "length(filter p xs) = card{i. i < length xs & p(xs!i)}"

  1181 proof (induct xs)

  1182   case Nil thus ?case by simp

  1183 next

  1184   case (Cons x xs)

  1185   let ?S = "{i. i < length xs & p(xs!i)}"

  1186   have fin: "finite ?S" by(fast intro: bounded_nat_set_is_finite)

  1187   show ?case (is "?l = card ?S'")

  1188   proof (cases)

  1189     assume "p x"

  1190     hence eq: "?S' = insert 0 (Suc  ?S)"

  1191       by(auto simp: image_def split:nat.split dest:gr0_implies_Suc)

  1192     have "length (filter p (x # xs)) = Suc(card ?S)"

  1193       using Cons p x by simp

  1194     also have "\<dots> = Suc(card(Suc  ?S))" using fin

  1195       by (simp add: card_image)

  1196     also have "\<dots> = card ?S'" using eq fin

  1197       by (simp add:card_insert_if) (simp add:image_def)

  1198     finally show ?thesis .

  1199   next

  1200     assume "\<not> p x"

  1201     hence eq: "?S' = Suc  ?S"

  1202       by(auto simp add: image_def split:nat.split elim:lessE)

  1203     have "length (filter p (x # xs)) = card ?S"

  1204       using Cons \<not> p x by simp

  1205     also have "\<dots> = card(Suc  ?S)" using fin

  1206       by (simp add: card_image)

  1207     also have "\<dots> = card ?S'" using eq fin

  1208       by (simp add:card_insert_if)

  1209     finally show ?thesis .

  1210   qed

  1211 qed

  1212

  1213 lemma Cons_eq_filterD:

  1214  "x#xs = filter P ys \<Longrightarrow>

  1215   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"

  1216   (is "_ \<Longrightarrow> \<exists>us vs. ?P ys us vs")

  1217 proof(induct ys)

  1218   case Nil thus ?case by simp

  1219 next

  1220   case (Cons y ys)

  1221   show ?case (is "\<exists>x. ?Q x")

  1222   proof cases

  1223     assume Py: "P y"

  1224     show ?thesis

  1225     proof cases

  1226       assume "x = y"

  1227       with Py Cons.prems have "?Q []" by simp

  1228       then show ?thesis ..

  1229     next

  1230       assume "x \<noteq> y"

  1231       with Py Cons.prems show ?thesis by simp

  1232     qed

  1233   next

  1234     assume "\<not> P y"

  1235     with Cons obtain us vs where "?P (y#ys) (y#us) vs" by fastforce

  1236     then have "?Q (y#us)" by simp

  1237     then show ?thesis ..

  1238   qed

  1239 qed

  1240

  1241 lemma filter_eq_ConsD:

  1242  "filter P ys = x#xs \<Longrightarrow>

  1243   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"

  1244 by(rule Cons_eq_filterD) simp

  1245

  1246 lemma filter_eq_Cons_iff:

  1247  "(filter P ys = x#xs) =

  1248   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"

  1249 by(auto dest:filter_eq_ConsD)

  1250

  1251 lemma Cons_eq_filter_iff:

  1252  "(x#xs = filter P ys) =

  1253   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"

  1254 by(auto dest:Cons_eq_filterD)

  1255

  1256 lemma filter_cong[fundef_cong]:

  1257  "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x) \<Longrightarrow> filter P xs = filter Q ys"

  1258 apply simp

  1259 apply(erule thin_rl)

  1260 by (induct ys) simp_all

  1261

  1262

  1263 subsubsection {* List partitioning *}

  1264

  1265 primrec partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" where

  1266   "partition P [] = ([], [])"

  1267   | "partition P (x # xs) =

  1268       (let (yes, no) = partition P xs

  1269       in if P x then (x # yes, no) else (yes, x # no))"

  1270

  1271 lemma partition_filter1:

  1272     "fst (partition P xs) = filter P xs"

  1273 by (induct xs) (auto simp add: Let_def split_def)

  1274

  1275 lemma partition_filter2:

  1276     "snd (partition P xs) = filter (Not o P) xs"

  1277 by (induct xs) (auto simp add: Let_def split_def)

  1278

  1279 lemma partition_P:

  1280   assumes "partition P xs = (yes, no)"

  1281   shows "(\<forall>p \<in> set yes.  P p) \<and> (\<forall>p  \<in> set no. \<not> P p)"

  1282 proof -

  1283   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"

  1284     by simp_all

  1285   then show ?thesis by (simp_all add: partition_filter1 partition_filter2)

  1286 qed

  1287

  1288 lemma partition_set:

  1289   assumes "partition P xs = (yes, no)"

  1290   shows "set yes \<union> set no = set xs"

  1291 proof -

  1292   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"

  1293     by simp_all

  1294   then show ?thesis by (auto simp add: partition_filter1 partition_filter2)

  1295 qed

  1296

  1297 lemma partition_filter_conv[simp]:

  1298   "partition f xs = (filter f xs,filter (Not o f) xs)"

  1299 unfolding partition_filter2[symmetric]

  1300 unfolding partition_filter1[symmetric] by simp

  1301

  1302 declare partition.simps[simp del]

  1303

  1304

  1305 subsubsection {* @{text concat} *}

  1306

  1307 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"

  1308 by (induct xs) auto

  1309

  1310 lemma concat_eq_Nil_conv [simp]: "(concat xss = []) = (\<forall>xs \<in> set xss. xs = [])"

  1311 by (induct xss) auto

  1312

  1313 lemma Nil_eq_concat_conv [simp]: "([] = concat xss) = (\<forall>xs \<in> set xss. xs = [])"

  1314 by (induct xss) auto

  1315

  1316 lemma set_concat [simp]: "set (concat xs) = (UN x:set xs. set x)"

  1317 by (induct xs) auto

  1318

  1319 lemma concat_map_singleton[simp]: "concat(map (%x. [f x]) xs) = map f xs"

  1320 by (induct xs) auto

  1321

  1322 lemma map_concat: "map f (concat xs) = concat (map (map f) xs)"

  1323 by (induct xs) auto

  1324

  1325 lemma filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"

  1326 by (induct xs) auto

  1327

  1328 lemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"

  1329 by (induct xs) auto

  1330

  1331 lemma concat_eq_concat_iff: "\<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> length xs = length ys ==> (concat xs = concat ys) = (xs = ys)"

  1332 proof (induct xs arbitrary: ys)

  1333   case (Cons x xs ys)

  1334   thus ?case by (cases ys) auto

  1335 qed (auto)

  1336

  1337 lemma concat_injective: "concat xs = concat ys ==> length xs = length ys ==> \<forall>(x, y) \<in> set (zip xs ys). length x = length y ==> xs = ys"

  1338 by (simp add: concat_eq_concat_iff)

  1339

  1340

  1341 subsubsection {* @{text nth} *}

  1342

  1343 lemma nth_Cons_0 [simp, code]: "(x # xs)!0 = x"

  1344 by auto

  1345

  1346 lemma nth_Cons_Suc [simp, code]: "(x # xs)!(Suc n) = xs!n"

  1347 by auto

  1348

  1349 declare nth.simps [simp del]

  1350

  1351 lemma nth_Cons_pos[simp]: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"

  1352 by(auto simp: Nat.gr0_conv_Suc)

  1353

  1354 lemma nth_append:

  1355   "(xs @ ys)!n = (if n < length xs then xs!n else ys!(n - length xs))"

  1356 apply (induct xs arbitrary: n, simp)

  1357 apply (case_tac n, auto)

  1358 done

  1359

  1360 lemma nth_append_length [simp]: "(xs @ x # ys) ! length xs = x"

  1361 by (induct xs) auto

  1362

  1363 lemma nth_append_length_plus[simp]: "(xs @ ys) ! (length xs + n) = ys ! n"

  1364 by (induct xs) auto

  1365

  1366 lemma nth_map [simp]: "n < length xs ==> (map f xs)!n = f(xs!n)"

  1367 apply (induct xs arbitrary: n, simp)

  1368 apply (case_tac n, auto)

  1369 done

  1370

  1371 lemma nth_tl:

  1372   assumes "n < length (tl x)" shows "tl x ! n = x ! Suc n"

  1373 using assms by (induct x) auto

  1374

  1375 lemma hd_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd xs = xs!0"

  1376 by(cases xs) simp_all

  1377

  1378

  1379 lemma list_eq_iff_nth_eq:

  1380  "(xs = ys) = (length xs = length ys \<and> (ALL i<length xs. xs!i = ys!i))"

  1381 apply(induct xs arbitrary: ys)

  1382  apply force

  1383 apply(case_tac ys)

  1384  apply simp

  1385 apply(simp add:nth_Cons split:nat.split)apply blast

  1386 done

  1387

  1388 lemma set_conv_nth: "set xs = {xs!i | i. i < length xs}"

  1389 apply (induct xs, simp, simp)

  1390 apply safe

  1391 apply (metis nat_case_0 nth.simps zero_less_Suc)

  1392 apply (metis less_Suc_eq_0_disj nth_Cons_Suc)

  1393 apply (case_tac i, simp)

  1394 apply (metis diff_Suc_Suc nat_case_Suc nth.simps zero_less_diff)

  1395 done

  1396

  1397 lemma in_set_conv_nth: "(x \<in> set xs) = (\<exists>i < length xs. xs!i = x)"

  1398 by(auto simp:set_conv_nth)

  1399

  1400 lemma list_ball_nth: "[| n < length xs; !x : set xs. P x|] ==> P(xs!n)"

  1401 by (auto simp add: set_conv_nth)

  1402

  1403 lemma nth_mem [simp]: "n < length xs ==> xs!n : set xs"

  1404 by (auto simp add: set_conv_nth)

  1405

  1406 lemma all_nth_imp_all_set:

  1407 "[| !i < length xs. P(xs!i); x : set xs|] ==> P x"

  1408 by (auto simp add: set_conv_nth)

  1409

  1410 lemma all_set_conv_all_nth:

  1411 "(\<forall>x \<in> set xs. P x) = (\<forall>i. i < length xs --> P (xs ! i))"

  1412 by (auto simp add: set_conv_nth)

  1413

  1414 lemma rev_nth:

  1415   "n < size xs \<Longrightarrow> rev xs ! n = xs ! (length xs - Suc n)"

  1416 proof (induct xs arbitrary: n)

  1417   case Nil thus ?case by simp

  1418 next

  1419   case (Cons x xs)

  1420   hence n: "n < Suc (length xs)" by simp

  1421   moreover

  1422   { assume "n < length xs"

  1423     with n obtain n' where "length xs - n = Suc n'"

  1424       by (cases "length xs - n", auto)

  1425     moreover

  1426     then have "length xs - Suc n = n'" by simp

  1427     ultimately

  1428     have "xs ! (length xs - Suc n) = (x # xs) ! (length xs - n)" by simp

  1429   }

  1430   ultimately

  1431   show ?case by (clarsimp simp add: Cons nth_append)

  1432 qed

  1433

  1434 lemma Skolem_list_nth:

  1435   "(ALL i<k. EX x. P i x) = (EX xs. size xs = k & (ALL i<k. P i (xs!i)))"

  1436   (is "_ = (EX xs. ?P k xs)")

  1437 proof(induct k)

  1438   case 0 show ?case by simp

  1439 next

  1440   case (Suc k)

  1441   show ?case (is "?L = ?R" is "_ = (EX xs. ?P' xs)")

  1442   proof

  1443     assume "?R" thus "?L" using Suc by auto

  1444   next

  1445     assume "?L"

  1446     with Suc obtain x xs where "?P k xs & P k x" by (metis less_Suc_eq)

  1447     hence "?P'(xs@[x])" by(simp add:nth_append less_Suc_eq)

  1448     thus "?R" ..

  1449   qed

  1450 qed

  1451

  1452

  1453 subsubsection {* @{text list_update} *}

  1454

  1455 lemma length_list_update [simp]: "length(xs[i:=x]) = length xs"

  1456 by (induct xs arbitrary: i) (auto split: nat.split)

  1457

  1458 lemma nth_list_update:

  1459 "i < length xs==> (xs[i:=x])!j = (if i = j then x else xs!j)"

  1460 by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)

  1461

  1462 lemma nth_list_update_eq [simp]: "i < length xs ==> (xs[i:=x])!i = x"

  1463 by (simp add: nth_list_update)

  1464

  1465 lemma nth_list_update_neq [simp]: "i \<noteq> j ==> xs[i:=x]!j = xs!j"

  1466 by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)

  1467

  1468 lemma list_update_id[simp]: "xs[i := xs!i] = xs"

  1469 by (induct xs arbitrary: i) (simp_all split:nat.splits)

  1470

  1471 lemma list_update_beyond[simp]: "length xs \<le> i \<Longrightarrow> xs[i:=x] = xs"

  1472 apply (induct xs arbitrary: i)

  1473  apply simp

  1474 apply (case_tac i)

  1475 apply simp_all

  1476 done

  1477

  1478 lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"

  1479 by(metis length_0_conv length_list_update)

  1480

  1481 lemma list_update_same_conv:

  1482 "i < length xs ==> (xs[i := x] = xs) = (xs!i = x)"

  1483 by (induct xs arbitrary: i) (auto split: nat.split)

  1484

  1485 lemma list_update_append1:

  1486  "i < size xs \<Longrightarrow> (xs @ ys)[i:=x] = xs[i:=x] @ ys"

  1487 apply (induct xs arbitrary: i, simp)

  1488 apply(simp split:nat.split)

  1489 done

  1490

  1491 lemma list_update_append:

  1492   "(xs @ ys) [n:= x] =

  1493   (if n < length xs then xs[n:= x] @ ys else xs @ (ys [n-length xs:= x]))"

  1494 by (induct xs arbitrary: n) (auto split:nat.splits)

  1495

  1496 lemma list_update_length [simp]:

  1497  "(xs @ x # ys)[length xs := y] = (xs @ y # ys)"

  1498 by (induct xs, auto)

  1499

  1500 lemma map_update: "map f (xs[k:= y]) = (map f xs)[k := f y]"

  1501 by(induct xs arbitrary: k)(auto split:nat.splits)

  1502

  1503 lemma rev_update:

  1504   "k < length xs \<Longrightarrow> rev (xs[k:= y]) = (rev xs)[length xs - k - 1 := y]"

  1505 by (induct xs arbitrary: k) (auto simp: list_update_append split:nat.splits)

  1506

  1507 lemma update_zip:

  1508   "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"

  1509 by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)

  1510

  1511 lemma set_update_subset_insert: "set(xs[i:=x]) <= insert x (set xs)"

  1512 by (induct xs arbitrary: i) (auto split: nat.split)

  1513

  1514 lemma set_update_subsetI: "[| set xs <= A; x:A |] ==> set(xs[i := x]) <= A"

  1515 by (blast dest!: set_update_subset_insert [THEN subsetD])

  1516

  1517 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"

  1518 by (induct xs arbitrary: n) (auto split:nat.splits)

  1519

  1520 lemma list_update_overwrite[simp]:

  1521   "xs [i := x, i := y] = xs [i := y]"

  1522 apply (induct xs arbitrary: i) apply simp

  1523 apply (case_tac i, simp_all)

  1524 done

  1525

  1526 lemma list_update_swap:

  1527   "i \<noteq> i' \<Longrightarrow> xs [i := x, i' := x'] = xs [i' := x', i := x]"

  1528 apply (induct xs arbitrary: i i')

  1529 apply simp

  1530 apply (case_tac i, case_tac i')

  1531 apply auto

  1532 apply (case_tac i')

  1533 apply auto

  1534 done

  1535

  1536 lemma list_update_code [code]:

  1537   "[][i := y] = []"

  1538   "(x # xs)[0 := y] = y # xs"

  1539   "(x # xs)[Suc i := y] = x # xs[i := y]"

  1540   by simp_all

  1541

  1542

  1543 subsubsection {* @{text last} and @{text butlast} *}

  1544

  1545 lemma last_snoc [simp]: "last (xs @ [x]) = x"

  1546 by (induct xs) auto

  1547

  1548 lemma butlast_snoc [simp]: "butlast (xs @ [x]) = xs"

  1549 by (induct xs) auto

  1550

  1551 lemma last_ConsL: "xs = [] \<Longrightarrow> last(x#xs) = x"

  1552   by simp

  1553

  1554 lemma last_ConsR: "xs \<noteq> [] \<Longrightarrow> last(x#xs) = last xs"

  1555   by simp

  1556

  1557 lemma last_append: "last(xs @ ys) = (if ys = [] then last xs else last ys)"

  1558 by (induct xs) (auto)

  1559

  1560 lemma last_appendL[simp]: "ys = [] \<Longrightarrow> last(xs @ ys) = last xs"

  1561 by(simp add:last_append)

  1562

  1563 lemma last_appendR[simp]: "ys \<noteq> [] \<Longrightarrow> last(xs @ ys) = last ys"

  1564 by(simp add:last_append)

  1565

  1566 lemma last_tl: "xs = [] \<or> tl xs \<noteq> [] \<Longrightarrow>last (tl xs) = last xs"

  1567 by (induct xs) simp_all

  1568

  1569 lemma butlast_tl: "butlast (tl xs) = tl (butlast xs)"

  1570 by (induct xs) simp_all

  1571

  1572 lemma hd_rev: "xs \<noteq> [] \<Longrightarrow> hd(rev xs) = last xs"

  1573 by(rule rev_exhaust[of xs]) simp_all

  1574

  1575 lemma last_rev: "xs \<noteq> [] \<Longrightarrow> last(rev xs) = hd xs"

  1576 by(cases xs) simp_all

  1577

  1578 lemma last_in_set[simp]: "as \<noteq> [] \<Longrightarrow> last as \<in> set as"

  1579 by (induct as) auto

  1580

  1581 lemma length_butlast [simp]: "length (butlast xs) = length xs - 1"

  1582 by (induct xs rule: rev_induct) auto

  1583

  1584 lemma butlast_append:

  1585   "butlast (xs @ ys) = (if ys = [] then butlast xs else xs @ butlast ys)"

  1586 by (induct xs arbitrary: ys) auto

  1587

  1588 lemma append_butlast_last_id [simp]:

  1589 "xs \<noteq> [] ==> butlast xs @ [last xs] = xs"

  1590 by (induct xs) auto

  1591

  1592 lemma in_set_butlastD: "x : set (butlast xs) ==> x : set xs"

  1593 by (induct xs) (auto split: split_if_asm)

  1594

  1595 lemma in_set_butlast_appendI:

  1596 "x : set (butlast xs) | x : set (butlast ys) ==> x : set (butlast (xs @ ys))"

  1597 by (auto dest: in_set_butlastD simp add: butlast_append)

  1598

  1599 lemma last_drop[simp]: "n < length xs \<Longrightarrow> last (drop n xs) = last xs"

  1600 apply (induct xs arbitrary: n)

  1601  apply simp

  1602 apply (auto split:nat.split)

  1603 done

  1604

  1605 lemma nth_butlast:

  1606   assumes "n < length (butlast xs)" shows "butlast xs ! n = xs ! n"

  1607 proof (cases xs)

  1608   case (Cons y ys)

  1609   moreover from assms have "butlast xs ! n = (butlast xs @ [last xs]) ! n"

  1610     by (simp add: nth_append)

  1611   ultimately show ?thesis using append_butlast_last_id by simp

  1612 qed simp

  1613

  1614 lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - 1)"

  1615 by(induct xs)(auto simp:neq_Nil_conv)

  1616

  1617 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"

  1618 by (induct xs, simp, case_tac xs, simp_all)

  1619

  1620 lemma last_list_update:

  1621   "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"

  1622 by (auto simp: last_conv_nth)

  1623

  1624 lemma butlast_list_update:

  1625   "butlast(xs[k:=x]) =

  1626  (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"

  1627 apply(cases xs rule:rev_cases)

  1628 apply simp

  1629 apply(simp add:list_update_append split:nat.splits)

  1630 done

  1631

  1632 lemma last_map:

  1633   "xs \<noteq> [] \<Longrightarrow> last (map f xs) = f (last xs)"

  1634   by (cases xs rule: rev_cases) simp_all

  1635

  1636 lemma map_butlast:

  1637   "map f (butlast xs) = butlast (map f xs)"

  1638   by (induct xs) simp_all

  1639

  1640 lemma snoc_eq_iff_butlast:

  1641   "xs @ [x] = ys \<longleftrightarrow> (ys \<noteq> [] & butlast ys = xs & last ys = x)"

  1642 by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

  1643

  1644

  1645 subsubsection {* @{text take} and @{text drop} *}

  1646

  1647 lemma take_0 [simp]: "take 0 xs = []"

  1648 by (induct xs) auto

  1649

  1650 lemma drop_0 [simp]: "drop 0 xs = xs"

  1651 by (induct xs) auto

  1652

  1653 lemma take_Suc_Cons [simp]: "take (Suc n) (x # xs) = x # take n xs"

  1654 by simp

  1655

  1656 lemma drop_Suc_Cons [simp]: "drop (Suc n) (x # xs) = drop n xs"

  1657 by simp

  1658

  1659 declare take_Cons [simp del] and drop_Cons [simp del]

  1660

  1661 lemma take_1_Cons [simp]: "take 1 (x # xs) = [x]"

  1662   unfolding One_nat_def by simp

  1663

  1664 lemma drop_1_Cons [simp]: "drop 1 (x # xs) = xs"

  1665   unfolding One_nat_def by simp

  1666

  1667 lemma take_Suc: "xs ~= [] ==> take (Suc n) xs = hd xs # take n (tl xs)"

  1668 by(clarsimp simp add:neq_Nil_conv)

  1669

  1670 lemma drop_Suc: "drop (Suc n) xs = drop n (tl xs)"

  1671 by(cases xs, simp_all)

  1672

  1673 lemma take_tl: "take n (tl xs) = tl (take (Suc n) xs)"

  1674 by (induct xs arbitrary: n) simp_all

  1675

  1676 lemma drop_tl: "drop n (tl xs) = tl(drop n xs)"

  1677 by(induct xs arbitrary: n, simp_all add:drop_Cons drop_Suc split:nat.split)

  1678

  1679 lemma tl_take: "tl (take n xs) = take (n - 1) (tl xs)"

  1680 by (cases n, simp, cases xs, auto)

  1681

  1682 lemma tl_drop: "tl (drop n xs) = drop n (tl xs)"

  1683 by (simp only: drop_tl)

  1684

  1685 lemma nth_via_drop: "drop n xs = y#ys \<Longrightarrow> xs!n = y"

  1686 apply (induct xs arbitrary: n, simp)

  1687 apply(simp add:drop_Cons nth_Cons split:nat.splits)

  1688 done

  1689

  1690 lemma take_Suc_conv_app_nth:

  1691   "i < length xs \<Longrightarrow> take (Suc i) xs = take i xs @ [xs!i]"

  1692 apply (induct xs arbitrary: i, simp)

  1693 apply (case_tac i, auto)

  1694 done

  1695

  1696 lemma drop_Suc_conv_tl:

  1697   "i < length xs \<Longrightarrow> (xs!i) # (drop (Suc i) xs) = drop i xs"

  1698 apply (induct xs arbitrary: i, simp)

  1699 apply (case_tac i, auto)

  1700 done

  1701

  1702 lemma length_take [simp]: "length (take n xs) = min (length xs) n"

  1703 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1704

  1705 lemma length_drop [simp]: "length (drop n xs) = (length xs - n)"

  1706 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1707

  1708 lemma take_all [simp]: "length xs <= n ==> take n xs = xs"

  1709 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1710

  1711 lemma drop_all [simp]: "length xs <= n ==> drop n xs = []"

  1712 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1713

  1714 lemma take_append [simp]:

  1715   "take n (xs @ ys) = (take n xs @ take (n - length xs) ys)"

  1716 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1717

  1718 lemma drop_append [simp]:

  1719   "drop n (xs @ ys) = drop n xs @ drop (n - length xs) ys"

  1720 by (induct n arbitrary: xs) (auto, case_tac xs, auto)

  1721

  1722 lemma take_take [simp]: "take n (take m xs) = take (min n m) xs"

  1723 apply (induct m arbitrary: xs n, auto)

  1724 apply (case_tac xs, auto)

  1725 apply (case_tac n, auto)

  1726 done

  1727

  1728 lemma drop_drop [simp]: "drop n (drop m xs) = drop (n + m) xs"

  1729 apply (induct m arbitrary: xs, auto)

  1730 apply (case_tac xs, auto)

  1731 done

  1732

  1733 lemma take_drop: "take n (drop m xs) = drop m (take (n + m) xs)"

  1734 apply (induct m arbitrary: xs n, auto)

  1735 apply (case_tac xs, auto)

  1736 done

  1737

  1738 lemma drop_take: "drop n (take m xs) = take (m-n) (drop n xs)"

  1739 apply(induct xs arbitrary: m n)

  1740  apply simp

  1741 apply(simp add: take_Cons drop_Cons split:nat.split)

  1742 done

  1743

  1744 lemma append_take_drop_id [simp]: "take n xs @ drop n xs = xs"

  1745 apply (induct n arbitrary: xs, auto)

  1746 apply (case_tac xs, auto)

  1747 done

  1748

  1749 lemma take_eq_Nil[simp]: "(take n xs = []) = (n = 0 \<or> xs = [])"

  1750 apply(induct xs arbitrary: n)

  1751  apply simp

  1752 apply(simp add:take_Cons split:nat.split)

  1753 done

  1754

  1755 lemma drop_eq_Nil[simp]: "(drop n xs = []) = (length xs <= n)"

  1756 apply(induct xs arbitrary: n)

  1757 apply simp

  1758 apply(simp add:drop_Cons split:nat.split)

  1759 done

  1760

  1761 lemma take_map: "take n (map f xs) = map f (take n xs)"

  1762 apply (induct n arbitrary: xs, auto)

  1763 apply (case_tac xs, auto)

  1764 done

  1765

  1766 lemma drop_map: "drop n (map f xs) = map f (drop n xs)"

  1767 apply (induct n arbitrary: xs, auto)

  1768 apply (case_tac xs, auto)

  1769 done

  1770

  1771 lemma rev_take: "rev (take i xs) = drop (length xs - i) (rev xs)"

  1772 apply (induct xs arbitrary: i, auto)

  1773 apply (case_tac i, auto)

  1774 done

  1775

  1776 lemma rev_drop: "rev (drop i xs) = take (length xs - i) (rev xs)"

  1777 apply (induct xs arbitrary: i, auto)

  1778 apply (case_tac i, auto)

  1779 done

  1780

  1781 lemma nth_take [simp]: "i < n ==> (take n xs)!i = xs!i"

  1782 apply (induct xs arbitrary: i n, auto)

  1783 apply (case_tac n, blast)

  1784 apply (case_tac i, auto)

  1785 done

  1786

  1787 lemma nth_drop [simp]:

  1788   "n + i <= length xs ==> (drop n xs)!i = xs!(n + i)"

  1789 apply (induct n arbitrary: xs i, auto)

  1790 apply (case_tac xs, auto)

  1791 done

  1792

  1793 lemma butlast_take:

  1794   "n <= length xs ==> butlast (take n xs) = take (n - 1) xs"

  1795 by (simp add: butlast_conv_take min_max.inf_absorb1 min_max.inf_absorb2)

  1796

  1797 lemma butlast_drop: "butlast (drop n xs) = drop n (butlast xs)"

  1798 by (simp add: butlast_conv_take drop_take add_ac)

  1799

  1800 lemma take_butlast: "n < length xs ==> take n (butlast xs) = take n xs"

  1801 by (simp add: butlast_conv_take min_max.inf_absorb1)

  1802

  1803 lemma drop_butlast: "drop n (butlast xs) = butlast (drop n xs)"

  1804 by (simp add: butlast_conv_take drop_take add_ac)

  1805

  1806 lemma hd_drop_conv_nth: "n < length xs \<Longrightarrow> hd(drop n xs) = xs!n"

  1807 by(simp add: hd_conv_nth)

  1808

  1809 lemma set_take_subset_set_take:

  1810   "m <= n \<Longrightarrow> set(take m xs) <= set(take n xs)"

  1811 apply (induct xs arbitrary: m n)

  1812 apply simp

  1813 apply (case_tac n)

  1814 apply (auto simp: take_Cons)

  1815 done

  1816

  1817 lemma set_take_subset: "set(take n xs) \<subseteq> set xs"

  1818 by(induct xs arbitrary: n)(auto simp:take_Cons split:nat.split)

  1819

  1820 lemma set_drop_subset: "set(drop n xs) \<subseteq> set xs"

  1821 by(induct xs arbitrary: n)(auto simp:drop_Cons split:nat.split)

  1822

  1823 lemma set_drop_subset_set_drop:

  1824   "m >= n \<Longrightarrow> set(drop m xs) <= set(drop n xs)"

  1825 apply(induct xs arbitrary: m n)

  1826 apply(auto simp:drop_Cons split:nat.split)

  1827 apply (metis set_drop_subset subset_iff)

  1828 done

  1829

  1830 lemma in_set_takeD: "x : set(take n xs) \<Longrightarrow> x : set xs"

  1831 using set_take_subset by fast

  1832

  1833 lemma in_set_dropD: "x : set(drop n xs) \<Longrightarrow> x : set xs"

  1834 using set_drop_subset by fast

  1835

  1836 lemma append_eq_conv_conj:

  1837   "(xs @ ys = zs) = (xs = take (length xs) zs \<and> ys = drop (length xs) zs)"

  1838 apply (induct xs arbitrary: zs, simp, clarsimp)

  1839 apply (case_tac zs, auto)

  1840 done

  1841

  1842 lemma take_add:

  1843   "take (i+j) xs = take i xs @ take j (drop i xs)"

  1844 apply (induct xs arbitrary: i, auto)

  1845 apply (case_tac i, simp_all)

  1846 done

  1847

  1848 lemma append_eq_append_conv_if:

  1849  "(xs\<^isub>1 @ xs\<^isub>2 = ys\<^isub>1 @ ys\<^isub>2) =

  1850   (if size xs\<^isub>1 \<le> size ys\<^isub>1

  1851    then xs\<^isub>1 = take (size xs\<^isub>1) ys\<^isub>1 \<and> xs\<^isub>2 = drop (size xs\<^isub>1) ys\<^isub>1 @ ys\<^isub>2

  1852    else take (size ys\<^isub>1) xs\<^isub>1 = ys\<^isub>1 \<and> drop (size ys\<^isub>1) xs\<^isub>1 @ xs\<^isub>2 = ys\<^isub>2)"

  1853 apply(induct xs\<^isub>1 arbitrary: ys\<^isub>1)

  1854  apply simp

  1855 apply(case_tac ys\<^isub>1)

  1856 apply simp_all

  1857 done

  1858

  1859 lemma take_hd_drop:

  1860   "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (Suc n) xs"

  1861 apply(induct xs arbitrary: n)

  1862 apply simp

  1863 apply(simp add:drop_Cons split:nat.split)

  1864 done

  1865

  1866 lemma id_take_nth_drop:

  1867  "i < length xs \<Longrightarrow> xs = take i xs @ xs!i # drop (Suc i) xs"

  1868 proof -

  1869   assume si: "i < length xs"

  1870   hence "xs = take (Suc i) xs @ drop (Suc i) xs" by auto

  1871   moreover

  1872   from si have "take (Suc i) xs = take i xs @ [xs!i]"

  1873     apply (rule_tac take_Suc_conv_app_nth) by arith

  1874   ultimately show ?thesis by auto

  1875 qed

  1876

  1877 lemma upd_conv_take_nth_drop:

  1878  "i < length xs \<Longrightarrow> xs[i:=a] = take i xs @ a # drop (Suc i) xs"

  1879 proof -

  1880   assume i: "i < length xs"

  1881   have "xs[i:=a] = (take i xs @ xs!i # drop (Suc i) xs)[i:=a]"

  1882     by(rule arg_cong[OF id_take_nth_drop[OF i]])

  1883   also have "\<dots> = take i xs @ a # drop (Suc i) xs"

  1884     using i by (simp add: list_update_append)

  1885   finally show ?thesis .

  1886 qed

  1887

  1888 lemma nth_drop':

  1889   "i < length xs \<Longrightarrow> xs ! i # drop (Suc i) xs = drop i xs"

  1890 apply (induct i arbitrary: xs)

  1891 apply (simp add: neq_Nil_conv)

  1892 apply (erule exE)+

  1893 apply simp

  1894 apply (case_tac xs)

  1895 apply simp_all

  1896 done

  1897

  1898

  1899 subsubsection {* @{text takeWhile} and @{text dropWhile} *}

  1900

  1901 lemma length_takeWhile_le: "length (takeWhile P xs) \<le> length xs"

  1902   by (induct xs) auto

  1903

  1904 lemma takeWhile_dropWhile_id [simp]: "takeWhile P xs @ dropWhile P xs = xs"

  1905 by (induct xs) auto

  1906

  1907 lemma takeWhile_append1 [simp]:

  1908 "[| x:set xs; ~P(x)|] ==> takeWhile P (xs @ ys) = takeWhile P xs"

  1909 by (induct xs) auto

  1910

  1911 lemma takeWhile_append2 [simp]:

  1912 "(!!x. x : set xs ==> P x) ==> takeWhile P (xs @ ys) = xs @ takeWhile P ys"

  1913 by (induct xs) auto

  1914

  1915 lemma takeWhile_tail: "\<not> P x ==> takeWhile P (xs @ (x#l)) = takeWhile P xs"

  1916 by (induct xs) auto

  1917

  1918 lemma takeWhile_nth: "j < length (takeWhile P xs) \<Longrightarrow> takeWhile P xs ! j = xs ! j"

  1919 apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by auto

  1920

  1921 lemma dropWhile_nth: "j < length (dropWhile P xs) \<Longrightarrow> dropWhile P xs ! j = xs ! (j + length (takeWhile P xs))"

  1922 apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by auto

  1923

  1924 lemma length_dropWhile_le: "length (dropWhile P xs) \<le> length xs"

  1925 by (induct xs) auto

  1926

  1927 lemma dropWhile_append1 [simp]:

  1928 "[| x : set xs; ~P(x)|] ==> dropWhile P (xs @ ys) = (dropWhile P xs)@ys"

  1929 by (induct xs) auto

  1930

  1931 lemma dropWhile_append2 [simp]:

  1932 "(!!x. x:set xs ==> P(x)) ==> dropWhile P (xs @ ys) = dropWhile P ys"

  1933 by (induct xs) auto

  1934

  1935 lemma dropWhile_append3:

  1936   "\<not> P y \<Longrightarrow>dropWhile P (xs @ y # ys) = dropWhile P xs @ y # ys"

  1937 by (induct xs) auto

  1938

  1939 lemma dropWhile_last:

  1940   "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> last (dropWhile P xs) = last xs"

  1941 by (auto simp add: dropWhile_append3 in_set_conv_decomp)

  1942

  1943 lemma set_dropWhileD: "x \<in> set (dropWhile P xs) \<Longrightarrow> x \<in> set xs"

  1944 by (induct xs) (auto split: split_if_asm)

  1945

  1946 lemma set_takeWhileD: "x : set (takeWhile P xs) ==> x : set xs \<and> P x"

  1947 by (induct xs) (auto split: split_if_asm)

  1948

  1949 lemma takeWhile_eq_all_conv[simp]:

  1950  "(takeWhile P xs = xs) = (\<forall>x \<in> set xs. P x)"

  1951 by(induct xs, auto)

  1952

  1953 lemma dropWhile_eq_Nil_conv[simp]:

  1954  "(dropWhile P xs = []) = (\<forall>x \<in> set xs. P x)"

  1955 by(induct xs, auto)

  1956

  1957 lemma dropWhile_eq_Cons_conv:

  1958  "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys & \<not> P y)"

  1959 by(induct xs, auto)

  1960

  1961 lemma distinct_takeWhile[simp]: "distinct xs ==> distinct (takeWhile P xs)"

  1962 by (induct xs) (auto dest: set_takeWhileD)

  1963

  1964 lemma distinct_dropWhile[simp]: "distinct xs ==> distinct (dropWhile P xs)"

  1965 by (induct xs) auto

  1966

  1967 lemma takeWhile_map: "takeWhile P (map f xs) = map f (takeWhile (P \<circ> f) xs)"

  1968 by (induct xs) auto

  1969

  1970 lemma dropWhile_map: "dropWhile P (map f xs) = map f (dropWhile (P \<circ> f) xs)"

  1971 by (induct xs) auto

  1972

  1973 lemma takeWhile_eq_take: "takeWhile P xs = take (length (takeWhile P xs)) xs"

  1974 by (induct xs) auto

  1975

  1976 lemma dropWhile_eq_drop: "dropWhile P xs = drop (length (takeWhile P xs)) xs"

  1977 by (induct xs) auto

  1978

  1979 lemma hd_dropWhile:

  1980   "dropWhile P xs \<noteq> [] \<Longrightarrow> \<not> P (hd (dropWhile P xs))"

  1981 using assms by (induct xs) auto

  1982

  1983 lemma takeWhile_eq_filter:

  1984   assumes "\<And> x. x \<in> set (dropWhile P xs) \<Longrightarrow> \<not> P x"

  1985   shows "takeWhile P xs = filter P xs"

  1986 proof -

  1987   have A: "filter P xs = filter P (takeWhile P xs @ dropWhile P xs)"

  1988     by simp

  1989   have B: "filter P (dropWhile P xs) = []"

  1990     unfolding filter_empty_conv using assms by blast

  1991   have "filter P xs = takeWhile P xs"

  1992     unfolding A filter_append B

  1993     by (auto simp add: filter_id_conv dest: set_takeWhileD)

  1994   thus ?thesis ..

  1995 qed

  1996

  1997 lemma takeWhile_eq_take_P_nth:

  1998   "\<lbrakk> \<And> i. \<lbrakk> i < n ; i < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) ; n < length xs \<Longrightarrow> \<not> P (xs ! n) \<rbrakk> \<Longrightarrow>

  1999   takeWhile P xs = take n xs"

  2000 proof (induct xs arbitrary: n)

  2001   case (Cons x xs)

  2002   thus ?case

  2003   proof (cases n)

  2004     case (Suc n') note this[simp]

  2005     have "P x" using Cons.prems(1)[of 0] by simp

  2006     moreover have "takeWhile P xs = take n' xs"

  2007     proof (rule Cons.hyps)

  2008       case goal1 thus "P (xs ! i)" using Cons.prems(1)[of "Suc i"] by simp

  2009     next case goal2 thus ?case using Cons by auto

  2010     qed

  2011     ultimately show ?thesis by simp

  2012    qed simp

  2013 qed simp

  2014

  2015 lemma nth_length_takeWhile:

  2016   "length (takeWhile P xs) < length xs \<Longrightarrow> \<not> P (xs ! length (takeWhile P xs))"

  2017 by (induct xs) auto

  2018

  2019 lemma length_takeWhile_less_P_nth:

  2020   assumes all: "\<And> i. i < j \<Longrightarrow> P (xs ! i)" and "j \<le> length xs"

  2021   shows "j \<le> length (takeWhile P xs)"

  2022 proof (rule classical)

  2023   assume "\<not> ?thesis"

  2024   hence "length (takeWhile P xs) < length xs" using assms by simp

  2025   thus ?thesis using all \<not> ?thesis nth_length_takeWhile[of P xs] by auto

  2026 qed

  2027

  2028 text{* The following two lemmmas could be generalized to an arbitrary

  2029 property. *}

  2030

  2031 lemma takeWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>

  2032  takeWhile (\<lambda>y. y \<noteq> x) (rev xs) = rev (tl (dropWhile (\<lambda>y. y \<noteq> x) xs))"

  2033 by(induct xs) (auto simp: takeWhile_tail[where l="[]"])

  2034

  2035 lemma dropWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>

  2036   dropWhile (\<lambda>y. y \<noteq> x) (rev xs) = x # rev (takeWhile (\<lambda>y. y \<noteq> x) xs)"

  2037 apply(induct xs)

  2038  apply simp

  2039 apply auto

  2040 apply(subst dropWhile_append2)

  2041 apply auto

  2042 done

  2043

  2044 lemma takeWhile_not_last:

  2045  "distinct xs \<Longrightarrow> takeWhile (\<lambda>y. y \<noteq> last xs) xs = butlast xs"

  2046 apply(induct xs)

  2047  apply simp

  2048 apply(case_tac xs)

  2049 apply(auto)

  2050 done

  2051

  2052 lemma takeWhile_cong [fundef_cong]:

  2053   "[| l = k; !!x. x : set l ==> P x = Q x |]

  2054   ==> takeWhile P l = takeWhile Q k"

  2055 by (induct k arbitrary: l) (simp_all)

  2056

  2057 lemma dropWhile_cong [fundef_cong]:

  2058   "[| l = k; !!x. x : set l ==> P x = Q x |]

  2059   ==> dropWhile P l = dropWhile Q k"

  2060 by (induct k arbitrary: l, simp_all)

  2061

  2062

  2063 subsubsection {* @{text zip} *}

  2064

  2065 lemma zip_Nil [simp]: "zip [] ys = []"

  2066 by (induct ys) auto

  2067

  2068 lemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"

  2069 by simp

  2070

  2071 declare zip_Cons [simp del]

  2072

  2073 lemma [code]:

  2074   "zip [] ys = []"

  2075   "zip xs [] = []"

  2076   "zip (x # xs) (y # ys) = (x, y) # zip xs ys"

  2077   by (fact zip_Nil zip.simps(1) zip_Cons_Cons)+

  2078

  2079 lemma zip_Cons1:

  2080  "zip (x#xs) ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x,y)#zip xs ys)"

  2081 by(auto split:list.split)

  2082

  2083 lemma length_zip [simp]:

  2084 "length (zip xs ys) = min (length xs) (length ys)"

  2085 by (induct xs ys rule:list_induct2') auto

  2086

  2087 lemma zip_obtain_same_length:

  2088   assumes "\<And>zs ws n. length zs = length ws \<Longrightarrow> n = min (length xs) (length ys)

  2089     \<Longrightarrow> zs = take n xs \<Longrightarrow> ws = take n ys \<Longrightarrow> P (zip zs ws)"

  2090   shows "P (zip xs ys)"

  2091 proof -

  2092   let ?n = "min (length xs) (length ys)"

  2093   have "P (zip (take ?n xs) (take ?n ys))"

  2094     by (rule assms) simp_all

  2095   moreover have "zip xs ys = zip (take ?n xs) (take ?n ys)"

  2096   proof (induct xs arbitrary: ys)

  2097     case Nil then show ?case by simp

  2098   next

  2099     case (Cons x xs) then show ?case by (cases ys) simp_all

  2100   qed

  2101   ultimately show ?thesis by simp

  2102 qed

  2103

  2104 lemma zip_append1:

  2105 "zip (xs @ ys) zs =

  2106 zip xs (take (length xs) zs) @ zip ys (drop (length xs) zs)"

  2107 by (induct xs zs rule:list_induct2') auto

  2108

  2109 lemma zip_append2:

  2110 "zip xs (ys @ zs) =

  2111 zip (take (length ys) xs) ys @ zip (drop (length ys) xs) zs"

  2112 by (induct xs ys rule:list_induct2') auto

  2113

  2114 lemma zip_append [simp]:

  2115  "[| length xs = length us |] ==>

  2116 zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"

  2117 by (simp add: zip_append1)

  2118

  2119 lemma zip_rev:

  2120 "length xs = length ys ==> zip (rev xs) (rev ys) = rev (zip xs ys)"

  2121 by (induct rule:list_induct2, simp_all)

  2122

  2123 lemma zip_map_map:

  2124   "zip (map f xs) (map g ys) = map (\<lambda> (x, y). (f x, g y)) (zip xs ys)"

  2125 proof (induct xs arbitrary: ys)

  2126   case (Cons x xs) note Cons_x_xs = Cons.hyps

  2127   show ?case

  2128   proof (cases ys)

  2129     case (Cons y ys')

  2130     show ?thesis unfolding Cons using Cons_x_xs by simp

  2131   qed simp

  2132 qed simp

  2133

  2134 lemma zip_map1:

  2135   "zip (map f xs) ys = map (\<lambda>(x, y). (f x, y)) (zip xs ys)"

  2136 using zip_map_map[of f xs "\<lambda>x. x" ys] by simp

  2137

  2138 lemma zip_map2:

  2139   "zip xs (map f ys) = map (\<lambda>(x, y). (x, f y)) (zip xs ys)"

  2140 using zip_map_map[of "\<lambda>x. x" xs f ys] by simp

  2141

  2142 lemma map_zip_map:

  2143   "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"

  2144 unfolding zip_map1 by auto

  2145

  2146 lemma map_zip_map2:

  2147   "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"

  2148 unfolding zip_map2 by auto

  2149

  2150 text{* Courtesy of Andreas Lochbihler: *}

  2151 lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"

  2152 by(induct xs) auto

  2153

  2154 lemma nth_zip [simp]:

  2155 "[| i < length xs; i < length ys|] ==> (zip xs ys)!i = (xs!i, ys!i)"

  2156 apply (induct ys arbitrary: i xs, simp)

  2157 apply (case_tac xs)

  2158  apply (simp_all add: nth.simps split: nat.split)

  2159 done

  2160

  2161 lemma set_zip:

  2162 "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"

  2163 by(simp add: set_conv_nth cong: rev_conj_cong)

  2164

  2165 lemma zip_same: "((a,b) \<in> set (zip xs xs)) = (a \<in> set xs \<and> a = b)"

  2166 by(induct xs) auto

  2167

  2168 lemma zip_update:

  2169   "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"

  2170 by(rule sym, simp add: update_zip)

  2171

  2172 lemma zip_replicate [simp]:

  2173   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"

  2174 apply (induct i arbitrary: j, auto)

  2175 apply (case_tac j, auto)

  2176 done

  2177

  2178 lemma take_zip:

  2179   "take n (zip xs ys) = zip (take n xs) (take n ys)"

  2180 apply (induct n arbitrary: xs ys)

  2181  apply simp

  2182 apply (case_tac xs, simp)

  2183 apply (case_tac ys, simp_all)

  2184 done

  2185

  2186 lemma drop_zip:

  2187   "drop n (zip xs ys) = zip (drop n xs) (drop n ys)"

  2188 apply (induct n arbitrary: xs ys)

  2189  apply simp

  2190 apply (case_tac xs, simp)

  2191 apply (case_tac ys, simp_all)

  2192 done

  2193

  2194 lemma zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P \<circ> fst) (zip xs ys)"

  2195 proof (induct xs arbitrary: ys)

  2196   case (Cons x xs) thus ?case by (cases ys) auto

  2197 qed simp

  2198

  2199 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"

  2200 proof (induct xs arbitrary: ys)

  2201   case (Cons x xs) thus ?case by (cases ys) auto

  2202 qed simp

  2203

  2204 lemma set_zip_leftD:

  2205   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"

  2206 by (induct xs ys rule:list_induct2') auto

  2207

  2208 lemma set_zip_rightD:

  2209   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"

  2210 by (induct xs ys rule:list_induct2') auto

  2211

  2212 lemma in_set_zipE:

  2213   "(x,y) : set(zip xs ys) \<Longrightarrow> (\<lbrakk> x : set xs; y : set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"

  2214 by(blast dest: set_zip_leftD set_zip_rightD)

  2215

  2216 lemma zip_map_fst_snd:

  2217   "zip (map fst zs) (map snd zs) = zs"

  2218   by (induct zs) simp_all

  2219

  2220 lemma zip_eq_conv:

  2221   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"

  2222   by (auto simp add: zip_map_fst_snd)

  2223

  2224

  2225 subsubsection {* @{text list_all2} *}

  2226

  2227 lemma list_all2_lengthD [intro?]:

  2228   "list_all2 P xs ys ==> length xs = length ys"

  2229 by (simp add: list_all2_def)

  2230

  2231 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"

  2232 by (simp add: list_all2_def)

  2233

  2234 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"

  2235 by (simp add: list_all2_def)

  2236

  2237 lemma list_all2_Cons [iff, code]:

  2238   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"

  2239 by (auto simp add: list_all2_def)

  2240

  2241 lemma list_all2_Cons1:

  2242 "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"

  2243 by (cases ys) auto

  2244

  2245 lemma list_all2_Cons2:

  2246 "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"

  2247 by (cases xs) auto

  2248

  2249 lemma list_all2_induct

  2250   [consumes 1, case_names Nil Cons, induct set: list_all2]:

  2251   assumes P: "list_all2 P xs ys"

  2252   assumes Nil: "R [] []"

  2253   assumes Cons: "\<And>x xs y ys. \<lbrakk>P x y; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"

  2254   shows "R xs ys"

  2255 using P

  2256 by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)

  2257

  2258 lemma list_all2_rev [iff]:

  2259 "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"

  2260 by (simp add: list_all2_def zip_rev cong: conj_cong)

  2261

  2262 lemma list_all2_rev1:

  2263 "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"

  2264 by (subst list_all2_rev [symmetric]) simp

  2265

  2266 lemma list_all2_append1:

  2267 "list_all2 P (xs @ ys) zs =

  2268 (EX us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>

  2269 list_all2 P xs us \<and> list_all2 P ys vs)"

  2270 apply (simp add: list_all2_def zip_append1)

  2271 apply (rule iffI)

  2272  apply (rule_tac x = "take (length xs) zs" in exI)

  2273  apply (rule_tac x = "drop (length xs) zs" in exI)

  2274  apply (force split: nat_diff_split simp add: min_def, clarify)

  2275 apply (simp add: ball_Un)

  2276 done

  2277

  2278 lemma list_all2_append2:

  2279 "list_all2 P xs (ys @ zs) =

  2280 (EX us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>

  2281 list_all2 P us ys \<and> list_all2 P vs zs)"

  2282 apply (simp add: list_all2_def zip_append2)

  2283 apply (rule iffI)

  2284  apply (rule_tac x = "take (length ys) xs" in exI)

  2285  apply (rule_tac x = "drop (length ys) xs" in exI)

  2286  apply (force split: nat_diff_split simp add: min_def, clarify)

  2287 apply (simp add: ball_Un)

  2288 done

  2289

  2290 lemma list_all2_append:

  2291   "length xs = length ys \<Longrightarrow>

  2292   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"

  2293 by (induct rule:list_induct2, simp_all)

  2294

  2295 lemma list_all2_appendI [intro?, trans]:

  2296   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"

  2297 by (simp add: list_all2_append list_all2_lengthD)

  2298

  2299 lemma list_all2_conv_all_nth:

  2300 "list_all2 P xs ys =

  2301 (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"

  2302 by (force simp add: list_all2_def set_zip)

  2303

  2304 lemma list_all2_trans:

  2305   assumes tr: "!!a b c. P1 a b ==> P2 b c ==> P3 a c"

  2306   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> list_all2 P3 as cs"

  2307         (is "!!bs cs. PROP ?Q as bs cs")

  2308 proof (induct as)

  2309   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"

  2310   show "!!cs. PROP ?Q (x # xs) bs cs"

  2311   proof (induct bs)

  2312     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"

  2313     show "PROP ?Q (x # xs) (y # ys) cs"

  2314       by (induct cs) (auto intro: tr I1 I2)

  2315   qed simp

  2316 qed simp

  2317

  2318 lemma list_all2_all_nthI [intro?]:

  2319   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"

  2320 by (simp add: list_all2_conv_all_nth)

  2321

  2322 lemma list_all2I:

  2323   "\<forall>x \<in> set (zip a b). split P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"

  2324 by (simp add: list_all2_def)

  2325

  2326 lemma list_all2_nthD:

  2327   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

  2328 by (simp add: list_all2_conv_all_nth)

  2329

  2330 lemma list_all2_nthD2:

  2331   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

  2332 by (frule list_all2_lengthD) (auto intro: list_all2_nthD)

  2333

  2334 lemma list_all2_map1:

  2335   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"

  2336 by (simp add: list_all2_conv_all_nth)

  2337

  2338 lemma list_all2_map2:

  2339   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"

  2340 by (auto simp add: list_all2_conv_all_nth)

  2341

  2342 lemma list_all2_refl [intro?]:

  2343   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"

  2344 by (simp add: list_all2_conv_all_nth)

  2345

  2346 lemma list_all2_update_cong:

  2347   "\<lbrakk> list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"

  2348 by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)

  2349

  2350 lemma list_all2_takeI [simp,intro?]:

  2351   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"

  2352 apply (induct xs arbitrary: n ys)

  2353  apply simp

  2354 apply (clarsimp simp add: list_all2_Cons1)

  2355 apply (case_tac n)

  2356 apply auto

  2357 done

  2358

  2359 lemma list_all2_dropI [simp,intro?]:

  2360   "list_all2 P as bs \<Longrightarrow> list_all2 P (drop n as) (drop n bs)"

  2361 apply (induct as arbitrary: n bs, simp)

  2362 apply (clarsimp simp add: list_all2_Cons1)

  2363 apply (case_tac n, simp, simp)

  2364 done

  2365

  2366 lemma list_all2_mono [intro?]:

  2367   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"

  2368 apply (induct xs arbitrary: ys, simp)

  2369 apply (case_tac ys, auto)

  2370 done

  2371

  2372 lemma list_all2_eq:

  2373   "xs = ys \<longleftrightarrow> list_all2 (op =) xs ys"

  2374 by (induct xs ys rule: list_induct2') auto

  2375

  2376 lemma list_eq_iff_zip_eq:

  2377   "xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x,y) \<in> set (zip xs ys). x = y)"

  2378 by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)

  2379

  2380

  2381 subsubsection {* @{const fold} with canonical argument order *}

  2382

  2383 lemma fold_remove1_split:

  2384   assumes f: "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x"

  2385     and x: "x \<in> set xs"

  2386   shows "fold f xs = fold f (remove1 x xs) \<circ> f x"

  2387   using assms by (induct xs) (auto simp add: o_assoc [symmetric])

  2388

  2389 lemma fold_cong [fundef_cong]:

  2390   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)

  2391     \<Longrightarrow> fold f xs a = fold g ys b"

  2392   by (induct ys arbitrary: a b xs) simp_all

  2393

  2394 lemma fold_id:

  2395   assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"

  2396   shows "fold f xs = id"

  2397   using assms by (induct xs) simp_all

  2398

  2399 lemma fold_commute:

  2400   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"

  2401   shows "h \<circ> fold g xs = fold f xs \<circ> h"

  2402   using assms by (induct xs) (simp_all add: fun_eq_iff)

  2403

  2404 lemma fold_commute_apply:

  2405   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"

  2406   shows "h (fold g xs s) = fold f xs (h s)"

  2407 proof -

  2408   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)

  2409   then show ?thesis by (simp add: fun_eq_iff)

  2410 qed

  2411

  2412 lemma fold_invariant:

  2413   assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"

  2414     and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"

  2415   shows "P (fold f xs s)"

  2416   using assms by (induct xs arbitrary: s) simp_all

  2417

  2418 lemma fold_append [simp]:

  2419   "fold f (xs @ ys) = fold f ys \<circ> fold f xs"

  2420   by (induct xs) simp_all

  2421

  2422 lemma fold_map [code_unfold]:

  2423   "fold g (map f xs) = fold (g o f) xs"

  2424   by (induct xs) simp_all

  2425

  2426 lemma fold_rev:

  2427   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"

  2428   shows "fold f (rev xs) = fold f xs"

  2429 using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)

  2430

  2431 lemma fold_Cons_rev:

  2432   "fold Cons xs = append (rev xs)"

  2433   by (induct xs) simp_all

  2434

  2435 lemma rev_conv_fold [code]:

  2436   "rev xs = fold Cons xs []"

  2437   by (simp add: fold_Cons_rev)

  2438

  2439 lemma fold_append_concat_rev:

  2440   "fold append xss = append (concat (rev xss))"

  2441   by (induct xss) simp_all

  2442

  2443 text {* @{const Finite_Set.fold} and @{const fold} *}

  2444

  2445 lemma (in comp_fun_commute) fold_set_fold_remdups:

  2446   "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"

  2447   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)

  2448

  2449 lemma (in comp_fun_idem) fold_set_fold:

  2450   "Finite_Set.fold f y (set xs) = fold f xs y"

  2451   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)

  2452

  2453 lemma (in ab_semigroup_idem_mult) fold1_set_fold:

  2454   assumes "xs \<noteq> []"

  2455   shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)"

  2456 proof -

  2457   interpret comp_fun_idem times by (fact comp_fun_idem)

  2458   from assms obtain y ys where xs: "xs = y # ys"

  2459     by (cases xs) auto

  2460   show ?thesis

  2461   proof (cases "set ys = {}")

  2462     case True with xs show ?thesis by simp

  2463   next

  2464     case False

  2465     then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)"

  2466       by (simp only: finite_set fold1_eq_fold_idem)

  2467     with xs show ?thesis by (simp add: fold_set_fold mult_commute)

  2468   qed

  2469 qed

  2470

  2471 lemma union_set_fold:

  2472   "set xs \<union> A = fold Set.insert xs A"

  2473 proof -

  2474   interpret comp_fun_idem Set.insert

  2475     by (fact comp_fun_idem_insert)

  2476   show ?thesis by (simp add: union_fold_insert fold_set_fold)

  2477 qed

  2478

  2479 lemma minus_set_fold:

  2480   "A - set xs = fold Set.remove xs A"

  2481 proof -

  2482   interpret comp_fun_idem Set.remove

  2483     by (fact comp_fun_idem_remove)

  2484   show ?thesis

  2485     by (simp add: minus_fold_remove [of _ A] fold_set_fold)

  2486 qed

  2487

  2488 lemma (in lattice) Inf_fin_set_fold:

  2489   "Inf_fin (set (x # xs)) = fold inf xs x"

  2490 proof -

  2491   interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2492     by (fact ab_semigroup_idem_mult_inf)

  2493   show ?thesis

  2494     by (simp add: Inf_fin_def fold1_set_fold del: set.simps)

  2495 qed

  2496

  2497 lemma (in lattice) Sup_fin_set_fold:

  2498   "Sup_fin (set (x # xs)) = fold sup xs x"

  2499 proof -

  2500   interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2501     by (fact ab_semigroup_idem_mult_sup)

  2502   show ?thesis

  2503     by (simp add: Sup_fin_def fold1_set_fold del: set.simps)

  2504 qed

  2505

  2506 lemma (in linorder) Min_fin_set_fold:

  2507   "Min (set (x # xs)) = fold min xs x"

  2508 proof -

  2509   interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2510     by (fact ab_semigroup_idem_mult_min)

  2511   show ?thesis

  2512     by (simp add: Min_def fold1_set_fold del: set.simps)

  2513 qed

  2514

  2515 lemma (in linorder) Max_fin_set_fold:

  2516   "Max (set (x # xs)) = fold max xs x"

  2517 proof -

  2518   interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2519     by (fact ab_semigroup_idem_mult_max)

  2520   show ?thesis

  2521     by (simp add: Max_def fold1_set_fold del: set.simps)

  2522 qed

  2523

  2524 lemma (in complete_lattice) Inf_set_fold:

  2525   "Inf (set xs) = fold inf xs top"

  2526 proof -

  2527   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2528     by (fact comp_fun_idem_inf)

  2529   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)

  2530 qed

  2531

  2532 lemma (in complete_lattice) Sup_set_fold:

  2533   "Sup (set xs) = fold sup xs bot"

  2534 proof -

  2535   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2536     by (fact comp_fun_idem_sup)

  2537   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)

  2538 qed

  2539

  2540 lemma (in complete_lattice) INF_set_fold:

  2541   "INFI (set xs) f = fold (inf \<circ> f) xs top"

  2542   unfolding INF_def set_map [symmetric] Inf_set_fold fold_map ..

  2543

  2544 lemma (in complete_lattice) SUP_set_fold:

  2545   "SUPR (set xs) f = fold (sup \<circ> f) xs bot"

  2546   unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map ..

  2547

  2548

  2549 subsubsection {* Fold variants: @{const foldr} and @{const foldl} *}

  2550

  2551 text {* Correspondence *}

  2552

  2553 lemma foldr_foldl: -- {* The Third Duality Theorem'' in Bird \& Wadler: *}

  2554   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"

  2555   by (simp add: foldr_def foldl_def)

  2556

  2557 lemma foldl_foldr:

  2558   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"

  2559   by (simp add: foldr_def foldl_def)

  2560

  2561 lemma foldr_fold:

  2562   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"

  2563   shows "foldr f xs = fold f xs"

  2564   using assms unfolding foldr_def by (rule fold_rev)

  2565

  2566 lemma

  2567   foldr_Nil [code, simp]: "foldr f [] = id"

  2568   and foldr_Cons [code, simp]: "foldr f (x # xs) = f x \<circ> foldr f xs"

  2569   by (simp_all add: foldr_def)

  2570

  2571 lemma

  2572   foldl_Nil [simp]: "foldl f a [] = a"

  2573   and foldl_Cons [simp]: "foldl f a (x # xs) = foldl f (f a x) xs"

  2574   by (simp_all add: foldl_def)

  2575

  2576 lemma foldr_cong [fundef_cong]:

  2577   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f x a = g x a) \<Longrightarrow> foldr f l a = foldr g k b"

  2578   by (auto simp add: foldr_def intro!: fold_cong)

  2579

  2580 lemma foldl_cong [fundef_cong]:

  2581   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f a x = g a x) \<Longrightarrow> foldl f a l = foldl g b k"

  2582   by (auto simp add: foldl_def intro!: fold_cong)

  2583

  2584 lemma foldr_append [simp]:

  2585   "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"

  2586   by (simp add: foldr_def)

  2587

  2588 lemma foldl_append [simp]:

  2589   "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"

  2590   by (simp add: foldl_def)

  2591

  2592 lemma foldr_map [code_unfold]:

  2593   "foldr g (map f xs) a = foldr (g o f) xs a"

  2594   by (simp add: foldr_def fold_map rev_map)

  2595

  2596 lemma foldl_map [code_unfold]:

  2597   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"

  2598   by (simp add: foldl_def fold_map comp_def)

  2599

  2600 text {* Executing operations in terms of @{const foldr} -- tail-recursive! *}

  2601

  2602 lemma concat_conv_foldr [code]:

  2603   "concat xss = foldr append xss []"

  2604   by (simp add: fold_append_concat_rev foldr_def)

  2605

  2606 lemma minus_set_foldr [code]:

  2607   "A - set xs = foldr Set.remove xs A"

  2608 proof -

  2609   have "\<And>x y :: 'a. Set.remove y \<circ> Set.remove x = Set.remove x \<circ> Set.remove y"

  2610     by (auto simp add: remove_def)

  2611   then show ?thesis by (simp add: minus_set_fold foldr_fold)

  2612 qed

  2613

  2614 lemma subtract_coset_filter [code]:

  2615   "A - List.coset xs = set (List.filter (\<lambda>x. x \<in> A) xs)"

  2616   by auto

  2617

  2618 lemma union_set_foldr [code]:

  2619   "set xs \<union> A = foldr Set.insert xs A"

  2620 proof -

  2621   have "\<And>x y :: 'a. insert y \<circ> insert x = insert x \<circ> insert y"

  2622     by auto

  2623   then show ?thesis by (simp add: union_set_fold foldr_fold)

  2624 qed

  2625

  2626 lemma union_coset_foldr [code]:

  2627   "List.coset xs \<union> A = List.coset (List.filter (\<lambda>x. x \<notin> A) xs)"

  2628   by auto

  2629

  2630 lemma inter_set_filer [code]:

  2631   "A \<inter> set xs = set (List.filter (\<lambda>x. x \<in> A) xs)"

  2632   by auto

  2633

  2634 lemma inter_coset_foldr [code]:

  2635   "A \<inter> List.coset xs = foldr Set.remove xs A"

  2636   by (simp add: Diff_eq [symmetric] minus_set_foldr)

  2637

  2638 lemma (in lattice) Inf_fin_set_foldr [code]:

  2639   "Inf_fin (set (x # xs)) = foldr inf xs x"

  2640   by (simp add: Inf_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2641

  2642 lemma (in lattice) Sup_fin_set_foldr [code]:

  2643   "Sup_fin (set (x # xs)) = foldr sup xs x"

  2644   by (simp add: Sup_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2645

  2646 lemma (in linorder) Min_fin_set_foldr [code]:

  2647   "Min (set (x # xs)) = foldr min xs x"

  2648   by (simp add: Min_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2649

  2650 lemma (in linorder) Max_fin_set_foldr [code]:

  2651   "Max (set (x # xs)) = foldr max xs x"

  2652   by (simp add: Max_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2653

  2654 lemma (in complete_lattice) Inf_set_foldr:

  2655   "Inf (set xs) = foldr inf xs top"

  2656   by (simp add: Inf_set_fold ac_simps foldr_fold fun_eq_iff)

  2657

  2658 lemma (in complete_lattice) Sup_set_foldr:

  2659   "Sup (set xs) = foldr sup xs bot"

  2660   by (simp add: Sup_set_fold ac_simps foldr_fold fun_eq_iff)

  2661

  2662 declare Inf_set_foldr [where 'a = "'a set", code] Sup_set_foldr [where 'a = "'a set", code]

  2663

  2664 lemma (in complete_lattice) INF_set_foldr [code]:

  2665   "INFI (set xs) f = foldr (inf \<circ> f) xs top"

  2666   by (simp only: INF_def Inf_set_foldr foldr_map set_map [symmetric])

  2667

  2668 lemma (in complete_lattice) SUP_set_foldr [code]:

  2669   "SUPR (set xs) f = foldr (sup \<circ> f) xs bot"

  2670   by (simp only: SUP_def Sup_set_foldr foldr_map set_map [symmetric])

  2671

  2672

  2673 subsubsection {* @{text upt} *}

  2674

  2675 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"

  2676 -- {* simp does not terminate! *}

  2677 by (induct j) auto

  2678

  2679 lemmas upt_rec_number_of[simp] = upt_rec[of "number_of m" "number_of n"] for m n

  2680

  2681 lemma upt_conv_Nil [simp]: "j <= i ==> [i..<j] = []"

  2682 by (subst upt_rec) simp

  2683

  2684 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j <= i)"

  2685 by(induct j)simp_all

  2686

  2687 lemma upt_eq_Cons_conv:

  2688  "([i..<j] = x#xs) = (i < j & i = x & [i+1..<j] = xs)"

  2689 apply(induct j arbitrary: x xs)

  2690  apply simp

  2691 apply(clarsimp simp add: append_eq_Cons_conv)

  2692 apply arith

  2693 done

  2694

  2695 lemma upt_Suc_append: "i <= j ==> [i..<(Suc j)] = [i..<j]@[j]"

  2696 -- {* Only needed if @{text upt_Suc} is deleted from the simpset. *}

  2697 by simp

  2698

  2699 lemma upt_conv_Cons: "i < j ==> [i..<j] = i # [Suc i..<j]"

  2700   by (simp add: upt_rec)

  2701

  2702 lemma upt_add_eq_append: "i<=j ==> [i..<j+k] = [i..<j]@[j..<j+k]"

  2703 -- {* LOOPS as a simprule, since @{text "j <= j"}. *}

  2704 by (induct k) auto

  2705

  2706 lemma length_upt [simp]: "length [i..<j] = j - i"

  2707 by (induct j) (auto simp add: Suc_diff_le)

  2708

  2709 lemma nth_upt [simp]: "i + k < j ==> [i..<j] ! k = i + k"

  2710 apply (induct j)

  2711 apply (auto simp add: less_Suc_eq nth_append split: nat_diff_split)

  2712 done

  2713

  2714

  2715 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"

  2716 by(simp add:upt_conv_Cons)

  2717

  2718 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"

  2719 apply(cases j)

  2720  apply simp

  2721 by(simp add:upt_Suc_append)

  2722

  2723 lemma take_upt [simp]: "i+m <= n ==> take m [i..<n] = [i..<i+m]"

  2724 apply (induct m arbitrary: i, simp)

  2725 apply (subst upt_rec)

  2726 apply (rule sym)

  2727 apply (subst upt_rec)

  2728 apply (simp del: upt.simps)

  2729 done

  2730

  2731 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"

  2732 apply(induct j)

  2733 apply auto

  2734 done

  2735

  2736 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"

  2737 by (induct n) auto

  2738

  2739 lemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"

  2740 apply (induct n m  arbitrary: i rule: diff_induct)

  2741 prefer 3 apply (subst map_Suc_upt[symmetric])

  2742 apply (auto simp add: less_diff_conv)

  2743 done

  2744

  2745 lemma nth_take_lemma:

  2746   "k <= length xs ==> k <= length ys ==>

  2747      (!!i. i < k --> xs!i = ys!i) ==> take k xs = take k ys"

  2748 apply (atomize, induct k arbitrary: xs ys)

  2749 apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib, clarify)

  2750 txt {* Both lists must be non-empty *}

  2751 apply (case_tac xs, simp)

  2752 apply (case_tac ys, clarify)

  2753  apply (simp (no_asm_use))

  2754 apply clarify

  2755 txt {* prenexing's needed, not miniscoping *}

  2756 apply (simp (no_asm_use) add: all_simps [symmetric] del: all_simps)

  2757 apply blast

  2758 done

  2759

  2760 lemma nth_equalityI:

  2761  "[| length xs = length ys; ALL i < length xs. xs!i = ys!i |] ==> xs = ys"

  2762   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all

  2763

  2764 lemma map_nth:

  2765   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"

  2766   by (rule nth_equalityI, auto)

  2767

  2768 (* needs nth_equalityI *)

  2769 lemma list_all2_antisym:

  2770   "\<lbrakk> (\<And>x y. \<lbrakk>P x y; Q y x\<rbrakk> \<Longrightarrow> x = y); list_all2 P xs ys; list_all2 Q ys xs \<rbrakk>

  2771   \<Longrightarrow> xs = ys"

  2772   apply (simp add: list_all2_conv_all_nth)

  2773   apply (rule nth_equalityI, blast, simp)

  2774   done

  2775

  2776 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) ==> xs = ys"

  2777 -- {* The famous take-lemma. *}

  2778 apply (drule_tac x = "max (length xs) (length ys)" in spec)

  2779 apply (simp add: le_max_iff_disj)

  2780 done

  2781

  2782

  2783 lemma take_Cons':

  2784      "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"

  2785 by (cases n) simp_all

  2786

  2787 lemma drop_Cons':

  2788      "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"

  2789 by (cases n) simp_all

  2790

  2791 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"

  2792 by (cases n) simp_all

  2793

  2794 lemmas take_Cons_number_of = take_Cons'[of "number_of v"] for v

  2795 lemmas drop_Cons_number_of = drop_Cons'[of "number_of v"] for v

  2796 lemmas nth_Cons_number_of = nth_Cons'[of _ _ "number_of v"] for v

  2797

  2798 declare take_Cons_number_of [simp]

  2799         drop_Cons_number_of [simp]

  2800         nth_Cons_number_of [simp]

  2801

  2802

  2803 subsubsection {* @{text upto}: interval-list on @{typ int} *}

  2804

  2805 (* FIXME make upto tail recursive? *)

  2806

  2807 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where

  2808 "upto i j = (if i \<le> j then i # [i+1..j] else [])"

  2809 by auto

  2810 termination

  2811 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto

  2812

  2813 declare upto.simps[code, simp del]

  2814

  2815 lemmas upto_rec_number_of[simp] = upto.simps[of "number_of m" "number_of n"] for m n

  2816

  2817 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"

  2818 by(simp add: upto.simps)

  2819

  2820 lemma set_upto[simp]: "set[i..j] = {i..j}"

  2821 proof(induct i j rule:upto.induct)

  2822   case (1 i j)

  2823   from this show ?case

  2824     unfolding upto.simps[of i j] simp_from_to[of i j] by auto

  2825 qed

  2826

  2827

  2828 subsubsection {* @{text "distinct"} and @{text remdups} *}

  2829

  2830 lemma distinct_tl:

  2831   "distinct xs \<Longrightarrow> distinct (tl xs)"

  2832   by (cases xs) simp_all

  2833

  2834 lemma distinct_append [simp]:

  2835 "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"

  2836 by (induct xs) auto

  2837

  2838 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"

  2839 by(induct xs) auto

  2840

  2841 lemma set_remdups [simp]: "set (remdups xs) = set xs"

  2842 by (induct xs) (auto simp add: insert_absorb)

  2843

  2844 lemma distinct_remdups [iff]: "distinct (remdups xs)"

  2845 by (induct xs) auto

  2846

  2847 lemma distinct_remdups_id: "distinct xs ==> remdups xs = xs"

  2848 by (induct xs, auto)

  2849

  2850 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"

  2851 by (metis distinct_remdups distinct_remdups_id)

  2852

  2853 lemma finite_distinct_list: "finite A \<Longrightarrow> EX xs. set xs = A & distinct xs"

  2854 by (metis distinct_remdups finite_list set_remdups)

  2855

  2856 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"

  2857 by (induct x, auto)

  2858

  2859 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"

  2860 by (induct x, auto)

  2861

  2862 lemma length_remdups_leq[iff]: "length(remdups xs) <= length xs"

  2863 by (induct xs) auto

  2864

  2865 lemma length_remdups_eq[iff]:

  2866   "(length (remdups xs) = length xs) = (remdups xs = xs)"

  2867 apply(induct xs)

  2868  apply auto

  2869 apply(subgoal_tac "length (remdups xs) <= length xs")

  2870  apply arith

  2871 apply(rule length_remdups_leq)

  2872 done

  2873

  2874 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"

  2875 apply(induct xs)

  2876 apply auto

  2877 done

  2878

  2879 lemma distinct_map:

  2880   "distinct(map f xs) = (distinct xs & inj_on f (set xs))"

  2881 by (induct xs) auto

  2882

  2883

  2884 lemma distinct_filter [simp]: "distinct xs ==> distinct (filter P xs)"

  2885 by (induct xs) auto

  2886

  2887 lemma distinct_upt[simp]: "distinct[i..<j]"

  2888 by (induct j) auto

  2889

  2890 lemma distinct_upto[simp]: "distinct[i..j]"

  2891 apply(induct i j rule:upto.induct)

  2892 apply(subst upto.simps)

  2893 apply(simp)

  2894 done

  2895

  2896 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"

  2897 apply(induct xs arbitrary: i)

  2898  apply simp

  2899 apply (case_tac i)

  2900  apply simp_all

  2901 apply(blast dest:in_set_takeD)

  2902 done

  2903

  2904 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"

  2905 apply(induct xs arbitrary: i)

  2906  apply simp

  2907 apply (case_tac i)

  2908  apply simp_all

  2909 done

  2910

  2911 lemma distinct_list_update:

  2912 assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"

  2913 shows "distinct (xs[i:=a])"

  2914 proof (cases "i < length xs")

  2915   case True

  2916   with a have "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"

  2917     apply (drule_tac id_take_nth_drop) by simp

  2918   with d True show ?thesis

  2919     apply (simp add: upd_conv_take_nth_drop)

  2920     apply (drule subst [OF id_take_nth_drop]) apply assumption

  2921     apply simp apply (cases "a = xs!i") apply simp by blast

  2922 next

  2923   case False with d show ?thesis by auto

  2924 qed

  2925

  2926 lemma distinct_concat:

  2927   assumes "distinct xs"

  2928   and "\<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys"

  2929   and "\<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}"

  2930   shows "distinct (concat xs)"

  2931   using assms by (induct xs) auto

  2932

  2933 text {* It is best to avoid this indexed version of distinct, but

  2934 sometimes it is useful. *}

  2935

  2936 lemma distinct_conv_nth:

  2937 "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j --> xs!i \<noteq> xs!j)"

  2938 apply (induct xs, simp, simp)

  2939 apply (rule iffI, clarsimp)

  2940  apply (case_tac i)

  2941 apply (case_tac j, simp)

  2942 apply (simp add: set_conv_nth)

  2943  apply (case_tac j)

  2944 apply (clarsimp simp add: set_conv_nth, simp)

  2945 apply (rule conjI)

  2946 (*TOO SLOW

  2947 apply (metis Zero_neq_Suc gr0_conv_Suc in_set_conv_nth lessI less_trans_Suc nth_Cons' nth_Cons_Suc)

  2948 *)

  2949  apply (clarsimp simp add: set_conv_nth)

  2950  apply (erule_tac x = 0 in allE, simp)

  2951  apply (erule_tac x = "Suc i" in allE, simp, clarsimp)

  2952 (*TOO SLOW

  2953 apply (metis Suc_Suc_eq lessI less_trans_Suc nth_Cons_Suc)

  2954 *)

  2955 apply (erule_tac x = "Suc i" in allE, simp)

  2956 apply (erule_tac x = "Suc j" in allE, simp)

  2957 done

  2958

  2959 lemma nth_eq_iff_index_eq:

  2960  "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"

  2961 by(auto simp: distinct_conv_nth)

  2962

  2963 lemma distinct_card: "distinct xs ==> card (set xs) = size xs"

  2964 by (induct xs) auto

  2965

  2966 lemma card_distinct: "card (set xs) = size xs ==> distinct xs"

  2967 proof (induct xs)

  2968   case Nil thus ?case by simp

  2969 next

  2970   case (Cons x xs)

  2971   show ?case

  2972   proof (cases "x \<in> set xs")

  2973     case False with Cons show ?thesis by simp

  2974   next

  2975     case True with Cons.prems

  2976     have "card (set xs) = Suc (length xs)"

  2977       by (simp add: card_insert_if split: split_if_asm)

  2978     moreover have "card (set xs) \<le> length xs" by (rule card_length)

  2979     ultimately have False by simp

  2980     thus ?thesis ..

  2981   qed

  2982 qed

  2983

  2984 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"

  2985 by (induct xs) (auto)

  2986

  2987 lemma not_distinct_decomp: "~ distinct ws ==> EX xs ys zs y. ws = xs@[y]@ys@[y]@zs"

  2988 apply (induct n == "length ws" arbitrary:ws) apply simp

  2989 apply(case_tac ws) apply simp

  2990 apply (simp split:split_if_asm)

  2991 apply (metis Cons_eq_appendI eq_Nil_appendI split_list)

  2992 done

  2993

  2994 lemma not_distinct_conv_prefix:

  2995   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"

  2996   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")

  2997 proof

  2998   assume "?L" then show "?R"

  2999   proof (induct "length as" arbitrary: as rule: less_induct)

  3000     case less

  3001     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"

  3002       using not_distinct_decomp[OF less.prems] by auto

  3003     show ?case

  3004     proof (cases "distinct (xs @ y # ys)")

  3005       case True

  3006       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)

  3007       then show ?thesis by blast

  3008     next

  3009       case False

  3010       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"

  3011         by atomize_elim auto

  3012       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)

  3013       then show ?thesis by blast

  3014     qed

  3015   qed

  3016 qed (auto simp: dec_def)

  3017

  3018 lemma length_remdups_concat:

  3019   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"

  3020   by (simp add: distinct_card [symmetric])

  3021

  3022 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"

  3023 proof -

  3024   have xs: "concat[xs] = xs" by simp

  3025   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp

  3026 qed

  3027

  3028 lemma remdups_remdups:

  3029   "remdups (remdups xs) = remdups xs"

  3030   by (induct xs) simp_all

  3031

  3032 lemma distinct_butlast:

  3033   assumes "distinct xs"

  3034   shows "distinct (butlast xs)"

  3035 proof (cases "xs = []")

  3036   case False

  3037     from xs \<noteq> [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto

  3038     with distinct xs show ?thesis by simp

  3039 qed (auto)

  3040

  3041 lemma remdups_map_remdups:

  3042   "remdups (map f (remdups xs)) = remdups (map f xs)"

  3043   by (induct xs) simp_all

  3044

  3045 lemma distinct_zipI1:

  3046   assumes "distinct xs"

  3047   shows "distinct (zip xs ys)"

  3048 proof (rule zip_obtain_same_length)

  3049   fix xs' :: "'a list" and ys' :: "'b list" and n

  3050   assume "length xs' = length ys'"

  3051   assume "xs' = take n xs"

  3052   with assms have "distinct xs'" by simp

  3053   with length xs' = length ys' show "distinct (zip xs' ys')"

  3054     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)

  3055 qed

  3056

  3057 lemma distinct_zipI2:

  3058   assumes "distinct ys"

  3059   shows "distinct (zip xs ys)"

  3060 proof (rule zip_obtain_same_length)

  3061   fix xs' :: "'b list" and ys' :: "'a list" and n

  3062   assume "length xs' = length ys'"

  3063   assume "ys' = take n ys"

  3064   with assms have "distinct ys'" by simp

  3065   with length xs' = length ys' show "distinct (zip xs' ys')"

  3066     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)

  3067 qed

  3068

  3069 (* The next two lemmas help Sledgehammer. *)

  3070

  3071 lemma distinct_singleton: "distinct [x]" by simp

  3072

  3073 lemma distinct_length_2_or_more:

  3074 "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"

  3075 by (metis distinct.simps(2) hd.simps hd_in_set list.simps(2) set_ConsD set_rev_mp set_subset_Cons)

  3076

  3077 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}

  3078

  3079 lemma (in monoid_add) listsum_simps [simp]:

  3080   "listsum [] = 0"

  3081   "listsum (x # xs) = x + listsum xs"

  3082   by (simp_all add: listsum_def)

  3083

  3084 lemma (in monoid_add) listsum_append [simp]:

  3085   "listsum (xs @ ys) = listsum xs + listsum ys"

  3086   by (induct xs) (simp_all add: add.assoc)

  3087

  3088 lemma (in comm_monoid_add) listsum_rev [simp]:

  3089   "listsum (rev xs) = listsum xs"

  3090   by (simp add: listsum_def foldr_def fold_rev fun_eq_iff add_ac)

  3091

  3092 lemma (in monoid_add) fold_plus_listsum_rev:

  3093   "fold plus xs = plus (listsum (rev xs))"

  3094 proof

  3095   fix x

  3096   have "fold plus xs x = fold plus xs (x + 0)" by simp

  3097   also have "\<dots> = fold plus (x # xs) 0" by simp

  3098   also have "\<dots> = foldr plus (rev xs @ [x]) 0" by (simp add: foldr_def)

  3099   also have "\<dots> = listsum (rev xs @ [x])" by (simp add: listsum_def)

  3100   also have "\<dots> = listsum (rev xs) + listsum [x]" by simp

  3101   finally show "fold plus xs x = listsum (rev xs) + x" by simp

  3102 qed

  3103

  3104 lemma (in semigroup_add) foldl_assoc:

  3105   "foldl plus (x + y) zs = x + foldl plus y zs"

  3106   by (simp add: foldl_def fold_commute_apply [symmetric] fun_eq_iff add_assoc)

  3107

  3108 lemma (in ab_semigroup_add) foldr_conv_foldl:

  3109   "foldr plus xs a = foldl plus a xs"

  3110   by (simp add: foldl_def foldr_fold fun_eq_iff add_ac)

  3111

  3112 text {*

  3113   Note: @{text "n \<le> foldl (op +) n ns"} looks simpler, but is more

  3114   difficult to use because it requires an additional transitivity step.

  3115 *}

  3116

  3117 lemma start_le_sum:

  3118   fixes m n :: nat

  3119   shows "m \<le> n \<Longrightarrow> m \<le> foldl plus n ns"

  3120   by (simp add: foldl_def add_commute fold_plus_listsum_rev)

  3121

  3122 lemma elem_le_sum:

  3123   fixes m n :: nat

  3124   shows "n \<in> set ns \<Longrightarrow> n \<le> foldl plus 0 ns"

  3125   by (force intro: start_le_sum simp add: in_set_conv_decomp)

  3126

  3127 lemma sum_eq_0_conv [iff]:

  3128   fixes m :: nat

  3129   shows "foldl plus m ns = 0 \<longleftrightarrow> m = 0 \<and> (\<forall>n \<in> set ns. n = 0)"

  3130   by (induct ns arbitrary: m) auto

  3131

  3132 text{* Some syntactic sugar for summing a function over a list: *}

  3133

  3134 syntax

  3135   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)

  3136 syntax (xsymbols)

  3137   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

  3138 syntax (HTML output)

  3139   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

  3140

  3141 translations -- {* Beware of argument permutation! *}

  3142   "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)"

  3143   "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"

  3144

  3145 lemma (in comm_monoid_add) listsum_map_remove1:

  3146   "x \<in> set xs \<Longrightarrow> listsum (map f xs) = f x + listsum (map f (remove1 x xs))"

  3147   by (induct xs) (auto simp add: ac_simps)

  3148

  3149 lemma (in monoid_add) list_size_conv_listsum:

  3150   "list_size f xs = listsum (map f xs) + size xs"

  3151   by (induct xs) auto

  3152

  3153 lemma (in monoid_add) length_concat:

  3154   "length (concat xss) = listsum (map length xss)"

  3155   by (induct xss) simp_all

  3156

  3157 lemma (in monoid_add) listsum_map_filter:

  3158   assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"

  3159   shows "listsum (map f (filter P xs)) = listsum (map f xs)"

  3160   using assms by (induct xs) auto

  3161

  3162 lemma (in monoid_add) distinct_listsum_conv_Setsum:

  3163   "distinct xs \<Longrightarrow> listsum xs = Setsum (set xs)"

  3164   by (induct xs) simp_all

  3165

  3166 lemma listsum_eq_0_nat_iff_nat [simp]:

  3167   "listsum ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"

  3168   by (simp add: listsum_def foldr_conv_foldl)

  3169

  3170 lemma elem_le_listsum_nat:

  3171   "k < size ns \<Longrightarrow> ns ! k \<le> listsum (ns::nat list)"

  3172 apply(induct ns arbitrary: k)

  3173  apply simp

  3174 apply(fastforce simp add:nth_Cons split: nat.split)

  3175 done

  3176

  3177 lemma listsum_update_nat:

  3178   "k<size ns \<Longrightarrow> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"

  3179 apply(induct ns arbitrary:k)

  3180  apply (auto split:nat.split)

  3181 apply(drule elem_le_listsum_nat)

  3182 apply arith

  3183 done

  3184

  3185 lemma (in monoid_add) listsum_triv:

  3186   "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"

  3187   by (induct xs) (simp_all add: left_distrib)

  3188

  3189 lemma (in monoid_add) listsum_0 [simp]:

  3190   "(\<Sum>x\<leftarrow>xs. 0) = 0"

  3191   by (induct xs) (simp_all add: left_distrib)

  3192

  3193 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}

  3194 lemma (in ab_group_add) uminus_listsum_map:

  3195   "- listsum (map f xs) = listsum (map (uminus \<circ> f) xs)"

  3196   by (induct xs) simp_all

  3197

  3198 lemma (in comm_monoid_add) listsum_addf:

  3199   "(\<Sum>x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)"

  3200   by (induct xs) (simp_all add: algebra_simps)

  3201

  3202 lemma (in ab_group_add) listsum_subtractf:

  3203   "(\<Sum>x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)"

  3204   by (induct xs) (simp_all add: algebra_simps)

  3205

  3206 lemma (in semiring_0) listsum_const_mult:

  3207   "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"

  3208   by (induct xs) (simp_all add: algebra_simps)

  3209

  3210 lemma (in semiring_0) listsum_mult_const:

  3211   "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"

  3212   by (induct xs) (simp_all add: algebra_simps)

  3213

  3214 lemma (in ordered_ab_group_add_abs) listsum_abs:

  3215   "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"

  3216   by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])

  3217

  3218 lemma listsum_mono:

  3219   fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"

  3220   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)"

  3221   by (induct xs) (simp, simp add: add_mono)

  3222

  3223 lemma (in monoid_add) listsum_distinct_conv_setsum_set:

  3224   "distinct xs \<Longrightarrow> listsum (map f xs) = setsum f (set xs)"

  3225   by (induct xs) simp_all

  3226

  3227 lemma (in monoid_add) interv_listsum_conv_setsum_set_nat:

  3228   "listsum (map f [m..<n]) = setsum f (set [m..<n])"

  3229   by (simp add: listsum_distinct_conv_setsum_set)

  3230

  3231 lemma (in monoid_add) interv_listsum_conv_setsum_set_int:

  3232   "listsum (map f [k..l]) = setsum f (set [k..l])"

  3233   by (simp add: listsum_distinct_conv_setsum_set)

  3234

  3235 text {* General equivalence between @{const listsum} and @{const setsum} *}

  3236 lemma (in monoid_add) listsum_setsum_nth:

  3237   "listsum xs = (\<Sum> i = 0 ..< length xs. xs ! i)"

  3238   using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)

  3239

  3240

  3241 subsubsection {* @{const insert} *}

  3242

  3243 lemma in_set_insert [simp]:

  3244   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"

  3245   by (simp add: List.insert_def)

  3246

  3247 lemma not_in_set_insert [simp]:

  3248   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"

  3249   by (simp add: List.insert_def)

  3250

  3251 lemma insert_Nil [simp]:

  3252   "List.insert x [] = [x]"

  3253   by simp

  3254

  3255 lemma set_insert [simp]:

  3256   "set (List.insert x xs) = insert x (set xs)"

  3257   by (auto simp add: List.insert_def)

  3258

  3259 lemma distinct_insert [simp]:

  3260   "distinct xs \<Longrightarrow> distinct (List.insert x xs)"

  3261   by (simp add: List.insert_def)

  3262

  3263 lemma insert_remdups:

  3264   "List.insert x (remdups xs) = remdups (List.insert x xs)"

  3265   by (simp add: List.insert_def)

  3266

  3267

  3268 subsubsection {* @{text remove1} *}

  3269

  3270 lemma remove1_append:

  3271   "remove1 x (xs @ ys) =

  3272   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"

  3273 by (induct xs) auto

  3274

  3275 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"

  3276 by (induct zs) auto

  3277

  3278 lemma in_set_remove1[simp]:

  3279   "a \<noteq> b \<Longrightarrow> a : set(remove1 b xs) = (a : set xs)"

  3280 apply (induct xs)

  3281 apply auto

  3282 done

  3283

  3284 lemma set_remove1_subset: "set(remove1 x xs) <= set xs"

  3285 apply(induct xs)

  3286  apply simp

  3287 apply simp

  3288 apply blast

  3289 done

  3290

  3291 lemma set_remove1_eq [simp]: "distinct xs ==> set(remove1 x xs) = set xs - {x}"

  3292 apply(induct xs)

  3293  apply simp

  3294 apply simp

  3295 apply blast

  3296 done

  3297

  3298 lemma length_remove1:

  3299   "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"

  3300 apply (induct xs)

  3301  apply (auto dest!:length_pos_if_in_set)

  3302 done

  3303

  3304 lemma remove1_filter_not[simp]:

  3305   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"

  3306 by(induct xs) auto

  3307

  3308 lemma filter_remove1:

  3309   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"

  3310 by (induct xs) auto

  3311

  3312 lemma notin_set_remove1[simp]: "x ~: set xs ==> x ~: set(remove1 y xs)"

  3313 apply(insert set_remove1_subset)

  3314 apply fast

  3315 done

  3316

  3317 lemma distinct_remove1[simp]: "distinct xs ==> distinct(remove1 x xs)"

  3318 by (induct xs) simp_all

  3319

  3320 lemma remove1_remdups:

  3321   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"

  3322   by (induct xs) simp_all

  3323

  3324 lemma remove1_idem:

  3325   assumes "x \<notin> set xs"

  3326   shows "remove1 x xs = xs"

  3327   using assms by (induct xs) simp_all

  3328

  3329

  3330 subsubsection {* @{text removeAll} *}

  3331

  3332 lemma removeAll_filter_not_eq:

  3333   "removeAll x = filter (\<lambda>y. x \<noteq> y)"

  3334 proof

  3335   fix xs

  3336   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"

  3337     by (induct xs) auto

  3338 qed

  3339

  3340 lemma removeAll_append[simp]:

  3341   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"

  3342 by (induct xs) auto

  3343

  3344 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"

  3345 by (induct xs) auto

  3346

  3347 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"

  3348 by (induct xs) auto

  3349

  3350 (* Needs count:: 'a \<Rightarrow> 'a list \<Rightarrow> nat

  3351 lemma length_removeAll:

  3352   "length(removeAll x xs) = length xs - count x xs"

  3353 *)

  3354

  3355 lemma removeAll_filter_not[simp]:

  3356   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"

  3357 by(induct xs) auto

  3358

  3359 lemma distinct_removeAll:

  3360   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"

  3361   by (simp add: removeAll_filter_not_eq)

  3362

  3363 lemma distinct_remove1_removeAll:

  3364   "distinct xs ==> remove1 x xs = removeAll x xs"

  3365 by (induct xs) simp_all

  3366

  3367 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>

  3368   map f (removeAll x xs) = removeAll (f x) (map f xs)"

  3369 by (induct xs) (simp_all add:inj_on_def)

  3370

  3371 lemma map_removeAll_inj: "inj f \<Longrightarrow>

  3372   map f (removeAll x xs) = removeAll (f x) (map f xs)"

  3373 by(metis map_removeAll_inj_on subset_inj_on subset_UNIV)

  3374

  3375

  3376 subsubsection {* @{text replicate} *}

  3377

  3378 lemma length_replicate [simp]: "length (replicate n x) = n"

  3379 by (induct n) auto

  3380

  3381 lemma Ex_list_of_length: "\<exists>xs. length xs = n"

  3382 by (rule exI[of _ "replicate n undefined"]) simp

  3383

  3384 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"

  3385 by (induct n) auto

  3386

  3387 lemma map_replicate_const:

  3388   "map (\<lambda> x. k) lst = replicate (length lst) k"

  3389   by (induct lst) auto

  3390

  3391 lemma replicate_app_Cons_same:

  3392 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"

  3393 by (induct n) auto

  3394

  3395 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"

  3396 apply (induct n, simp)

  3397 apply (simp add: replicate_app_Cons_same)

  3398 done

  3399

  3400 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"

  3401 by (induct n) auto

  3402

  3403 text{* Courtesy of Matthias Daum: *}

  3404 lemma append_replicate_commute:

  3405   "replicate n x @ replicate k x = replicate k x @ replicate n x"

  3406 apply (simp add: replicate_add [THEN sym])

  3407 apply (simp add: add_commute)

  3408 done

  3409

  3410 text{* Courtesy of Andreas Lochbihler: *}

  3411 lemma filter_replicate:

  3412   "filter P (replicate n x) = (if P x then replicate n x else [])"

  3413 by(induct n) auto

  3414

  3415 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"

  3416 by (induct n) auto

  3417

  3418 lemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"

  3419 by (induct n) auto

  3420

  3421 lemma last_replicate [simp]: "n \<noteq> 0 ==> last (replicate n x) = x"

  3422 by (atomize (full), induct n) auto

  3423

  3424 lemma nth_replicate[simp]: "i < n ==> (replicate n x)!i = x"

  3425 apply (induct n arbitrary: i, simp)

  3426 apply (simp add: nth_Cons split: nat.split)

  3427 done

  3428

  3429 text{* Courtesy of Matthias Daum (2 lemmas): *}

  3430 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"

  3431 apply (case_tac "k \<le> i")

  3432  apply  (simp add: min_def)

  3433 apply (drule not_leE)

  3434 apply (simp add: min_def)

  3435 apply (subgoal_tac "replicate k x = replicate i x @ replicate (k - i) x")

  3436  apply  simp

  3437 apply (simp add: replicate_add [symmetric])

  3438 done

  3439

  3440 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"

  3441 apply (induct k arbitrary: i)

  3442  apply simp

  3443 apply clarsimp

  3444 apply (case_tac i)

  3445  apply simp

  3446 apply clarsimp

  3447 done

  3448

  3449

  3450 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"

  3451 by (induct n) auto

  3452

  3453 lemma set_replicate [simp]: "n \<noteq> 0 ==> set (replicate n x) = {x}"

  3454 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)

  3455

  3456 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"

  3457 by auto

  3458

  3459 lemma in_set_replicate[simp]: "(x : set (replicate n y)) = (x = y & n \<noteq> 0)"

  3460 by (simp add: set_replicate_conv_if)

  3461

  3462 lemma Ball_set_replicate[simp]:

  3463   "(ALL x : set(replicate n a). P x) = (P a | n=0)"

  3464 by(simp add: set_replicate_conv_if)

  3465

  3466 lemma Bex_set_replicate[simp]:

  3467   "(EX x : set(replicate n a). P x) = (P a & n\<noteq>0)"

  3468 by(simp add: set_replicate_conv_if)

  3469

  3470 lemma replicate_append_same:

  3471   "replicate i x @ [x] = x # replicate i x"

  3472   by (induct i) simp_all

  3473

  3474 lemma map_replicate_trivial:

  3475   "map (\<lambda>i. x) [0..<i] = replicate i x"

  3476   by (induct i) (simp_all add: replicate_append_same)

  3477

  3478 lemma concat_replicate_trivial[simp]:

  3479   "concat (replicate i []) = []"

  3480   by (induct i) (auto simp add: map_replicate_const)

  3481

  3482 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"

  3483 by (induct n) auto

  3484

  3485 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"

  3486 by (induct n) auto

  3487

  3488 lemma replicate_eq_replicate[simp]:

  3489   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n & (m\<noteq>0 \<longrightarrow> x=y))"

  3490 apply(induct m arbitrary: n)

  3491  apply simp

  3492 apply(induct_tac n)

  3493 apply auto

  3494 done

  3495

  3496 lemma replicate_length_filter:

  3497   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"

  3498   by (induct xs) auto

  3499

  3500 lemma comm_append_are_replicate:

  3501   fixes xs ys :: "'a list"

  3502   assumes "xs \<noteq> []" "ys \<noteq> []"

  3503   assumes "xs @ ys = ys @ xs"

  3504   shows "\<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"

  3505   using assms

  3506 proof (induct "length (xs @ ys)" arbitrary: xs ys rule: less_induct)

  3507   case less

  3508

  3509   def xs' \<equiv> "if (length xs \<le> length ys) then xs else ys"

  3510     and ys' \<equiv> "if (length xs \<le> length ys) then ys else xs"

  3511   then have

  3512     prems': "length xs' \<le> length ys'"

  3513             "xs' @ ys' = ys' @ xs'"

  3514       and "xs' \<noteq> []"

  3515       and len: "length (xs @ ys) = length (xs' @ ys')"

  3516     using less by (auto intro: less.hyps)

  3517

  3518   from prems'

  3519   obtain ws where "ys' = xs' @ ws"

  3520     by (auto simp: append_eq_append_conv2)

  3521

  3522   have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ys'"

  3523   proof (cases "ws = []")

  3524     case True

  3525     then have "concat (replicate 1 xs') = xs'"

  3526       and "concat (replicate 1 xs') = ys'"

  3527       using ys' = xs' @ ws by auto

  3528     then show ?thesis by blast

  3529   next

  3530     case False

  3531     from ys' = xs' @ ws and xs' @ ys' = ys' @ xs'

  3532     have "xs' @ ws = ws @ xs'" by simp

  3533     then have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ws"

  3534       using False and xs' \<noteq> [] and ys' = xs' @ ws and len

  3535       by (intro less.hyps) auto

  3536     then obtain m n zs where "concat (replicate m zs) = xs'"

  3537       and "concat (replicate n zs) = ws" by blast

  3538     moreover

  3539     then have "concat (replicate (m + n) zs) = ys'"

  3540       using ys' = xs' @ ws

  3541       by (simp add: replicate_add)

  3542     ultimately

  3543     show ?thesis by blast

  3544   qed

  3545   then show ?case

  3546     using xs'_def ys'_def by metis

  3547 qed

  3548

  3549 lemma comm_append_is_replicate:

  3550   fixes xs ys :: "'a list"

  3551   assumes "xs \<noteq> []" "ys \<noteq> []"

  3552   assumes "xs @ ys = ys @ xs"

  3553   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"

  3554

  3555 proof -

  3556   obtain m n zs where "concat (replicate m zs) = xs"

  3557     and "concat (replicate n zs) = ys"

  3558     using assms by (metis comm_append_are_replicate)

  3559   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"

  3560     using xs \<noteq> [] and ys \<noteq> []

  3561     by (auto simp: replicate_add)

  3562   then show ?thesis by blast

  3563 qed

  3564

  3565

  3566 subsubsection{*@{text rotate1} and @{text rotate}*}

  3567

  3568 lemma rotate0[simp]: "rotate 0 = id"

  3569 by(simp add:rotate_def)

  3570

  3571 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"

  3572 by(simp add:rotate_def)

  3573

  3574 lemma rotate_add:

  3575   "rotate (m+n) = rotate m o rotate n"

  3576 by(simp add:rotate_def funpow_add)

  3577

  3578 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"

  3579 by(simp add:rotate_add)

  3580

  3581 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"

  3582 by(simp add:rotate_def funpow_swap1)

  3583

  3584 lemma rotate1_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate1 xs = xs"

  3585 by(cases xs) simp_all

  3586

  3587 lemma rotate_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate n xs = xs"

  3588 apply(induct n)

  3589  apply simp

  3590 apply (simp add:rotate_def)

  3591 done

  3592

  3593 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"

  3594 by (cases xs) simp_all

  3595

  3596 lemma rotate_drop_take:

  3597   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"

  3598 apply(induct n)

  3599  apply simp

  3600 apply(simp add:rotate_def)

  3601 apply(cases "xs = []")

  3602  apply (simp)

  3603 apply(case_tac "n mod length xs = 0")

  3604  apply(simp add:mod_Suc)

  3605  apply(simp add: rotate1_hd_tl drop_Suc take_Suc)

  3606 apply(simp add:mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]

  3607                 take_hd_drop linorder_not_le)

  3608 done

  3609

  3610 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"

  3611 by(simp add:rotate_drop_take)

  3612

  3613 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"

  3614 by(simp add:rotate_drop_take)

  3615

  3616 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"

  3617 by (cases xs) simp_all

  3618

  3619 lemma length_rotate[simp]: "length(rotate n xs) = length xs"

  3620 by (induct n arbitrary: xs) (simp_all add:rotate_def)

  3621

  3622 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"

  3623 by (cases xs) auto

  3624

  3625 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"

  3626 by (induct n) (simp_all add:rotate_def)

  3627

  3628 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"

  3629 by(simp add:rotate_drop_take take_map drop_map)

  3630

  3631 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"

  3632 by (cases xs) auto

  3633

  3634 lemma set_rotate[simp]: "set(rotate n xs) = set xs"

  3635 by (induct n) (simp_all add:rotate_def)

  3636

  3637 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"

  3638 by (cases xs) auto

  3639

  3640 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"

  3641 by (induct n) (simp_all add:rotate_def)

  3642

  3643 lemma rotate_rev:

  3644   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"

  3645 apply(simp add:rotate_drop_take rev_drop rev_take)

  3646 apply(cases "length xs = 0")

  3647  apply simp

  3648 apply(cases "n mod length xs = 0")

  3649  apply simp

  3650 apply(simp add:rotate_drop_take rev_drop rev_take)

  3651 done

  3652

  3653 lemma hd_rotate_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd(rotate n xs) = xs!(n mod length xs)"

  3654 apply(simp add:rotate_drop_take hd_append hd_drop_conv_nth hd_conv_nth)

  3655 apply(subgoal_tac "length xs \<noteq> 0")

  3656  prefer 2 apply simp

  3657 using mod_less_divisor[of "length xs" n] by arith

  3658

  3659

  3660 subsubsection {* @{text sublist} --- a generalization of @{text nth} to sets *}

  3661

  3662 lemma sublist_empty [simp]: "sublist xs {} = []"

  3663 by (auto simp add: sublist_def)

  3664

  3665 lemma sublist_nil [simp]: "sublist [] A = []"

  3666 by (auto simp add: sublist_def)

  3667

  3668 lemma length_sublist:

  3669   "length(sublist xs I) = card{i. i < length xs \<and> i : I}"

  3670 by(simp add: sublist_def length_filter_conv_card cong:conj_cong)

  3671

  3672 lemma sublist_shift_lemma_Suc:

  3673   "map fst (filter (%p. P(Suc(snd p))) (zip xs is)) =

  3674    map fst (filter (%p. P(snd p)) (zip xs (map Suc is)))"

  3675 apply(induct xs arbitrary: "is")

  3676  apply simp

  3677 apply (case_tac "is")

  3678  apply simp

  3679 apply simp

  3680 done

  3681

  3682 lemma sublist_shift_lemma:

  3683      "map fst [p<-zip xs [i..<i + length xs] . snd p : A] =

  3684       map fst [p<-zip xs [0..<length xs] . snd p + i : A]"

  3685 by (induct xs rule: rev_induct) (simp_all add: add_commute)

  3686

  3687 lemma sublist_append:

  3688      "sublist (l @ l') A = sublist l A @ sublist l' {j. j + length l : A}"

  3689 apply (unfold sublist_def)

  3690 apply (induct l' rule: rev_induct, simp)

  3691 apply (simp add: upt_add_eq_append[of 0] sublist_shift_lemma)

  3692 apply (simp add: add_commute)

  3693 done

  3694

  3695 lemma sublist_Cons:

  3696 "sublist (x # l) A = (if 0:A then [x] else []) @ sublist l {j. Suc j : A}"

  3697 apply (induct l rule: rev_induct)

  3698  apply (simp add: sublist_def)

  3699 apply (simp del: append_Cons add: append_Cons[symmetric] sublist_append)

  3700 done

  3701

  3702 lemma set_sublist: "set(sublist xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"

  3703 apply(induct xs arbitrary: I)

  3704 apply(auto simp: sublist_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)

  3705 done

  3706

  3707 lemma set_sublist_subset: "set(sublist xs I) \<subseteq> set xs"

  3708 by(auto simp add:set_sublist)

  3709

  3710 lemma notin_set_sublistI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(sublist xs I)"

  3711 by(auto simp add:set_sublist)

  3712

  3713 lemma in_set_sublistD: "x \<in> set(sublist xs I) \<Longrightarrow> x \<in> set xs"

  3714 by(auto simp add:set_sublist)

  3715

  3716 lemma sublist_singleton [simp]: "sublist [x] A = (if 0 : A then [x] else [])"

  3717 by (simp add: sublist_Cons)

  3718

  3719

  3720 lemma distinct_sublistI[simp]: "distinct xs \<Longrightarrow> distinct(sublist xs I)"

  3721 apply(induct xs arbitrary: I)

  3722  apply simp

  3723 apply(auto simp add:sublist_Cons)

  3724 done

  3725

  3726

  3727 lemma sublist_upt_eq_take [simp]: "sublist l {..<n} = take n l"

  3728 apply (induct l rule: rev_induct, simp)

  3729 apply (simp split: nat_diff_split add: sublist_append)

  3730 done

  3731

  3732 lemma filter_in_sublist:

  3733  "distinct xs \<Longrightarrow> filter (%x. x \<in> set(sublist xs s)) xs = sublist xs s"

  3734 proof (induct xs arbitrary: s)

  3735   case Nil thus ?case by simp

  3736 next

  3737   case (Cons a xs)

  3738   moreover hence "!x. x: set xs \<longrightarrow> x \<noteq> a" by auto

  3739   ultimately show ?case by(simp add: sublist_Cons cong:filter_cong)

  3740 qed

  3741

  3742

  3743 subsubsection {* @{const splice} *}

  3744

  3745 lemma splice_Nil2 [simp, code]: "splice xs [] = xs"

  3746 by (cases xs) simp_all

  3747

  3748 declare splice.simps(1,3)[code]

  3749 declare splice.simps(2)[simp del]

  3750

  3751 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"

  3752 by (induct xs ys rule: splice.induct) auto

  3753

  3754

  3755 subsubsection {* Transpose *}

  3756

  3757 function transpose where

  3758 "transpose []             = []" |

  3759 "transpose ([]     # xss) = transpose xss" |

  3760 "transpose ((x#xs) # xss) =

  3761   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"

  3762 by pat_completeness auto

  3763

  3764 lemma transpose_aux_filter_head:

  3765   "concat (map (list_case [] (\<lambda>h t. [h])) xss) =

  3766   map (\<lambda>xs. hd xs) [ys\<leftarrow>xss . ys \<noteq> []]"

  3767   by (induct xss) (auto split: list.split)

  3768

  3769 lemma transpose_aux_filter_tail:

  3770   "concat (map (list_case [] (\<lambda>h t. [t])) xss) =

  3771   map (\<lambda>xs. tl xs) [ys\<leftarrow>xss . ys \<noteq> []]"

  3772   by (induct xss) (auto split: list.split)

  3773

  3774 lemma transpose_aux_max:

  3775   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =

  3776   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) [ys\<leftarrow>xss . ys\<noteq>[]] 0))"

  3777   (is "max _ ?foldB = Suc (max _ ?foldA)")

  3778 proof (cases "[ys\<leftarrow>xss . ys\<noteq>[]] = []")

  3779   case True

  3780   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"

  3781   proof (induct xss)

  3782     case (Cons x xs)

  3783     moreover hence "x = []" by (cases x) auto

  3784     ultimately show ?case by auto

  3785   qed simp

  3786   thus ?thesis using True by simp

  3787 next

  3788   case False

  3789

  3790   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0 - 1"

  3791     by (induct xss) auto

  3792   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0"

  3793     by (induct xss) auto

  3794

  3795   have "0 < ?foldB"

  3796   proof -

  3797     from False

  3798     obtain z zs where zs: "[ys\<leftarrow>xss . ys \<noteq> []] = z#zs" by (auto simp: neq_Nil_conv)

  3799     hence "z \<in> set ([ys\<leftarrow>xss . ys \<noteq> []])" by auto

  3800     hence "z \<noteq> []" by auto

  3801     thus ?thesis

  3802       unfolding foldB zs

  3803       by (auto simp: max_def intro: less_le_trans)

  3804   qed

  3805   thus ?thesis

  3806     unfolding foldA foldB max_Suc_Suc[symmetric]

  3807     by simp

  3808 qed

  3809

  3810 termination transpose

  3811   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")

  3812      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)

  3813

  3814 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"

  3815   by (induct rule: transpose.induct) simp_all

  3816

  3817 lemma length_transpose:

  3818   fixes xs :: "'a list list"

  3819   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"

  3820   by (induct rule: transpose.induct)

  3821     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max

  3822                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)

  3823

  3824 lemma nth_transpose:

  3825   fixes xs :: "'a list list"

  3826   assumes "i < length (transpose xs)"

  3827   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) [ys \<leftarrow> xs. i < length ys]"

  3828 using assms proof (induct arbitrary: i rule: transpose.induct)

  3829   case (3 x xs xss)

  3830   def XS == "(x # xs) # xss"

  3831   hence [simp]: "XS \<noteq> []" by auto

  3832   thus ?case

  3833   proof (cases i)

  3834     case 0

  3835     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)

  3836   next

  3837     case (Suc j)

  3838     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp

  3839     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp

  3840     { fix x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"

  3841       by (cases x) simp_all

  3842     } note *** = this

  3843

  3844     have j_less: "j < length (transpose (xs # concat (map (list_case [] (\<lambda>h t. [t])) xss)))"

  3845       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)

  3846

  3847     show ?thesis

  3848       unfolding transpose.simps i = Suc j nth_Cons_Suc "3.hyps"[OF j_less]

  3849       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])

  3850       apply (rule_tac y=x in list.exhaust)

  3851       by auto

  3852   qed

  3853 qed simp_all

  3854

  3855 lemma transpose_map_map:

  3856   "transpose (map (map f) xs) = map (map f) (transpose xs)"

  3857 proof (rule nth_equalityI, safe)

  3858   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"

  3859     by (simp add: length_transpose foldr_map comp_def)

  3860   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp

  3861

  3862   fix i assume "i < length (transpose (map (map f) xs))"

  3863   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"

  3864     by (simp add: nth_transpose filter_map comp_def)

  3865 qed

  3866

  3867

  3868 subsubsection {* (In)finiteness *}

  3869

  3870 lemma finite_maxlen:

  3871   "finite (M::'a list set) ==> EX n. ALL s:M. size s < n"

  3872 proof (induct rule: finite.induct)

  3873   case emptyI show ?case by simp

  3874 next

  3875   case (insertI M xs)

  3876   then obtain n where "\<forall>s\<in>M. length s < n" by blast

  3877   hence "ALL s:insert xs M. size s < max n (size xs) + 1" by auto

  3878   thus ?case ..

  3879 qed

  3880

  3881 lemma lists_length_Suc_eq:

  3882   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =

  3883     (\<lambda>(xs, n). n#xs)  ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"

  3884   by (auto simp: length_Suc_conv)

  3885

  3886 lemma

  3887   assumes "finite A"

  3888   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"

  3889   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"

  3890   using finite A

  3891   by (induct n)

  3892      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)

  3893

  3894 lemma finite_lists_length_le:

  3895   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"

  3896  (is "finite ?S")

  3897 proof-

  3898   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto

  3899   thus ?thesis by (auto intro: finite_lists_length_eq[OF finite A])

  3900 qed

  3901

  3902 lemma card_lists_length_le:

  3903   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"

  3904 proof -

  3905   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"

  3906     using finite A

  3907     by (subst card_UN_disjoint)

  3908        (auto simp add: card_lists_length_eq finite_lists_length_eq)

  3909   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}"

  3910     by auto

  3911   finally show ?thesis by simp

  3912 qed

  3913

  3914 lemma card_lists_distinct_length_eq:

  3915   assumes "k < card A"

  3916   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"

  3917 using assms

  3918 proof (induct k)

  3919   case 0

  3920   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto

  3921   then show ?case by simp

  3922 next

  3923   case (Suc k)

  3924   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"

  3925   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto

  3926

  3927   from Suc have "k < card A" by simp

  3928   moreover have "finite A" using assms by (simp add: card_ge_0_finite)

  3929   moreover have "finite {xs. ?k_list k xs}"

  3930     using finite_lists_length_eq[OF finite A, of k]

  3931     by - (rule finite_subset, auto)

  3932   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"

  3933     by auto

  3934   moreover have "\<And>i. i \<in>Collect (?k_list k) \<Longrightarrow> card (A - set i) = card A - k"

  3935     by (simp add: card_Diff_subset distinct_card)

  3936   moreover have "{xs. ?k_list (Suc k) xs} =

  3937       (\<lambda>(xs, n). n#xs)  \<Union>(\<lambda>xs. {xs} \<times> (A - set xs))  {xs. ?k_list k xs}"

  3938     by (auto simp: length_Suc_conv)

  3939   moreover

  3940   have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp

  3941   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"

  3942     by (subst setprod_insert[symmetric]) (simp add: atLeastAtMost_insertL)+

  3943   ultimately show ?case

  3944     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)

  3945 qed

  3946

  3947 lemma infinite_UNIV_listI: "~ finite(UNIV::'a list set)"

  3948 apply(rule notI)

  3949 apply(drule finite_maxlen)

  3950 apply (metis UNIV_I length_replicate less_not_refl)

  3951 done

  3952

  3953

  3954 subsection {* Sorting *}

  3955

  3956 text{* Currently it is not shown that @{const sort} returns a

  3957 permutation of its input because the nicest proof is via multisets,

  3958 which are not yet available. Alternatively one could define a function

  3959 that counts the number of occurrences of an element in a list and use

  3960 that instead of multisets to state the correctness property. *}

  3961

  3962 context linorder

  3963 begin

  3964

  3965 lemma length_insort [simp]:

  3966   "length (insort_key f x xs) = Suc (length xs)"

  3967   by (induct xs) simp_all

  3968

  3969 lemma insort_key_left_comm:

  3970   assumes "f x \<noteq> f y"

  3971   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"

  3972   by (induct xs) (auto simp add: assms dest: antisym)

  3973

  3974 lemma insort_left_comm:

  3975   "insort x (insort y xs) = insort y (insort x xs)"

  3976   by (cases "x = y") (auto intro: insort_key_left_comm)

  3977

  3978 lemma comp_fun_commute_insort:

  3979   "comp_fun_commute insort"

  3980 proof

  3981 qed (simp add: insort_left_comm fun_eq_iff)

  3982

  3983 lemma sort_key_simps [simp]:

  3984   "sort_key f [] = []"

  3985   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"

  3986   by (simp_all add: sort_key_def)

  3987

  3988 lemma (in linorder) sort_key_conv_fold:

  3989   assumes "inj_on f (set xs)"

  3990   shows "sort_key f xs = fold (insort_key f) xs []"

  3991 proof -

  3992   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"

  3993   proof (rule fold_rev, rule ext)

  3994     fix zs

  3995     fix x y

  3996     assume "x \<in> set xs" "y \<in> set xs"

  3997     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)

  3998     have **: "x = y \<longleftrightarrow> y = x" by auto

  3999     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"

  4000       by (induct zs) (auto intro: * simp add: **)

  4001   qed

  4002   then show ?thesis by (simp add: sort_key_def foldr_def)

  4003 qed

  4004

  4005 lemma (in linorder) sort_conv_fold:

  4006   "sort xs = fold insort xs []"

  4007   by (rule sort_key_conv_fold) simp

  4008

  4009 lemma length_sort[simp]: "length (sort_key f xs) = length xs"

  4010 by (induct xs, auto)

  4011

  4012 lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"

  4013 apply(induct xs arbitrary: x) apply simp

  4014 by simp (blast intro: order_trans)

  4015

  4016 lemma sorted_tl:

  4017   "sorted xs \<Longrightarrow> sorted (tl xs)"

  4018   by (cases xs) (simp_all add: sorted_Cons)

  4019

  4020 lemma sorted_append:

  4021   "sorted (xs@ys) = (sorted xs & sorted ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"

  4022 by (induct xs) (auto simp add:sorted_Cons)

  4023

  4024 lemma sorted_nth_mono:

  4025   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"

  4026 by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)

  4027

  4028 lemma sorted_rev_nth_mono:

  4029   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"

  4030 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]

  4031       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]

  4032 by auto

  4033

  4034 lemma sorted_nth_monoI:

  4035   "(\<And> i j. \<lbrakk> i \<le> j ; j < length xs \<rbrakk> \<Longrightarrow> xs ! i \<le> xs ! j) \<Longrightarrow> sorted xs"

  4036 proof (induct xs)

  4037   case (Cons x xs)

  4038   have "sorted xs"

  4039   proof (rule Cons.hyps)

  4040     fix i j assume "i \<le> j" and "j < length xs"

  4041     with Cons.prems[of "Suc i" "Suc j"]

  4042     show "xs ! i \<le> xs ! j" by auto

  4043   qed

  4044   moreover

  4045   {

  4046     fix y assume "y \<in> set xs"

  4047     then obtain j where "j < length xs" and "xs ! j = y"

  4048       unfolding in_set_conv_nth by blast

  4049     with Cons.prems[of 0 "Suc j"]

  4050     have "x \<le> y"

  4051       by auto

  4052   }

  4053   ultimately

  4054   show ?case

  4055     unfolding sorted_Cons by auto

  4056 qed simp

  4057

  4058 lemma sorted_equals_nth_mono:

  4059   "sorted xs = (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"

  4060 by (auto intro: sorted_nth_monoI sorted_nth_mono)

  4061

  4062 lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"

  4063 by (induct xs) auto

  4064

  4065 lemma set_sort[simp]: "set(sort_key f xs) = set xs"

  4066 by (induct xs) (simp_all add:set_insort)

  4067

  4068 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"

  4069 by(induct xs)(auto simp:set_insort)

  4070

  4071 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"

  4072   by (induct xs) (simp_all add: distinct_insort)

  4073

  4074 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"

  4075   by (induct xs) (auto simp:sorted_Cons set_insort)

  4076

  4077 lemma sorted_insort: "sorted (insort x xs) = sorted xs"

  4078   using sorted_insort_key [where f="\<lambda>x. x"] by simp

  4079

  4080 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"

  4081   by (induct xs) (auto simp:sorted_insort_key)

  4082

  4083 theorem sorted_sort [simp]: "sorted (sort xs)"

  4084   using sorted_sort_key [where f="\<lambda>x. x"] by simp

  4085

  4086 lemma sorted_butlast:

  4087   assumes "xs \<noteq> []" and "sorted xs"

  4088   shows "sorted (butlast xs)"

  4089 proof -

  4090   from xs \<noteq> [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto

  4091   with sorted xs show ?thesis by (simp add: sorted_append)

  4092 qed

  4093

  4094 lemma insort_not_Nil [simp]:

  4095   "insort_key f a xs \<noteq> []"

  4096   by (induct xs) simp_all

  4097

  4098 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"

  4099 by (cases xs) auto

  4100

  4101 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"

  4102   by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)

  4103

  4104 lemma sorted_map_remove1:

  4105   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"

  4106   by (induct xs) (auto simp add: sorted_Cons)

  4107

  4108 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"

  4109   using sorted_map_remove1 [of "\<lambda>x. x"] by simp

  4110

  4111 lemma insort_key_remove1:

  4112   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"

  4113   shows "insort_key f a (remove1 a xs) = xs"

  4114 using assms proof (induct xs)

  4115   case (Cons x xs)

  4116   then show ?case

  4117   proof (cases "x = a")

  4118     case False

  4119     then have "f x \<noteq> f a" using Cons.prems by auto

  4120     then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons)

  4121     with f x \<noteq> f a show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons)

  4122   qed (auto simp: sorted_Cons insort_is_Cons)

  4123 qed simp

  4124

  4125 lemma insort_remove1:

  4126   assumes "a \<in> set xs" and "sorted xs"

  4127   shows "insort a (remove1 a xs) = xs"

  4128 proof (rule insort_key_remove1)

  4129   from a \<in> set xs show "a \<in> set xs" .

  4130   from sorted xs show "sorted (map (\<lambda>x. x) xs)" by simp

  4131   from a \<in> set xs have "a \<in> set (filter (op = a) xs)" by auto

  4132   then have "set (filter (op = a) xs) \<noteq> {}" by auto

  4133   then have "filter (op = a) xs \<noteq> []" by (auto simp only: set_empty)

  4134   then have "length (filter (op = a) xs) > 0" by simp

  4135   then obtain n where n: "Suc n = length (filter (op = a) xs)"

  4136     by (cases "length (filter (op = a) xs)") simp_all

  4137   moreover have "replicate (Suc n) a = a # replicate n a"

  4138     by simp

  4139   ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)

  4140 qed

  4141

  4142 lemma sorted_remdups[simp]:

  4143   "sorted l \<Longrightarrow> sorted (remdups l)"

  4144 by (induct l) (auto simp: sorted_Cons)

  4145

  4146 lemma sorted_distinct_set_unique:

  4147 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"

  4148 shows "xs = ys"

  4149 proof -

  4150   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)

  4151   from assms show ?thesis

  4152   proof(induct rule:list_induct2[OF 1])

  4153     case 1 show ?case by simp

  4154   next

  4155     case 2 thus ?case by (simp add:sorted_Cons)

  4156        (metis Diff_insert_absorb antisym insertE insert_iff)

  4157   qed

  4158 qed

  4159

  4160 lemma map_sorted_distinct_set_unique:

  4161   assumes "inj_on f (set xs \<union> set ys)"

  4162   assumes "sorted (map f xs)" "distinct (map f xs)"

  4163     "sorted (map f ys)" "distinct (map f ys)"

  4164   assumes "set xs = set ys"

  4165   shows "xs = ys"

  4166 proof -

  4167   from assms have "map f xs = map f ys"

  4168     by (simp add: sorted_distinct_set_unique)

  4169   moreover with inj_on f (set xs \<union> set ys) show "xs = ys"

  4170     by (blast intro: map_inj_on)

  4171 qed

  4172

  4173 lemma finite_sorted_distinct_unique:

  4174 shows "finite A \<Longrightarrow> EX! xs. set xs = A & sorted xs & distinct xs"

  4175 apply(drule finite_distinct_list)

  4176 apply clarify

  4177 apply(rule_tac a="sort xs" in ex1I)

  4178 apply (auto simp: sorted_distinct_set_unique)

  4179 done

  4180

  4181 lemma

  4182   assumes "sorted xs"

  4183   shows sorted_take: "sorted (take n xs)"

  4184   and sorted_drop: "sorted (drop n xs)"

  4185 proof -

  4186   from assms have "sorted (take n xs @ drop n xs)" by simp

  4187   then show "sorted (take n xs)" and "sorted (drop n xs)"

  4188     unfolding sorted_append by simp_all

  4189 qed

  4190

  4191 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"

  4192   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)

  4193

  4194 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"

  4195   by (subst takeWhile_eq_take) (auto dest: sorted_take)

  4196

  4197 lemma sorted_filter:

  4198   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"

  4199   by (induct xs) (simp_all add: sorted_Cons)

  4200

  4201 lemma foldr_max_sorted:

  4202   assumes "sorted (rev xs)"

  4203   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"

  4204 using assms proof (induct xs)

  4205   case (Cons x xs)

  4206   moreover hence "sorted (rev xs)" using sorted_append by auto

  4207   ultimately show ?case

  4208     by (cases xs, auto simp add: sorted_append max_def)

  4209 qed simp

  4210

  4211 lemma filter_equals_takeWhile_sorted_rev:

  4212   assumes sorted: "sorted (rev (map f xs))"

  4213   shows "[x \<leftarrow> xs. t < f x] = takeWhile (\<lambda> x. t < f x) xs"

  4214     (is "filter ?P xs = ?tW")

  4215 proof (rule takeWhile_eq_filter[symmetric])

  4216   let "?dW" = "dropWhile ?P xs"

  4217   fix x assume "x \<in> set ?dW"

  4218   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"

  4219     unfolding in_set_conv_nth by auto

  4220   hence "length ?tW + i < length (?tW @ ?dW)"

  4221     unfolding length_append by simp

  4222   hence i': "length (map f ?tW) + i < length (map f xs)" by simp

  4223   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>

  4224         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"

  4225     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]

  4226     unfolding map_append[symmetric] by simp

  4227   hence "f x \<le> f (?dW ! 0)"

  4228     unfolding nth_append_length_plus nth_i

  4229     using i preorder_class.le_less_trans[OF le0 i] by simp

  4230   also have "... \<le> t"

  4231     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]

  4232     using hd_conv_nth[of "?dW"] by simp

  4233   finally show "\<not> t < f x" by simp

  4234 qed

  4235

  4236 lemma insort_insert_key_triv:

  4237   "f x \<in> f  set xs \<Longrightarrow> insort_insert_key f x xs = xs"

  4238   by (simp add: insort_insert_key_def)

  4239

  4240 lemma insort_insert_triv:

  4241   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"

  4242   using insort_insert_key_triv [of "\<lambda>x. x"] by simp

  4243

  4244 lemma insort_insert_insort_key:

  4245   "f x \<notin> f  set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"

  4246   by (simp add: insort_insert_key_def)

  4247

  4248 lemma insort_insert_insort:

  4249   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"

  4250   using insort_insert_insort_key [of "\<lambda>x. x"] by simp

  4251

  4252 lemma set_insort_insert:

  4253   "set (insort_insert x xs) = insert x (set xs)"

  4254   by (auto simp add: insort_insert_key_def set_insort)

  4255

  4256 lemma distinct_insort_insert:

  4257   assumes "distinct xs"

  4258   shows "distinct (insort_insert_key f x xs)"

  4259   using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)

  4260

  4261 lemma sorted_insort_insert_key:

  4262   assumes "sorted (map f xs)"

  4263   shows "sorted (map f (insort_insert_key f x xs))"

  4264   using assms by (simp add: insort_insert_key_def sorted_insort_key)

  4265

  4266 lemma sorted_insort_insert:

  4267   assumes "sorted xs"

  4268   shows "sorted (insort_insert x xs)"

  4269   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp

  4270

  4271 lemma filter_insort_triv:

  4272   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"

  4273   by (induct xs) simp_all

  4274

  4275 lemma filter_insort:

  4276   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"

  4277   using assms by (induct xs)

  4278     (auto simp add: sorted_Cons, subst insort_is_Cons, auto)

  4279

  4280 lemma filter_sort:

  4281   "filter P (sort_key f xs) = sort_key f (filter P xs)"

  4282   by (induct xs) (simp_all add: filter_insort_triv filter_insort)

  4283

  4284 lemma sorted_map_same:

  4285   "sorted (map f [x\<leftarrow>xs. f x = g xs])"

  4286 proof (induct xs arbitrary: g)

  4287   case Nil then show ?case by simp

  4288 next

  4289   case (Cons x xs)

  4290   then have "sorted (map f [y\<leftarrow>xs . f y = (\<lambda>xs. f x) xs])" .

  4291   moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g \<circ> Cons x) xs])" .

  4292   ultimately show ?case by (simp_all add: sorted_Cons)

  4293 qed

  4294

  4295 lemma sorted_same:

  4296   "sorted [x\<leftarrow>xs. x = g xs]"

  4297   using sorted_map_same [of "\<lambda>x. x"] by simp

  4298

  4299 lemma remove1_insort [simp]:

  4300   "remove1 x (insort x xs) = xs"

  4301   by (induct xs) simp_all

  4302

  4303 end

  4304

  4305 lemma sorted_upt[simp]: "sorted[i..<j]"

  4306 by (induct j) (simp_all add:sorted_append)

  4307

  4308 lemma sorted_upto[simp]: "sorted[i..j]"

  4309 apply(induct i j rule:upto.induct)

  4310 apply(subst upto.simps)

  4311 apply(simp add:sorted_Cons)

  4312 done

  4313

  4314

  4315 subsubsection {* @{const transpose} on sorted lists *}

  4316

  4317 lemma sorted_transpose[simp]:

  4318   shows "sorted (rev (map length (transpose xs)))"

  4319   by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose

  4320     length_filter_conv_card intro: card_mono)

  4321

  4322 lemma transpose_max_length:

  4323   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x \<noteq> []]"

  4324   (is "?L = ?R")

  4325 proof (cases "transpose xs = []")

  4326   case False

  4327   have "?L = foldr max (map length (transpose xs)) 0"

  4328     by (simp add: foldr_map comp_def)

  4329   also have "... = length (transpose xs ! 0)"

  4330     using False sorted_transpose by (simp add: foldr_max_sorted)

  4331   finally show ?thesis

  4332     using False by (simp add: nth_transpose)

  4333 next

  4334   case True

  4335   hence "[x \<leftarrow> xs. x \<noteq> []] = []"

  4336     by (auto intro!: filter_False simp: transpose_empty)

  4337   thus ?thesis by (simp add: transpose_empty True)

  4338 qed

  4339

  4340 lemma length_transpose_sorted:

  4341   fixes xs :: "'a list list"

  4342   assumes sorted: "sorted (rev (map length xs))"

  4343   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"

  4344 proof (cases "xs = []")

  4345   case False

  4346   thus ?thesis

  4347     using foldr_max_sorted[OF sorted] False

  4348     unfolding length_transpose foldr_map comp_def

  4349     by simp

  4350 qed simp

  4351

  4352 lemma nth_nth_transpose_sorted[simp]:

  4353   fixes xs :: "'a list list"

  4354   assumes sorted: "sorted (rev (map length xs))"

  4355   and i: "i < length (transpose xs)"

  4356   and j: "j < length [ys \<leftarrow> xs. i < length ys]"

  4357   shows "transpose xs ! i ! j = xs ! j  ! i"

  4358   using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]

  4359     nth_transpose[OF i] nth_map[OF j]

  4360   by (simp add: takeWhile_nth)

  4361

  4362 lemma transpose_column_length:

  4363   fixes xs :: "'a list list"

  4364   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"

  4365   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"

  4366 proof -

  4367   have "xs \<noteq> []" using i < length xs by auto

  4368   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]

  4369   { fix j assume "j \<le> i"

  4370     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this i < length xs]

  4371   } note sortedE = this[consumes 1]

  4372

  4373   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}

  4374     = {..< length (xs ! i)}"

  4375   proof safe

  4376     fix j

  4377     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"

  4378     with this(2) nth_transpose[OF this(1)]

  4379     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp

  4380     from nth_mem[OF this] takeWhile_nth[OF this]

  4381     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)

  4382   next

  4383     fix j assume "j < length (xs ! i)"

  4384     thus "j < length (transpose xs)"

  4385       using foldr_max_sorted[OF sorted] xs \<noteq> [] sortedE[OF le0]

  4386       by (auto simp: length_transpose comp_def foldr_map)

  4387

  4388     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"

  4389       using i < length xs j < length (xs ! i) less_Suc_eq_le

  4390       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)

  4391     with nth_transpose[OF j < length (transpose xs)]

  4392     show "i < length (transpose xs ! j)" by simp

  4393   qed

  4394   thus ?thesis by (simp add: length_filter_conv_card)

  4395 qed

  4396

  4397 lemma transpose_column:

  4398   fixes xs :: "'a list list"

  4399   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"

  4400   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))

  4401     = xs ! i" (is "?R = _")

  4402 proof (rule nth_equalityI, safe)

  4403   show length: "length ?R = length (xs ! i)"

  4404     using transpose_column_length[OF assms] by simp

  4405

  4406   fix j assume j: "j < length ?R"

  4407   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]

  4408   from j have j_less: "j < length (xs ! i)" using length by simp

  4409   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"

  4410   proof (rule length_takeWhile_less_P_nth)

  4411     show "Suc i \<le> length xs" using i < length xs by simp

  4412     fix k assume "k < Suc i"

  4413     hence "k \<le> i" by auto

  4414     with sorted_rev_nth_mono[OF sorted this] i < length xs

  4415     have "length (xs ! i) \<le> length (xs ! k)" by simp

  4416     thus "Suc j \<le> length (xs ! k)" using j_less by simp

  4417   qed

  4418   have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]"

  4419     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]

  4420     using i_less_tW by (simp_all add: Suc_le_eq)

  4421   from j show "?R ! j = xs ! i ! j"

  4422     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]

  4423     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])

  4424 qed

  4425

  4426 lemma transpose_transpose:

  4427   fixes xs :: "'a list list"

  4428   assumes sorted: "sorted (rev (map length xs))"

  4429   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")

  4430 proof -

  4431   have len: "length ?L = length ?R"

  4432     unfolding length_transpose transpose_max_length

  4433     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]

  4434     by simp

  4435

  4436   { fix i assume "i < length ?R"

  4437     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]

  4438     have "i < length xs" by simp

  4439   } note * = this

  4440   show ?thesis

  4441     by (rule nth_equalityI)

  4442        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)

  4443 qed

  4444

  4445 theorem transpose_rectangle:

  4446   assumes "xs = [] \<Longrightarrow> n = 0"

  4447   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"

  4448   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"

  4449     (is "?trans = ?map")

  4450 proof (rule nth_equalityI)

  4451   have "sorted (rev (map length xs))"

  4452     by (auto simp: rev_nth rect intro!: sorted_nth_monoI)

  4453   from foldr_max_sorted[OF this] assms

  4454   show len: "length ?trans = length ?map"

  4455     by (simp_all add: length_transpose foldr_map comp_def)

  4456   moreover

  4457   { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs"

  4458       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }

  4459   ultimately show "\<forall>i < length ?trans. ?trans ! i = ?map ! i"

  4460     by (auto simp: nth_transpose intro: nth_equalityI)

  4461 qed

  4462

  4463

  4464 subsubsection {* @{text sorted_list_of_set} *}

  4465

  4466 text{* This function maps (finite) linearly ordered sets to sorted

  4467 lists. Warning: in most cases it is not a good idea to convert from

  4468 sets to lists but one should convert in the other direction (via

  4469 @{const set}). *}

  4470

  4471 context linorder

  4472 begin

  4473

  4474 definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where

  4475   "sorted_list_of_set = Finite_Set.fold insort []"

  4476

  4477 lemma sorted_list_of_set_empty [simp]:

  4478   "sorted_list_of_set {} = []"

  4479   by (simp add: sorted_list_of_set_def)

  4480

  4481 lemma sorted_list_of_set_insert [simp]:

  4482   assumes "finite A"

  4483   shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"

  4484 proof -

  4485   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)

  4486   with assms show ?thesis by (simp add: sorted_list_of_set_def fold_insert_remove)

  4487 qed

  4488

  4489 lemma sorted_list_of_set [simp]:

  4490   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A)

  4491     \<and> distinct (sorted_list_of_set A)"

  4492   by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)

  4493

  4494 lemma sorted_list_of_set_sort_remdups:

  4495   "sorted_list_of_set (set xs) = sort (remdups xs)"

  4496 proof -

  4497   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)

  4498   show ?thesis by (simp add: sorted_list_of_set_def sort_conv_fold fold_set_fold_remdups)

  4499 qed

  4500

  4501 lemma sorted_list_of_set_remove:

  4502   assumes "finite A"

  4503   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"

  4504 proof (cases "x \<in> A")

  4505   case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp

  4506   with False show ?thesis by (simp add: remove1_idem)

  4507 next

  4508   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)

  4509   with assms show ?thesis by simp

  4510 qed

  4511

  4512 end

  4513

  4514 lemma sorted_list_of_set_range [simp]:

  4515   "sorted_list_of_set {m..<n} = [m..<n]"

  4516   by (rule sorted_distinct_set_unique) simp_all

  4517

  4518

  4519 subsubsection {* @{text lists}: the list-forming operator over sets *}

  4520

  4521 inductive_set

  4522   lists :: "'a set => 'a list set"

  4523   for A :: "'a set"

  4524 where

  4525     Nil [intro!, simp]: "[]: lists A"

  4526   | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"

  4527

  4528 inductive_cases listsE [elim!,no_atp]: "x#l : lists A"

  4529 inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"

  4530

  4531 inductive_simps listsp_simps[code]:

  4532   "listsp A []"

  4533   "listsp A (x # xs)"

  4534

  4535 lemma listsp_mono [mono]: "A \<le> B ==> listsp A \<le> listsp B"

  4536 by (rule predicate1I, erule listsp.induct, (blast dest: predicate1D)+)

  4537

  4538 lemmas lists_mono = listsp_mono [to_set]

  4539

  4540 lemma listsp_infI:

  4541   assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using l

  4542 by induct blast+

  4543

  4544 lemmas lists_IntI = listsp_infI [to_set]

  4545

  4546 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"

  4547 proof (rule mono_inf [where f=listsp, THEN order_antisym])

  4548   show "mono listsp" by (simp add: mono_def listsp_mono)

  4549   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI predicate1I)

  4550 qed

  4551

  4552 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]

  4553

  4554 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]

  4555

  4556 lemma Cons_in_lists_iff[simp]: "x#xs : lists A \<longleftrightarrow> x:A \<and> xs : lists A"

  4557 by auto

  4558

  4559 lemma append_in_listsp_conv [iff]:

  4560      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"

  4561 by (induct xs) auto

  4562

  4563 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]

  4564

  4565 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"

  4566 -- {* eliminate @{text listsp} in favour of @{text set} *}

  4567 by (induct xs) auto

  4568

  4569 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]

  4570

  4571 lemma in_listspD [dest!,no_atp]: "listsp A xs ==> \<forall>x\<in>set xs. A x"

  4572 by (rule in_listsp_conv_set [THEN iffD1])

  4573

  4574 lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]

  4575

  4576 lemma in_listspI [intro!,no_atp]: "\<forall>x\<in>set xs. A x ==> listsp A xs"

  4577 by (rule in_listsp_conv_set [THEN iffD2])

  4578

  4579 lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]

  4580

  4581 lemma lists_eq_set: "lists A = {xs. set xs <= A}"

  4582 by auto

  4583

  4584 lemma lists_empty [simp]: "lists {} = {[]}"

  4585 by auto

  4586

  4587 lemma lists_UNIV [simp]: "lists UNIV = UNIV"

  4588 by auto

  4589

  4590

  4591 subsubsection {* Inductive definition for membership *}

  4592

  4593 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"

  4594 where

  4595     elem:  "ListMem x (x # xs)"

  4596   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"

  4597

  4598 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"

  4599 apply (rule iffI)

  4600  apply (induct set: ListMem)

  4601   apply auto

  4602 apply (induct xs)

  4603  apply (auto intro: ListMem.intros)

  4604 done

  4605

  4606

  4607 subsubsection {* Lists as Cartesian products *}

  4608

  4609 text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from

  4610 @{term A} and tail drawn from @{term Xs}.*}

  4611

  4612 definition

  4613   set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where

  4614   "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"

  4615

  4616 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])A"

  4617 by (auto simp add: set_Cons_def)

  4618

  4619 text{*Yields the set of lists, all of the same length as the argument and

  4620 with elements drawn from the corresponding element of the argument.*}

  4621

  4622 primrec

  4623   listset :: "'a set list \<Rightarrow> 'a list set" where

  4624      "listset [] = {[]}"

  4625   |  "listset (A # As) = set_Cons A (listset As)"

  4626

  4627

  4628 subsection {* Relations on Lists *}

  4629

  4630 subsubsection {* Length Lexicographic Ordering *}

  4631

  4632 text{*These orderings preserve well-foundedness: shorter lists

  4633   precede longer lists. These ordering are not used in dictionaries.*}

  4634

  4635 primrec -- {*The lexicographic ordering for lists of the specified length*}

  4636   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where

  4637     "lexn r 0 = {}"

  4638   | "lexn r (Suc n) = (map_pair (%(x, xs). x#xs) (%(x, xs). x#xs)  (r <*lex*> lexn r n)) Int

  4639       {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"

  4640

  4641 definition

  4642   lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  4643   "lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}

  4644

  4645 definition

  4646   lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where

  4647   "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"

  4648         -- {*Compares lists by their length and then lexicographically*}

  4649

  4650 lemma wf_lexn: "wf r ==> wf (lexn r n)"

  4651 apply (induct n, simp, simp)

  4652 apply(rule wf_subset)

  4653  prefer 2 apply (rule Int_lower1)

  4654 apply(rule wf_map_pair_image)

  4655  prefer 2 apply (rule inj_onI, auto)

  4656 done

  4657

  4658 lemma lexn_length:

  4659   "(xs, ys) : lexn r n ==> length xs = n \<and> length ys = n"

  4660 by (induct n arbitrary: xs ys) auto

  4661

  4662 lemma wf_lex [intro!]: "wf r ==> wf (lex r)"

  4663 apply (unfold lex_def)

  4664 apply (rule wf_UN)

  4665 apply (blast intro: wf_lexn, clarify)

  4666 apply (rename_tac m n)

  4667 apply (subgoal_tac "m \<noteq> n")

  4668  prefer 2 apply blast

  4669 apply (blast dest: lexn_length not_sym)

  4670 done

  4671

  4672 lemma lexn_conv:

  4673   "lexn r n =

  4674     {(xs,ys). length xs = n \<and> length ys = n \<and>

  4675     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y):r)}"

  4676 apply (induct n, simp)

  4677 apply (simp add: image_Collect lex_prod_def, safe, blast)

  4678  apply (rule_tac x = "ab # xys" in exI, simp)

  4679 apply (case_tac xys, simp_all, blast)

  4680 done

  4681

  4682 lemma lex_conv:

  4683   "lex r =

  4684     {(xs,ys). length xs = length ys \<and>

  4685     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y):r)}"

  4686 by (force simp add: lex_def lexn_conv)

  4687

  4688 lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"

  4689 by (unfold lenlex_def) blast

  4690

  4691 lemma lenlex_conv:

  4692     "lenlex r = {(xs,ys). length xs < length ys |

  4693                  length xs = length ys \<and> (xs, ys) : lex r}"

  4694 by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)

  4695

  4696 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"

  4697 by (simp add: lex_conv)

  4698

  4699 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"

  4700 by (simp add:lex_conv)

  4701

  4702 lemma Cons_in_lex [simp]:

  4703     "((x # xs, y # ys) : lex r) =

  4704       ((x, y) : r \<and> length xs = length ys | x = y \<and> (xs, ys) : lex r)"

  4705 apply (simp add: lex_conv)

  4706 apply (rule iffI)

  4707  prefer 2 apply (blast intro: Cons_eq_appendI, clarify)

  4708 apply (case_tac xys, simp, simp)

  4709 apply blast

  4710 done

  4711

  4712

  4713 subsubsection {* Lexicographic Ordering *}

  4714

  4715 text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".

  4716     This ordering does \emph{not} preserve well-foundedness.

  4717      Author: N. Voelker, March 2005. *}

  4718

  4719 definition

  4720   lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  4721   "lexord r = {(x,y ). \<exists> a v. y = x @ a # v \<or>

  4722             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"

  4723

  4724 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"

  4725 by (unfold lexord_def, induct_tac y, auto)

  4726

  4727 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"

  4728 by (unfold lexord_def, induct_tac x, auto)

  4729

  4730 lemma lexord_cons_cons[simp]:

  4731      "((a # x, b # y) \<in> lexord r) = ((a,b)\<in> r | (a = b & (x,y)\<in> lexord r))"

  4732   apply (unfold lexord_def, safe, simp_all)

  4733   apply (case_tac u, simp, simp)

  4734   apply (case_tac u, simp, clarsimp, blast, blast, clarsimp)

  4735   apply (erule_tac x="b # u" in allE)

  4736   by force

  4737

  4738 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons

  4739

  4740 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"

  4741 by (induct_tac x, auto)

  4742

  4743 lemma lexord_append_left_rightI:

  4744      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"

  4745 by (induct_tac u, auto)

  4746

  4747 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"

  4748 by (induct x, auto)

  4749

  4750 lemma lexord_append_leftD:

  4751      "\<lbrakk> (x @ u, x @ v) \<in> lexord r; (! a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"

  4752 by (erule rev_mp, induct_tac x, auto)

  4753

  4754 lemma lexord_take_index_conv:

  4755    "((x,y) : lexord r) =

  4756     ((length x < length y \<and> take (length x) y = x) \<or>

  4757      (\<exists>i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) \<in> r))"

  4758   apply (unfold lexord_def Let_def, clarsimp)

  4759   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)

  4760   apply auto

  4761   apply (rule_tac x="hd (drop (length x) y)" in exI)

  4762   apply (rule_tac x="tl (drop (length x) y)" in exI)

  4763   apply (erule subst, simp add: min_def)

  4764   apply (rule_tac x ="length u" in exI, simp)

  4765   apply (rule_tac x ="take i x" in exI)

  4766   apply (rule_tac x ="x ! i" in exI)

  4767   apply (rule_tac x ="y ! i" in exI, safe)

  4768   apply (rule_tac x="drop (Suc i) x" in exI)

  4769   apply (drule sym, simp add: drop_Suc_conv_tl)

  4770   apply (rule_tac x="drop (Suc i) y" in exI)

  4771   by (simp add: drop_Suc_conv_tl)

  4772

  4773 -- {* lexord is extension of partial ordering List.lex *}

  4774 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"

  4775   apply (rule_tac x = y in spec)

  4776   apply (induct_tac x, clarsimp)

  4777   by (clarify, case_tac x, simp, force)

  4778

  4779 lemma lexord_irreflexive: "ALL x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"

  4780 by (induct xs) auto

  4781

  4782 text{* By Ren\'e Thiemann: *}

  4783 lemma lexord_partial_trans:

  4784   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)

  4785    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"

  4786 proof (induct xs arbitrary: ys zs)

  4787   case Nil

  4788   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)

  4789 next

  4790   case (Cons x xs yys zzs)

  4791   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def

  4792     by (cases yys, auto)

  4793   note Cons = Cons[unfolded yys]

  4794   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto

  4795   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def

  4796     by (cases zzs, auto)

  4797   note Cons = Cons[unfolded zzs]

  4798   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto

  4799   {

  4800     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"

  4801     from Cons(1)[OF _ this] Cons(2)

  4802     have "(xs,zs) \<in> lexord r" by auto

  4803   } note ind1 = this

  4804   {

  4805     assume "(x,y) \<in> r" and "(y,z) \<in> r"

  4806     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto

  4807   } note ind2 = this

  4808   from one two ind1 ind2

  4809   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast

  4810   thus ?case unfolding zzs by auto

  4811 qed

  4812

  4813 lemma lexord_trans:

  4814     "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"

  4815 by(auto simp: trans_def intro:lexord_partial_trans)

  4816

  4817 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"

  4818 by (rule transI, drule lexord_trans, blast)

  4819

  4820 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"

  4821   apply (rule_tac x = y in spec)

  4822   apply (induct_tac x, rule allI)

  4823   apply (case_tac x, simp, simp)

  4824   apply (rule allI, case_tac x, simp, simp)

  4825   by blast

  4826

  4827

  4828 subsubsection {* Lexicographic combination of measure functions *}

  4829

  4830 text {* These are useful for termination proofs *}

  4831

  4832 definition

  4833   "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"

  4834

  4835 lemma wf_measures[simp]: "wf (measures fs)"

  4836 unfolding measures_def

  4837 by blast

  4838

  4839 lemma in_measures[simp]:

  4840   "(x, y) \<in> measures [] = False"

  4841   "(x, y) \<in> measures (f # fs)

  4842          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"

  4843 unfolding measures_def

  4844 by auto

  4845

  4846 lemma measures_less: "f x < f y ==> (x, y) \<in> measures (f#fs)"

  4847 by simp

  4848

  4849 lemma measures_lesseq: "f x <= f y ==> (x, y) \<in> measures fs ==> (x, y) \<in> measures (f#fs)"

  4850 by auto

  4851

  4852

  4853 subsubsection {* Lifting Relations to Lists: one element *}

  4854

  4855 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  4856 "listrel1 r = {(xs,ys).

  4857    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"

  4858

  4859 lemma listrel1I:

  4860   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>

  4861   (xs, ys) \<in> listrel1 r"

  4862 unfolding listrel1_def by auto

  4863

  4864 lemma listrel1E:

  4865   "\<lbrakk> (xs, ys) \<in> listrel1 r;

  4866      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P

  4867    \<rbrakk> \<Longrightarrow> P"

  4868 unfolding listrel1_def by auto

  4869

  4870 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"

  4871 unfolding listrel1_def by blast

  4872

  4873 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"

  4874 unfolding listrel1_def by blast

  4875

  4876 lemma Cons_listrel1_Cons [iff]:

  4877   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>

  4878    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"

  4879 by (simp add: listrel1_def Cons_eq_append_conv) (blast)

  4880

  4881 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"

  4882 by (metis Cons_listrel1_Cons)

  4883

  4884 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"

  4885 by (metis Cons_listrel1_Cons)

  4886

  4887 lemma append_listrel1I:

  4888   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r

  4889     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"

  4890 unfolding listrel1_def

  4891 by auto (blast intro: append_eq_appendI)+

  4892

  4893 lemma Cons_listrel1E1[elim!]:

  4894   assumes "(x # xs, ys) \<in> listrel1 r"

  4895     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"

  4896     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"

  4897   shows R

  4898 using assms by (cases ys) blast+

  4899

  4900 lemma Cons_listrel1E2[elim!]:

  4901   assumes "(xs, y # ys) \<in> listrel1 r"

  4902     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"

  4903     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"

  4904   shows R

  4905 using assms by (cases xs) blast+

  4906

  4907 lemma snoc_listrel1_snoc_iff:

  4908   "(xs @ [x], ys @ [y]) \<in> listrel1 r

  4909     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")

  4910 proof

  4911   assume ?L thus ?R

  4912     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)

  4913 next

  4914   assume ?R then show ?L unfolding listrel1_def by force

  4915 qed

  4916

  4917 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"

  4918 unfolding listrel1_def by auto

  4919

  4920 lemma listrel1_mono:

  4921   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"

  4922 unfolding listrel1_def by blast

  4923

  4924

  4925 lemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"

  4926 unfolding listrel1_def by blast

  4927

  4928 lemma in_listrel1_converse:

  4929   "(x,y) : listrel1 (r^-1) \<longleftrightarrow> (x,y) : (listrel1 r)^-1"

  4930 unfolding listrel1_def by blast

  4931

  4932 lemma listrel1_iff_update:

  4933   "(xs,ys) \<in> (listrel1 r)

  4934    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")

  4935 proof

  4936   assume "?L"

  4937   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"

  4938     unfolding listrel1_def by auto

  4939   then have "ys = xs[length u := y]" and "length u < length xs"

  4940     and "(xs ! length u, y) \<in> r" by auto

  4941   then show "?R" by auto

  4942 next

  4943   assume "?R"

  4944   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"

  4945     by auto

  4946   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"

  4947     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)

  4948   then show "?L" by (auto simp: listrel1_def)

  4949 qed

  4950

  4951

  4952 text{* Accessible part and wellfoundedness: *}

  4953

  4954 lemma Cons_acc_listrel1I [intro!]:

  4955   "x \<in> acc r \<Longrightarrow> xs \<in> acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> acc (listrel1 r)"

  4956 apply (induct arbitrary: xs set: acc)

  4957 apply (erule thin_rl)

  4958 apply (erule acc_induct)

  4959 apply (rule accI)

  4960 apply (blast)

  4961 done

  4962

  4963 lemma lists_accD: "xs \<in> lists (acc r) \<Longrightarrow> xs \<in> acc (listrel1 r)"

  4964 apply (induct set: lists)

  4965  apply (rule accI)

  4966  apply simp

  4967 apply (rule accI)

  4968 apply (fast dest: acc_downward)

  4969 done

  4970

  4971 lemma lists_accI: "xs \<in> acc (listrel1 r) \<Longrightarrow> xs \<in> lists (acc r)"

  4972 apply (induct set: acc)

  4973 apply clarify

  4974 apply (rule accI)

  4975 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)

  4976 done

  4977

  4978 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"

  4979 by(metis wf_acc_iff in_lists_conv_set lists_accI lists_accD Cons_in_lists_iff)

  4980

  4981

  4982 subsubsection {* Lifting Relations to Lists: all elements *}

  4983

  4984 inductive_set

  4985   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"

  4986   for r :: "('a \<times> 'b) set"

  4987 where

  4988     Nil:  "([],[]) \<in> listrel r"

  4989   | Cons: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (x#xs, y#ys) \<in> listrel r"

  4990

  4991 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"

  4992 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"

  4993 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"

  4994 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"

  4995

  4996

  4997 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"

  4998 by(induct rule: listrel.induct) auto

  4999

  5000 lemma listrel_iff_zip [code_unfold]: "(xs,ys) : listrel r \<longleftrightarrow>

  5001   length xs = length ys & (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")

  5002 proof

  5003   assume ?L thus ?R by induct (auto intro: listrel_eq_len)

  5004 next

  5005   assume ?R thus ?L

  5006     apply (clarify)

  5007     by (induct rule: list_induct2) (auto intro: listrel.intros)

  5008 qed

  5009

  5010 lemma listrel_iff_nth: "(xs,ys) : listrel r \<longleftrightarrow>

  5011   length xs = length ys & (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")

  5012 by (auto simp add: all_set_conv_all_nth listrel_iff_zip)

  5013

  5014

  5015 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"

  5016 apply clarify

  5017 apply (erule listrel.induct)

  5018 apply (blast intro: listrel.intros)+

  5019 done

  5020

  5021 lemma listrel_subset: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"

  5022 apply clarify

  5023 apply (erule listrel.induct, auto)

  5024 done

  5025

  5026 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)"

  5027 apply (simp add: refl_on_def listrel_subset Ball_def)

  5028 apply (rule allI)

  5029 apply (induct_tac x)

  5030 apply (auto intro: listrel.intros)

  5031 done

  5032

  5033 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)"

  5034 apply (auto simp add: sym_def)

  5035 apply (erule listrel.induct)

  5036 apply (blast intro: listrel.intros)+

  5037 done

  5038

  5039 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)"

  5040 apply (simp add: trans_def)

  5041 apply (intro allI)

  5042 apply (rule impI)

  5043 apply (erule listrel.induct)

  5044 apply (blast intro: listrel.intros)+

  5045 done

  5046

  5047 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"

  5048 by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans)

  5049

  5050 lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"

  5051 using listrel_refl_on[of UNIV, OF refl_rtrancl]

  5052 by(auto simp: refl_on_def)

  5053

  5054 lemma listrel_rtrancl_trans:

  5055   "\<lbrakk> (xs,ys) : listrel(r^*);  (ys,zs) : listrel(r^*) \<rbrakk>

  5056   \<Longrightarrow> (xs,zs) : listrel(r^*)"

  5057 by (metis listrel_trans trans_def trans_rtrancl)

  5058

  5059

  5060 lemma listrel_Nil [simp]: "listrel r  {[]} = {[]}"

  5061 by (blast intro: listrel.intros)

  5062

  5063 lemma listrel_Cons:

  5064      "listrel r  {x#xs} = set_Cons (r{x}) (listrel r  {xs})"

  5065 by (auto simp add: set_Cons_def intro: listrel.intros)

  5066

  5067 text {* Relating @{term listrel1}, @{term listrel} and closures: *}

  5068

  5069 lemma listrel1_rtrancl_subset_rtrancl_listrel1:

  5070   "listrel1 (r^*) \<subseteq> (listrel1 r)^*"

  5071 proof (rule subrelI)

  5072   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r^*)"

  5073   { fix x y us vs

  5074     have "(x,y) : r^* \<Longrightarrow> (us @ x # vs, us @ y # vs) : (listrel1 r)^*"

  5075     proof(induct rule: rtrancl.induct)

  5076       case rtrancl_refl show ?case by simp

  5077     next

  5078       case rtrancl_into_rtrancl thus ?case

  5079         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)

  5080     qed }

  5081   thus "(xs,ys) \<in> (listrel1 r)^*" using 1 by(blast elim: listrel1E)

  5082 qed

  5083

  5084 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)^* \<Longrightarrow> length x = length y"

  5085 by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)

  5086

  5087 lemma rtrancl_listrel1_ConsI1:

  5088   "(xs,ys) : (listrel1 r)^* \<Longrightarrow> (x#xs,x#ys) : (listrel1 r)^*"

  5089 apply(induct rule: rtrancl.induct)

  5090  apply simp

  5091 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)

  5092

  5093 lemma rtrancl_listrel1_ConsI2:

  5094   "(x,y) \<in> r^* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)^*

  5095   \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)^*"

  5096   by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1

  5097     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])

  5098

  5099 lemma listrel1_subset_listrel:

  5100   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"

  5101 by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)

  5102

  5103 lemma listrel_reflcl_if_listrel1:

  5104   "(xs,ys) : listrel1 r \<Longrightarrow> (xs,ys) : listrel(r^*)"

  5105 by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)

  5106

  5107 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"

  5108 proof

  5109   { fix x y assume "(x,y) \<in> listrel (r^*)"

  5110     then have "(x,y) \<in> (listrel1 r)^*"

  5111     by induct (auto intro: rtrancl_listrel1_ConsI2) }

  5112   then show "listrel (r^*) \<subseteq> (listrel1 r)^*"

  5113     by (rule subrelI)

  5114 next

  5115   show "listrel (r^*) \<supseteq> (listrel1 r)^*"

  5116   proof(rule subrelI)

  5117     fix xs ys assume "(xs,ys) \<in> (listrel1 r)^*"

  5118     then show "(xs,ys) \<in> listrel (r^*)"

  5119     proof induct

  5120       case base show ?case by(auto simp add: listrel_iff_zip set_zip)

  5121     next

  5122       case (step ys zs)

  5123       thus ?case  by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)

  5124     qed

  5125   qed

  5126 qed

  5127

  5128 lemma rtrancl_listrel1_if_listrel:

  5129   "(xs,ys) : listrel r \<Longrightarrow> (xs,ys) : (listrel1 r)^*"

  5130 by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)

  5131

  5132 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)^*"

  5133 by(fast intro:rtrancl_listrel1_if_listrel)

  5134

  5135

  5136 subsection {* Size function *}

  5137

  5138 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"

  5139 by (rule is_measure_trivial)

  5140

  5141 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (option_size f)"

  5142 by (rule is_measure_trivial)

  5143

  5144 lemma list_size_estimation[termination_simp]:

  5145   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < list_size f xs"

  5146 by (induct xs) auto

  5147

  5148 lemma list_size_estimation'[termination_simp]:

  5149   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> list_size f xs"

  5150 by (induct xs) auto

  5151

  5152 lemma list_size_map[simp]: "list_size f (map g xs) = list_size (f o g) xs"

  5153 by (induct xs) auto

  5154

  5155 lemma list_size_append[simp]: "list_size f (xs @ ys) = list_size f xs + list_size f ys"

  5156 by (induct xs, auto)

  5157

  5158 lemma list_size_pointwise[termination_simp]:

  5159   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"

  5160 by (induct xs) force+

  5161

  5162

  5163 subsection {* Monad operation *}

  5164

  5165 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where

  5166   "bind xs f = concat (map f xs)"

  5167

  5168 hide_const (open) bind

  5169

  5170 lemma bind_simps [simp]:

  5171   "List.bind [] f = []"

  5172   "List.bind (x # xs) f = f x @ List.bind xs f"

  5173   by (simp_all add: bind_def)

  5174

  5175

  5176 subsection {* Transfer *}

  5177

  5178 definition

  5179   embed_list :: "nat list \<Rightarrow> int list"

  5180 where

  5181   "embed_list l = map int l"

  5182

  5183 definition

  5184   nat_list :: "int list \<Rightarrow> bool"

  5185 where

  5186   "nat_list l = nat_set (set l)"

  5187

  5188 definition

  5189   return_list :: "int list \<Rightarrow> nat list"

  5190 where

  5191   "return_list l = map nat l"

  5192

  5193 lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>

  5194     embed_list (return_list l) = l"

  5195   unfolding embed_list_def return_list_def nat_list_def nat_set_def

  5196   apply (induct l)

  5197   apply auto

  5198 done

  5199

  5200 lemma transfer_nat_int_list_functions:

  5201   "l @ m = return_list (embed_list l @ embed_list m)"

  5202   "[] = return_list []"

  5203   unfolding return_list_def embed_list_def

  5204   apply auto

  5205   apply (induct l, auto)

  5206   apply (induct m, auto)

  5207 done

  5208

  5209 (*

  5210 lemma transfer_nat_int_fold1: "fold f l x =

  5211     fold (%x. f (nat x)) (embed_list l) x";

  5212 *)

  5213

  5214

  5215 subsection {* Code generation *}

  5216

  5217 subsubsection {* Counterparts for set-related operations *}

  5218

  5219 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where

  5220   [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"

  5221

  5222 text {*

  5223   Use @{text member} only for generating executable code.  Otherwise use

  5224   @{prop "x \<in> set xs"} instead --- it is much easier to reason about.

  5225 *}

  5226

  5227 lemma member_rec [code]:

  5228   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"

  5229   "member [] y \<longleftrightarrow> False"

  5230   by (auto simp add: member_def)

  5231

  5232 lemma in_set_member (* FIXME delete candidate *):

  5233   "x \<in> set xs \<longleftrightarrow> member xs x"

  5234   by (simp add: member_def)

  5235

  5236 definition list_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5237   list_all_iff [code_abbrev]: "list_all P xs \<longleftrightarrow> Ball (set xs) P"

  5238

  5239 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5240   list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"

  5241

  5242 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5243   list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"

  5244

  5245 text {*

  5246   Usually you should prefer @{text "\<forall>x\<in>set xs"}, @{text "\<exists>x\<in>set xs"}

  5247   and @{text "\<exists>!x. x\<in>set xs \<and> _"} over @{const list_all}, @{const list_ex}

  5248   and @{const list_ex1} in specifications.

  5249 *}

  5250

  5251 lemma list_all_simps [simp, code]:

  5252   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"

  5253   "list_all P [] \<longleftrightarrow> True"

  5254   by (simp_all add: list_all_iff)

  5255

  5256 lemma list_ex_simps [simp, code]:

  5257   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"

  5258   "list_ex P [] \<longleftrightarrow> False"

  5259   by (simp_all add: list_ex_iff)

  5260

  5261 lemma list_ex1_simps [simp, code]:

  5262   "list_ex1 P [] = False"

  5263   "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)"

  5264   by (auto simp add: list_ex1_iff list_all_iff)

  5265

  5266 lemma Ball_set_list_all: (* FIXME delete candidate *)

  5267   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  5268   by (simp add: list_all_iff)

  5269

  5270 lemma Bex_set_list_ex: (* FIXME delete candidate *)

  5271   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  5272   by (simp add: list_ex_iff)

  5273

  5274 lemma list_all_append [simp]:

  5275   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"

  5276   by (auto simp add: list_all_iff)

  5277

  5278 lemma list_ex_append [simp]:

  5279   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"

  5280   by (auto simp add: list_ex_iff)

  5281

  5282 lemma list_all_rev [simp]:

  5283   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"

  5284   by (simp add: list_all_iff)

  5285

  5286 lemma list_ex_rev [simp]:

  5287   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"

  5288   by (simp add: list_ex_iff)

  5289

  5290 lemma list_all_length:

  5291   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"

  5292   by (auto simp add: list_all_iff set_conv_nth)

  5293

  5294 lemma list_ex_length:

  5295   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"

  5296   by (auto simp add: list_ex_iff set_conv_nth)

  5297

  5298 lemma list_all_cong [fundef_cong]:

  5299   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_all f xs = list_all g ys"

  5300   by (simp add: list_all_iff)

  5301

  5302 lemma list_any_cong [fundef_cong]:

  5303   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"

  5304   by (simp add: list_ex_iff)

  5305

  5306 text {* Executable checks for relations on sets *}

  5307

  5308 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where

  5309 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"

  5310

  5311 lemma [code_unfold]:

  5312   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"

  5313 unfolding listrel1p_def by auto

  5314

  5315 lemma [code]:

  5316   "listrel1p r [] xs = False"

  5317   "listrel1p r xs [] =  False"

  5318   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>

  5319      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"

  5320 by (simp add: listrel1p_def)+

  5321

  5322 definition

  5323   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where

  5324   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"

  5325

  5326 lemma [code_unfold]:

  5327   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"

  5328 unfolding lexordp_def by auto

  5329

  5330 lemma [code]:

  5331   "lexordp r xs [] = False"

  5332   "lexordp r [] (y#ys) = True"

  5333   "lexordp r (x # xs) (y # ys) = (r x y | (x = y & lexordp r xs ys))"

  5334 unfolding lexordp_def by auto

  5335

  5336 text {* Bounded quantification and summation over nats. *}

  5337

  5338 lemma atMost_upto [code_unfold]:

  5339   "{..n} = set [0..<Suc n]"

  5340   by auto

  5341

  5342 lemma atLeast_upt [code_unfold]:

  5343   "{..<n} = set [0..<n]"

  5344   by auto

  5345

  5346 lemma greaterThanLessThan_upt [code_unfold]:

  5347   "{n<..<m} = set [Suc n..<m]"

  5348   by auto

  5349

  5350 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]

  5351

  5352 lemma greaterThanAtMost_upt [code_unfold]:

  5353   "{n<..m} = set [Suc n..<Suc m]"

  5354   by auto

  5355

  5356 lemma atLeastAtMost_upt [code_unfold]:

  5357   "{n..m} = set [n..<Suc m]"

  5358   by auto

  5359

  5360 lemma all_nat_less_eq [code_unfold]:

  5361   "(\<forall>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"

  5362   by auto

  5363

  5364 lemma ex_nat_less_eq [code_unfold]:

  5365   "(\<exists>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"

  5366   by auto

  5367

  5368 lemma all_nat_less [code_unfold]:

  5369   "(\<forall>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"

  5370   by auto

  5371

  5372 lemma ex_nat_less [code_unfold]:

  5373   "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"

  5374   by auto

  5375

  5376 lemma setsum_set_upt_conv_listsum_nat [code_unfold]:

  5377   "setsum f (set [m..<n]) = listsum (map f [m..<n])"

  5378   by (simp add: interv_listsum_conv_setsum_set_nat)

  5379

  5380 text {* Summation over ints. *}

  5381

  5382 lemma greaterThanLessThan_upto [code_unfold]:

  5383   "{i<..<j::int} = set [i+1..j - 1]"

  5384 by auto

  5385

  5386 lemma atLeastLessThan_upto [code_unfold]:

  5387   "{i..<j::int} = set [i..j - 1]"

  5388 by auto

  5389

  5390 lemma greaterThanAtMost_upto [code_unfold]:

  5391   "{i<..j::int} = set [i+1..j]"

  5392 by auto

  5393

  5394 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]

  5395

  5396 lemma setsum_set_upto_conv_listsum_int [code_unfold]:

  5397   "setsum f (set [i..j::int]) = listsum (map f [i..j])"

  5398   by (simp add: interv_listsum_conv_setsum_set_int)

  5399

  5400

  5401 subsubsection {* Optimizing by rewriting *}

  5402

  5403 definition null :: "'a list \<Rightarrow> bool" where

  5404   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"

  5405

  5406 text {*

  5407   Efficient emptyness check is implemented by @{const null}.

  5408 *}

  5409

  5410 lemma null_rec [code]:

  5411   "null (x # xs) \<longleftrightarrow> False"

  5412   "null [] \<longleftrightarrow> True"

  5413   by (simp_all add: null_def)

  5414

  5415 lemma eq_Nil_null: (* FIXME delete candidate *)

  5416   "xs = [] \<longleftrightarrow> null xs"

  5417   by (simp add: null_def)

  5418

  5419 lemma equal_Nil_null [code_unfold]:

  5420   "HOL.equal xs [] \<longleftrightarrow> null xs"

  5421   by (simp add: equal eq_Nil_null)

  5422

  5423 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5424   [code_abbrev]: "maps f xs = concat (map f xs)"

  5425

  5426 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5427   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"

  5428

  5429 text {*

  5430   Operations @{const maps} and @{const map_filter} avoid

  5431   intermediate lists on execution -- do not use for proving.

  5432 *}

  5433

  5434 lemma maps_simps [code]:

  5435   "maps f (x # xs) = f x @ maps f xs"

  5436   "maps f [] = []"

  5437   by (simp_all add: maps_def)

  5438

  5439 lemma map_filter_simps [code]:

  5440   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"

  5441   "map_filter f [] = []"

  5442   by (simp_all add: map_filter_def split: option.split)

  5443

  5444 lemma concat_map_maps: (* FIXME delete candidate *)

  5445   "concat (map f xs) = maps f xs"

  5446   by (simp add: maps_def)

  5447

  5448 lemma map_filter_map_filter [code_unfold]:

  5449   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"

  5450   by (simp add: map_filter_def)

  5451

  5452 text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}

  5453 and similiarly for @{text"\<exists>"}. *}

  5454

  5455 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where

  5456   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"

  5457

  5458 lemma [code]:

  5459   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"

  5460 proof -

  5461   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"

  5462   proof -

  5463     fix n

  5464     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"

  5465     then show "P n" by (cases "n = i") simp_all

  5466   qed

  5467   show ?thesis by (auto simp add: all_interval_nat_def intro: *)

  5468 qed

  5469

  5470 lemma list_all_iff_all_interval_nat [code_unfold]:

  5471   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"

  5472   by (simp add: list_all_iff all_interval_nat_def)

  5473

  5474 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:

  5475   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"

  5476   by (simp add: list_ex_iff all_interval_nat_def)

  5477

  5478 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where

  5479   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"

  5480

  5481 lemma [code]:

  5482   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"

  5483 proof -

  5484   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"

  5485   proof -

  5486     fix k

  5487     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"

  5488     then show "P k" by (cases "k = i") simp_all

  5489   qed

  5490   show ?thesis by (auto simp add: all_interval_int_def intro: *)

  5491 qed

  5492

  5493 lemma list_all_iff_all_interval_int [code_unfold]:

  5494   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"

  5495   by (simp add: list_all_iff all_interval_int_def)

  5496

  5497 lemma list_ex_iff_not_all_inverval_int [code_unfold]:

  5498   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"

  5499   by (simp add: list_ex_iff all_interval_int_def)

  5500

  5501 hide_const (open) member null maps map_filter all_interval_nat all_interval_int

  5502

  5503

  5504 subsubsection {* Pretty lists *}

  5505

  5506 use "Tools/list_code.ML"

  5507

  5508 code_type list

  5509   (SML "_ list")

  5510   (OCaml "_ list")

  5511   (Haskell "![(_)]")

  5512   (Scala "List[(_)]")

  5513

  5514 code_const Nil

  5515   (SML "[]")

  5516   (OCaml "[]")

  5517   (Haskell "[]")

  5518   (Scala "!Nil")

  5519

  5520 code_instance list :: equal

  5521   (Haskell -)

  5522

  5523 code_const "HOL.equal \<Colon> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"

  5524   (Haskell infix 4 "==")

  5525

  5526 code_reserved SML

  5527   list

  5528

  5529 code_reserved OCaml

  5530   list

  5531

  5532 setup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}

  5533

  5534

  5535 subsubsection {* Use convenient predefined operations *}

  5536

  5537 code_const "op @"

  5538   (SML infixr 7 "@")

  5539   (OCaml infixr 6 "@")

  5540   (Haskell infixr 5 "++")

  5541   (Scala infixl 7 "++")

  5542

  5543 code_const map

  5544   (Haskell "map")

  5545

  5546 code_const filter

  5547   (Haskell "filter")

  5548

  5549 code_const concat

  5550   (Haskell "concat")

  5551

  5552 code_const List.maps

  5553   (Haskell "concatMap")

  5554

  5555 code_const rev

  5556   (Haskell "reverse")

  5557

  5558 code_const zip

  5559   (Haskell "zip")

  5560

  5561 code_const List.null

  5562   (Haskell "null")

  5563

  5564 code_const takeWhile

  5565   (Haskell "takeWhile")

  5566

  5567 code_const dropWhile

  5568   (Haskell "dropWhile")

  5569

  5570 code_const list_all

  5571   (Haskell "all")

  5572

  5573 code_const list_ex

  5574   (Haskell "any")

  5575

  5576

  5577 subsubsection {* Implementation of sets by lists *}

  5578

  5579 text {* Basic operations *}

  5580

  5581 lemma is_empty_set [code]:

  5582   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"

  5583   by (simp add: Set.is_empty_def null_def)

  5584

  5585 lemma empty_set [code]:

  5586   "{} = set []"

  5587   by simp

  5588

  5589 lemma UNIV_coset [code]:

  5590   "UNIV = List.coset []"

  5591   by simp

  5592

  5593 lemma compl_set [code]:

  5594   "- set xs = List.coset xs"

  5595   by simp

  5596

  5597 lemma compl_coset [code]:

  5598   "- List.coset xs = set xs"

  5599   by simp

  5600

  5601 lemma [code]:

  5602   "x \<in> set xs \<longleftrightarrow> List.member xs x"

  5603   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"

  5604   by (simp_all add: member_def)

  5605

  5606 lemma insert_code [code]:

  5607   "insert x (set xs) = set (List.insert x xs)"

  5608   "insert x (List.coset xs) = List.coset (removeAll x xs)"

  5609   by simp_all

  5610

  5611 lemma remove_code [code]:

  5612   "Set.remove x (set xs) = set (removeAll x xs)"

  5613   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"

  5614   by (simp_all add: remove_def Compl_insert)

  5615

  5616 lemma project_set [code]:

  5617   "Set.project P (set xs) = set (filter P xs)"

  5618   by auto

  5619

  5620 lemma image_set [code]:

  5621   "image f (set xs) = set (map f xs)"

  5622   by simp

  5623

  5624 lemma Ball_set [code]:

  5625   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  5626   by (simp add: list_all_iff)

  5627

  5628 lemma Bex_set [code]:

  5629   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  5630   by (simp add: list_ex_iff)

  5631

  5632 lemma card_set [code]:

  5633   "card (set xs) = length (remdups xs)"

  5634 proof -

  5635   have "card (set (remdups xs)) = length (remdups xs)"

  5636     by (rule distinct_card) simp

  5637   then show ?thesis by simp

  5638 qed

  5639

  5640 lemma the_elem_set [code]:

  5641   "the_elem (set [x]) = x"

  5642   by simp

  5643

  5644 lemma Pow_set [code]:

  5645   "Pow (set []) = {{}}"

  5646   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x  A)"

  5647   by (simp_all add: Pow_insert Let_def)

  5648

  5649 text {* Further operations on sets *}

  5650

  5651 (* Minimal refinement of equality on sets *)

  5652 declare subset_eq[code del]

  5653 lemma subset_code [code]:

  5654   "set xs <= B \<longleftrightarrow> (ALL x : set xs. x : B)"

  5655   "List.coset xs <= List.coset ys \<longleftrightarrow> set ys <= set xs"

  5656   "List.coset [] <= set [] \<longleftrightarrow> False"

  5657 by auto

  5658

  5659 lemma setsum_code [code]:

  5660   "setsum f (set xs) = listsum (map f (remdups xs))"

  5661 by (simp add: listsum_distinct_conv_setsum_set)

  5662

  5663 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where

  5664   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"

  5665

  5666 lemma [code]:

  5667   "map_project f (set xs) = set (List.map_filter f xs)"

  5668 unfolding map_project_def map_filter_def

  5669 by auto (metis (lifting, mono_tags) CollectI image_eqI o_apply the.simps)

  5670

  5671 hide_const (open) map_project

  5672

  5673 text {* Operations on relations *}

  5674

  5675 lemma product_code [code]:

  5676   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"

  5677   by (auto simp add: Product_Type.product_def)

  5678

  5679 lemma Id_on_set [code]:

  5680   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"

  5681   by (auto simp add: Id_on_def)

  5682

  5683 lemma [code]:

  5684   "R  S = List.map_project (%(x, y). if x : S then Some y else None) R"

  5685 unfolding map_project_def by (auto split: prod.split split_if_asm)

  5686

  5687 lemma trancl_set_ntrancl [code]:

  5688   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"

  5689   by (simp add: finite_trancl_ntranl)

  5690

  5691 lemma set_rel_comp [code]:

  5692   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"

  5693   by (auto simp add: Bex_def)

  5694

  5695 lemma wf_set [code]:

  5696   "wf (set xs) = acyclic (set xs)"

  5697   by (simp add: wf_iff_acyclic_if_finite)

  5698

  5699 end
`