src/HOL/List.thy
 author haftmann Fri Jan 06 22:16:01 2012 +0100 (2012-01-06) changeset 46147 2c4d8de91c4c parent 46143 c932c80d3eae child 46149 54ca5b2775a8 permissions -rw-r--r--
moved lemmas about List.set and set operations to List theory
     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 definition

   210   rotate1 :: "'a list \<Rightarrow> 'a list" where

   211   "rotate1 xs = (case xs of [] \<Rightarrow> [] | x#xs \<Rightarrow> 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 add:rotate1_def)}\\

   269 @{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate1_def 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]: "(rev xs = rev ys) = (xs = ys)"

   938 apply (induct xs arbitrary: ys, force)

   939 apply (case_tac ys, simp, force)

   940 done

   941

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

   943 by(simp add:inj_on_def)

   944

   945 lemma rev_induct [case_names Nil snoc]:

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

   947 apply(simplesubst rev_rev_ident[symmetric])

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

   949 done

   950

   951 lemma rev_exhaust [case_names Nil snoc]:

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

   953 by (induct xs rule: rev_induct) auto

   954

   955 lemmas rev_cases = rev_exhaust

   956

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

   958 by(rule rev_cases[of xs]) auto

   959

   960

   961 subsubsection {* @{text set} *}

   962

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

   964 by (induct xs) auto

   965

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

   967 by (induct xs) auto

   968

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

   970 by(cases xs) auto

   971

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

   973 by auto

   974

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

   976 by auto

   977

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

   979 by (induct xs) auto

   980

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

   982 by(induct xs) auto

   983

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

   985 by (induct xs) auto

   986

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

   988 by (induct xs) auto

   989

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

   991 by (induct xs) auto

   992

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

   994 by (induct j) auto

   995

   996

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

   998 proof (induct xs)

   999   case Nil thus ?case by simp

  1000 next

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

  1002 qed

  1003

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

  1005   by (auto elim: split_list)

  1006

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

  1008 proof (induct xs)

  1009   case Nil thus ?case by simp

  1010 next

  1011   case (Cons a xs)

  1012   show ?case

  1013   proof cases

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

  1015   next

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

  1017   qed

  1018 qed

  1019

  1020 lemma in_set_conv_decomp_first:

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

  1022   by (auto dest!: split_list_first)

  1023

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

  1025 proof (induct xs rule: rev_induct)

  1026   case Nil thus ?case by simp

  1027 next

  1028   case (snoc a xs)

  1029   show ?case

  1030   proof cases

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

  1032   next

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

  1034   qed

  1035 qed

  1036

  1037 lemma in_set_conv_decomp_last:

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

  1039   by (auto dest!: split_list_last)

  1040

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

  1042 proof (induct xs)

  1043   case Nil thus ?case by simp

  1044 next

  1045   case Cons thus ?case

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

  1047 qed

  1048

  1049 lemma split_list_propE:

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

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

  1052 using split_list_prop [OF assms] by blast

  1053

  1054 lemma split_list_first_prop:

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

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

  1057 proof (induct xs)

  1058   case Nil thus ?case by simp

  1059 next

  1060   case (Cons x xs)

  1061   show ?case

  1062   proof cases

  1063     assume "P x"

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

  1065   next

  1066     assume "\<not> P x"

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

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

  1069   qed

  1070 qed

  1071

  1072 lemma split_list_first_propE:

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

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

  1075 using split_list_first_prop [OF assms] by blast

  1076

  1077 lemma split_list_first_prop_iff:

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

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

  1080 by (rule, erule split_list_first_prop) auto

  1081

  1082 lemma split_list_last_prop:

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

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

  1085 proof(induct xs rule:rev_induct)

  1086   case Nil thus ?case by simp

  1087 next

  1088   case (snoc x xs)

  1089   show ?case

  1090   proof cases

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

  1092   next

  1093     assume "\<not> P x"

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

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

  1096   qed

  1097 qed

  1098

  1099 lemma split_list_last_propE:

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

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

  1102 using split_list_last_prop [OF assms] by blast

  1103

  1104 lemma split_list_last_prop_iff:

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

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

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

  1108

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

  1110   by (erule finite_induct)

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

  1112

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

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

  1115

  1116 lemma set_minus_filter_out:

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

  1118   by (induct xs) auto

  1119

  1120

  1121 subsubsection {* @{text filter} *}

  1122

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

  1124 by (induct xs) auto

  1125

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

  1127 by (induct xs) simp_all

  1128

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

  1130 by (induct xs) auto

  1131

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

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

  1134

  1135 lemma sum_length_filter_compl:

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

  1137 by(induct xs) simp_all

  1138

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

  1140 by (induct xs) auto

  1141

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

  1143 by (induct xs) auto

  1144

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

  1146 by (induct xs) simp_all

  1147

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

  1149 apply (induct xs)

  1150  apply auto

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

  1152 apply simp

  1153 done

  1154

  1155 lemma filter_map:

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

  1157 by (induct xs) simp_all

  1158

  1159 lemma length_filter_map[simp]:

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

  1161 by (simp add:filter_map)

  1162

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

  1164 by auto

  1165

  1166 lemma length_filter_less:

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

  1168 proof (induct xs)

  1169   case Nil thus ?case by simp

  1170 next

  1171   case (Cons x xs) thus ?case

  1172     apply (auto split:split_if_asm)

  1173     using length_filter_le[of P xs] apply arith

  1174   done

  1175 qed

  1176

  1177 lemma length_filter_conv_card:

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

  1179 proof (induct xs)

  1180   case Nil thus ?case by simp

  1181 next

  1182   case (Cons x xs)

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

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

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

  1186   proof (cases)

  1187     assume "p x"

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

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

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

  1191       using Cons p x by simp

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

  1193       by (simp add: card_image)

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

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

  1196     finally show ?thesis .

  1197   next

  1198     assume "\<not> p x"

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

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

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

  1202       using Cons \<not> p x by simp

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

  1204       by (simp add: card_image)

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

  1206       by (simp add:card_insert_if)

  1207     finally show ?thesis .

  1208   qed

  1209 qed

  1210

  1211 lemma Cons_eq_filterD:

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

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

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

  1215 proof(induct ys)

  1216   case Nil thus ?case by simp

  1217 next

  1218   case (Cons y ys)

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

  1220   proof cases

  1221     assume Py: "P y"

  1222     show ?thesis

  1223     proof cases

  1224       assume "x = y"

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

  1226       then show ?thesis ..

  1227     next

  1228       assume "x \<noteq> y"

  1229       with Py Cons.prems show ?thesis by simp

  1230     qed

  1231   next

  1232     assume "\<not> P y"

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

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

  1235     then show ?thesis ..

  1236   qed

  1237 qed

  1238

  1239 lemma filter_eq_ConsD:

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

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

  1242 by(rule Cons_eq_filterD) simp

  1243

  1244 lemma filter_eq_Cons_iff:

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

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

  1247 by(auto dest:filter_eq_ConsD)

  1248

  1249 lemma Cons_eq_filter_iff:

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

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

  1252 by(auto dest:Cons_eq_filterD)

  1253

  1254 lemma filter_cong[fundef_cong]:

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

  1256 apply simp

  1257 apply(erule thin_rl)

  1258 by (induct ys) simp_all

  1259

  1260

  1261 subsubsection {* List partitioning *}

  1262

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

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

  1265   | "partition P (x # xs) =

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

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

  1268

  1269 lemma partition_filter1:

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

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

  1272

  1273 lemma partition_filter2:

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

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

  1276

  1277 lemma partition_P:

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

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

  1280 proof -

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

  1282     by simp_all

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

  1284 qed

  1285

  1286 lemma partition_set:

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

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

  1289 proof -

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

  1291     by simp_all

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

  1293 qed

  1294

  1295 lemma partition_filter_conv[simp]:

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

  1297 unfolding partition_filter2[symmetric]

  1298 unfolding partition_filter1[symmetric] by simp

  1299

  1300 declare partition.simps[simp del]

  1301

  1302

  1303 subsubsection {* @{text concat} *}

  1304

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

  1306 by (induct xs) auto

  1307

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

  1309 by (induct xss) auto

  1310

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

  1312 by (induct xss) auto

  1313

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

  1315 by (induct xs) auto

  1316

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

  1318 by (induct xs) auto

  1319

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

  1321 by (induct xs) auto

  1322

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

  1324 by (induct xs) auto

  1325

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

  1327 by (induct xs) auto

  1328

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

  1330 proof (induct xs arbitrary: ys)

  1331   case (Cons x xs ys)

  1332   thus ?case by (cases ys) auto

  1333 qed (auto)

  1334

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

  1336 by (simp add: concat_eq_concat_iff)

  1337

  1338

  1339 subsubsection {* @{text nth} *}

  1340

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

  1342 by auto

  1343

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

  1345 by auto

  1346

  1347 declare nth.simps [simp del]

  1348

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

  1350 by(auto simp: Nat.gr0_conv_Suc)

  1351

  1352 lemma nth_append:

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

  1354 apply (induct xs arbitrary: n, simp)

  1355 apply (case_tac n, auto)

  1356 done

  1357

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

  1359 by (induct xs) auto

  1360

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

  1362 by (induct xs) auto

  1363

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

  1365 apply (induct xs arbitrary: n, simp)

  1366 apply (case_tac n, auto)

  1367 done

  1368

  1369 lemma nth_tl:

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

  1371 using assms by (induct x) auto

  1372

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

  1374 by(cases xs) simp_all

  1375

  1376

  1377 lemma list_eq_iff_nth_eq:

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

  1379 apply(induct xs arbitrary: ys)

  1380  apply force

  1381 apply(case_tac ys)

  1382  apply simp

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

  1384 done

  1385

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

  1387 apply (induct xs, simp, simp)

  1388 apply safe

  1389 apply (metis nat_case_0 nth.simps zero_less_Suc)

  1390 apply (metis less_Suc_eq_0_disj nth_Cons_Suc)

  1391 apply (case_tac i, simp)

  1392 apply (metis diff_Suc_Suc nat_case_Suc nth.simps zero_less_diff)

  1393 done

  1394

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

  1396 by(auto simp:set_conv_nth)

  1397

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

  1399 by (auto simp add: set_conv_nth)

  1400

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

  1402 by (auto simp add: set_conv_nth)

  1403

  1404 lemma all_nth_imp_all_set:

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

  1406 by (auto simp add: set_conv_nth)

  1407

  1408 lemma all_set_conv_all_nth:

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

  1410 by (auto simp add: set_conv_nth)

  1411

  1412 lemma rev_nth:

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

  1414 proof (induct xs arbitrary: n)

  1415   case Nil thus ?case by simp

  1416 next

  1417   case (Cons x xs)

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

  1419   moreover

  1420   { assume "n < length xs"

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

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

  1423     moreover

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

  1425     ultimately

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

  1427   }

  1428   ultimately

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

  1430 qed

  1431

  1432 lemma Skolem_list_nth:

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

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

  1435 proof(induct k)

  1436   case 0 show ?case by simp

  1437 next

  1438   case (Suc k)

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

  1440   proof

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

  1442   next

  1443     assume "?L"

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

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

  1446     thus "?R" ..

  1447   qed

  1448 qed

  1449

  1450

  1451 subsubsection {* @{text list_update} *}

  1452

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

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

  1455

  1456 lemma nth_list_update:

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

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

  1459

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

  1461 by (simp add: nth_list_update)

  1462

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

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

  1465

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

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

  1468

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

  1470 apply (induct xs arbitrary: i)

  1471  apply simp

  1472 apply (case_tac i)

  1473 apply simp_all

  1474 done

  1475

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

  1477 by(metis length_0_conv length_list_update)

  1478

  1479 lemma list_update_same_conv:

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

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

  1482

  1483 lemma list_update_append1:

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

  1485 apply (induct xs arbitrary: i, simp)

  1486 apply(simp split:nat.split)

  1487 done

  1488

  1489 lemma list_update_append:

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

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

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

  1493

  1494 lemma list_update_length [simp]:

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

  1496 by (induct xs, auto)

  1497

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

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

  1500

  1501 lemma rev_update:

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

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

  1504

  1505 lemma update_zip:

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

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

  1508

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

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

  1511

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

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

  1514

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

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

  1517

  1518 lemma list_update_overwrite[simp]:

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

  1520 apply (induct xs arbitrary: i) apply simp

  1521 apply (case_tac i, simp_all)

  1522 done

  1523

  1524 lemma list_update_swap:

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

  1526 apply (induct xs arbitrary: i i')

  1527 apply simp

  1528 apply (case_tac i, case_tac i')

  1529 apply auto

  1530 apply (case_tac i')

  1531 apply auto

  1532 done

  1533

  1534 lemma list_update_code [code]:

  1535   "[][i := y] = []"

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

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

  1538   by simp_all

  1539

  1540

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

  1542

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

  1544 by (induct xs) auto

  1545

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

  1547 by (induct xs) auto

  1548

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

  1550   by simp

  1551

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

  1553   by simp

  1554

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

  1556 by (induct xs) (auto)

  1557

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

  1559 by(simp add:last_append)

  1560

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

  1562 by(simp add:last_append)

  1563

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

  1565 by (induct xs) simp_all

  1566

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

  1568 by (induct xs) simp_all

  1569

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

  1571 by(rule rev_exhaust[of xs]) simp_all

  1572

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

  1574 by(cases xs) simp_all

  1575

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

  1577 by (induct as) auto

  1578

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

  1580 by (induct xs rule: rev_induct) auto

  1581

  1582 lemma butlast_append:

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

  1584 by (induct xs arbitrary: ys) auto

  1585

  1586 lemma append_butlast_last_id [simp]:

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

  1588 by (induct xs) auto

  1589

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

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

  1592

  1593 lemma in_set_butlast_appendI:

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

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

  1596

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

  1598 apply (induct xs arbitrary: n)

  1599  apply simp

  1600 apply (auto split:nat.split)

  1601 done

  1602

  1603 lemma nth_butlast:

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

  1605 proof (cases xs)

  1606   case (Cons y ys)

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

  1608     by (simp add: nth_append)

  1609   ultimately show ?thesis using append_butlast_last_id by simp

  1610 qed simp

  1611

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

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

  1614

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

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

  1617

  1618 lemma last_list_update:

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

  1620 by (auto simp: last_conv_nth)

  1621

  1622 lemma butlast_list_update:

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

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

  1625 apply(cases xs rule:rev_cases)

  1626 apply simp

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

  1628 done

  1629

  1630 lemma last_map:

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

  1632   by (cases xs rule: rev_cases) simp_all

  1633

  1634 lemma map_butlast:

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

  1636   by (induct xs) simp_all

  1637

  1638 lemma snoc_eq_iff_butlast:

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

  1640 by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

  1641

  1642

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

  1644

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

  1646 by (induct xs) auto

  1647

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

  1649 by (induct xs) auto

  1650

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

  1652 by simp

  1653

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

  1655 by simp

  1656

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

  1658

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

  1660   unfolding One_nat_def by simp

  1661

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

  1663   unfolding One_nat_def by simp

  1664

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

  1666 by(clarsimp simp add:neq_Nil_conv)

  1667

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

  1669 by(cases xs, simp_all)

  1670

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

  1672 by (induct xs arbitrary: n) simp_all

  1673

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

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

  1676

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

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

  1679

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

  1681 by (simp only: drop_tl)

  1682

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

  1684 apply (induct xs arbitrary: n, simp)

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

  1686 done

  1687

  1688 lemma take_Suc_conv_app_nth:

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

  1690 apply (induct xs arbitrary: i, simp)

  1691 apply (case_tac i, auto)

  1692 done

  1693

  1694 lemma drop_Suc_conv_tl:

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

  1696 apply (induct xs arbitrary: i, simp)

  1697 apply (case_tac i, auto)

  1698 done

  1699

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

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

  1702

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

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

  1705

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

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

  1708

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

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

  1711

  1712 lemma take_append [simp]:

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

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

  1715

  1716 lemma drop_append [simp]:

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

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

  1719

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

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

  1722 apply (case_tac xs, auto)

  1723 apply (case_tac n, auto)

  1724 done

  1725

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

  1727 apply (induct m arbitrary: xs, auto)

  1728 apply (case_tac xs, auto)

  1729 done

  1730

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

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

  1733 apply (case_tac xs, auto)

  1734 done

  1735

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

  1737 apply(induct xs arbitrary: m n)

  1738  apply simp

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

  1740 done

  1741

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

  1743 apply (induct n arbitrary: xs, auto)

  1744 apply (case_tac xs, auto)

  1745 done

  1746

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

  1748 apply(induct xs arbitrary: n)

  1749  apply simp

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

  1751 done

  1752

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

  1754 apply(induct xs arbitrary: n)

  1755 apply simp

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

  1757 done

  1758

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

  1760 apply (induct n arbitrary: xs, auto)

  1761 apply (case_tac xs, auto)

  1762 done

  1763

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

  1765 apply (induct n arbitrary: xs, auto)

  1766 apply (case_tac xs, auto)

  1767 done

  1768

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

  1770 apply (induct xs arbitrary: i, auto)

  1771 apply (case_tac i, auto)

  1772 done

  1773

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

  1775 apply (induct xs arbitrary: i, auto)

  1776 apply (case_tac i, auto)

  1777 done

  1778

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

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

  1781 apply (case_tac n, blast)

  1782 apply (case_tac i, auto)

  1783 done

  1784

  1785 lemma nth_drop [simp]:

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

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

  1788 apply (case_tac xs, auto)

  1789 done

  1790

  1791 lemma butlast_take:

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

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

  1794

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

  1796 by (simp add: butlast_conv_take drop_take add_ac)

  1797

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

  1799 by (simp add: butlast_conv_take min_max.inf_absorb1)

  1800

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

  1802 by (simp add: butlast_conv_take drop_take add_ac)

  1803

  1804 lemma hd_drop_conv_nth: "\<lbrakk> xs \<noteq> []; n < length xs \<rbrakk> \<Longrightarrow> hd(drop n xs) = xs!n"

  1805 by(simp add: hd_conv_nth)

  1806

  1807 lemma set_take_subset_set_take:

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

  1809 apply (induct xs arbitrary: m n)

  1810 apply simp

  1811 apply (case_tac n)

  1812 apply (auto simp: take_Cons)

  1813 done

  1814

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

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

  1817

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

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

  1820

  1821 lemma set_drop_subset_set_drop:

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

  1823 apply(induct xs arbitrary: m n)

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

  1825 apply (metis set_drop_subset subset_iff)

  1826 done

  1827

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

  1829 using set_take_subset by fast

  1830

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

  1832 using set_drop_subset by fast

  1833

  1834 lemma append_eq_conv_conj:

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

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

  1837 apply (case_tac zs, auto)

  1838 done

  1839

  1840 lemma take_add:

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

  1842 apply (induct xs arbitrary: i, auto)

  1843 apply (case_tac i, simp_all)

  1844 done

  1845

  1846 lemma append_eq_append_conv_if:

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

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

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

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

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

  1852  apply simp

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

  1854 apply simp_all

  1855 done

  1856

  1857 lemma take_hd_drop:

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

  1859 apply(induct xs arbitrary: n)

  1860 apply simp

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

  1862 done

  1863

  1864 lemma id_take_nth_drop:

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

  1866 proof -

  1867   assume si: "i < length xs"

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

  1869   moreover

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

  1871     apply (rule_tac take_Suc_conv_app_nth) by arith

  1872   ultimately show ?thesis by auto

  1873 qed

  1874

  1875 lemma upd_conv_take_nth_drop:

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

  1877 proof -

  1878   assume i: "i < length xs"

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

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

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

  1882     using i by (simp add: list_update_append)

  1883   finally show ?thesis .

  1884 qed

  1885

  1886 lemma nth_drop':

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

  1888 apply (induct i arbitrary: xs)

  1889 apply (simp add: neq_Nil_conv)

  1890 apply (erule exE)+

  1891 apply simp

  1892 apply (case_tac xs)

  1893 apply simp_all

  1894 done

  1895

  1896

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

  1898

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

  1900   by (induct xs) auto

  1901

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

  1903 by (induct xs) auto

  1904

  1905 lemma takeWhile_append1 [simp]:

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

  1907 by (induct xs) auto

  1908

  1909 lemma takeWhile_append2 [simp]:

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

  1911 by (induct xs) auto

  1912

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

  1914 by (induct xs) auto

  1915

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

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

  1918

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

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

  1921

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

  1923 by (induct xs) auto

  1924

  1925 lemma dropWhile_append1 [simp]:

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

  1927 by (induct xs) auto

  1928

  1929 lemma dropWhile_append2 [simp]:

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

  1931 by (induct xs) auto

  1932

  1933 lemma dropWhile_append3:

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

  1935 by (induct xs) auto

  1936

  1937 lemma dropWhile_last:

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

  1939 by (auto simp add: dropWhile_append3 in_set_conv_decomp)

  1940

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

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

  1943

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

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

  1946

  1947 lemma takeWhile_eq_all_conv[simp]:

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

  1949 by(induct xs, auto)

  1950

  1951 lemma dropWhile_eq_Nil_conv[simp]:

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

  1953 by(induct xs, auto)

  1954

  1955 lemma dropWhile_eq_Cons_conv:

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

  1957 by(induct xs, auto)

  1958

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

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

  1961

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

  1963 by (induct xs) auto

  1964

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

  1966 by (induct xs) auto

  1967

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

  1969 by (induct xs) auto

  1970

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

  1972 by (induct xs) auto

  1973

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

  1975 by (induct xs) auto

  1976

  1977 lemma hd_dropWhile:

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

  1979 using assms by (induct xs) auto

  1980

  1981 lemma takeWhile_eq_filter:

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

  1983   shows "takeWhile P xs = filter P xs"

  1984 proof -

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

  1986     by simp

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

  1988     unfolding filter_empty_conv using assms by blast

  1989   have "filter P xs = takeWhile P xs"

  1990     unfolding A filter_append B

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

  1992   thus ?thesis ..

  1993 qed

  1994

  1995 lemma takeWhile_eq_take_P_nth:

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

  1997   takeWhile P xs = take n xs"

  1998 proof (induct xs arbitrary: n)

  1999   case (Cons x xs)

  2000   thus ?case

  2001   proof (cases n)

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

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

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

  2005     proof (rule Cons.hyps)

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

  2007     next case goal2 thus ?case using Cons by auto

  2008     qed

  2009     ultimately show ?thesis by simp

  2010    qed simp

  2011 qed simp

  2012

  2013 lemma nth_length_takeWhile:

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

  2015 by (induct xs) auto

  2016

  2017 lemma length_takeWhile_less_P_nth:

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

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

  2020 proof (rule classical)

  2021   assume "\<not> ?thesis"

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

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

  2024 qed

  2025

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

  2027 property. *}

  2028

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

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

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

  2032

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

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

  2035 apply(induct xs)

  2036  apply simp

  2037 apply auto

  2038 apply(subst dropWhile_append2)

  2039 apply auto

  2040 done

  2041

  2042 lemma takeWhile_not_last:

  2043  "\<lbrakk> xs \<noteq> []; distinct xs\<rbrakk> \<Longrightarrow> takeWhile (\<lambda>y. y \<noteq> last xs) xs = butlast xs"

  2044 apply(induct xs)

  2045  apply simp

  2046 apply(case_tac xs)

  2047 apply(auto)

  2048 done

  2049

  2050 lemma takeWhile_cong [fundef_cong]:

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

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

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

  2054

  2055 lemma dropWhile_cong [fundef_cong]:

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

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

  2058 by (induct k arbitrary: l, simp_all)

  2059

  2060

  2061 subsubsection {* @{text zip} *}

  2062

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

  2064 by (induct ys) auto

  2065

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

  2067 by simp

  2068

  2069 declare zip_Cons [simp del]

  2070

  2071 lemma [code]:

  2072   "zip [] ys = []"

  2073   "zip xs [] = []"

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

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

  2076

  2077 lemma zip_Cons1:

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

  2079 by(auto split:list.split)

  2080

  2081 lemma length_zip [simp]:

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

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

  2084

  2085 lemma zip_obtain_same_length:

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

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

  2088   shows "P (zip xs ys)"

  2089 proof -

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

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

  2092     by (rule assms) simp_all

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

  2094   proof (induct xs arbitrary: ys)

  2095     case Nil then show ?case by simp

  2096   next

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

  2098   qed

  2099   ultimately show ?thesis by simp

  2100 qed

  2101

  2102 lemma zip_append1:

  2103 "zip (xs @ ys) zs =

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

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

  2106

  2107 lemma zip_append2:

  2108 "zip xs (ys @ zs) =

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

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

  2111

  2112 lemma zip_append [simp]:

  2113  "[| length xs = length us; length ys = length vs |] ==>

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

  2115 by (simp add: zip_append1)

  2116

  2117 lemma zip_rev:

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

  2119 by (induct rule:list_induct2, simp_all)

  2120

  2121 lemma zip_map_map:

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

  2123 proof (induct xs arbitrary: ys)

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

  2125   show ?case

  2126   proof (cases ys)

  2127     case (Cons y ys')

  2128     show ?thesis unfolding Cons using Cons_x_xs by simp

  2129   qed simp

  2130 qed simp

  2131

  2132 lemma zip_map1:

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

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

  2135

  2136 lemma zip_map2:

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

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

  2139

  2140 lemma map_zip_map:

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

  2142 unfolding zip_map1 by auto

  2143

  2144 lemma map_zip_map2:

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

  2146 unfolding zip_map2 by auto

  2147

  2148 text{* Courtesy of Andreas Lochbihler: *}

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

  2150 by(induct xs) auto

  2151

  2152 lemma nth_zip [simp]:

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

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

  2155 apply (case_tac xs)

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

  2157 done

  2158

  2159 lemma set_zip:

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

  2161 by(simp add: set_conv_nth cong: rev_conj_cong)

  2162

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

  2164 by(induct xs) auto

  2165

  2166 lemma zip_update:

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

  2168 by(rule sym, simp add: update_zip)

  2169

  2170 lemma zip_replicate [simp]:

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

  2172 apply (induct i arbitrary: j, auto)

  2173 apply (case_tac j, auto)

  2174 done

  2175

  2176 lemma take_zip:

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

  2178 apply (induct n arbitrary: xs ys)

  2179  apply simp

  2180 apply (case_tac xs, simp)

  2181 apply (case_tac ys, simp_all)

  2182 done

  2183

  2184 lemma drop_zip:

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

  2186 apply (induct n arbitrary: xs ys)

  2187  apply simp

  2188 apply (case_tac xs, simp)

  2189 apply (case_tac ys, simp_all)

  2190 done

  2191

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

  2193 proof (induct xs arbitrary: ys)

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

  2195 qed simp

  2196

  2197 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"

  2198 proof (induct xs arbitrary: ys)

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

  2200 qed simp

  2201

  2202 lemma set_zip_leftD:

  2203   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"

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

  2205

  2206 lemma set_zip_rightD:

  2207   "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"

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

  2209

  2210 lemma in_set_zipE:

  2211   "(x,y) : set(zip xs ys) \<Longrightarrow> (\<lbrakk> x : set xs; y : set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"

  2212 by(blast dest: set_zip_leftD set_zip_rightD)

  2213

  2214 lemma zip_map_fst_snd:

  2215   "zip (map fst zs) (map snd zs) = zs"

  2216   by (induct zs) simp_all

  2217

  2218 lemma zip_eq_conv:

  2219   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"

  2220   by (auto simp add: zip_map_fst_snd)

  2221

  2222

  2223 subsubsection {* @{text list_all2} *}

  2224

  2225 lemma list_all2_lengthD [intro?]:

  2226   "list_all2 P xs ys ==> length xs = length ys"

  2227 by (simp add: list_all2_def)

  2228

  2229 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"

  2230 by (simp add: list_all2_def)

  2231

  2232 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"

  2233 by (simp add: list_all2_def)

  2234

  2235 lemma list_all2_Cons [iff, code]:

  2236   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"

  2237 by (auto simp add: list_all2_def)

  2238

  2239 lemma list_all2_Cons1:

  2240 "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"

  2241 by (cases ys) auto

  2242

  2243 lemma list_all2_Cons2:

  2244 "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"

  2245 by (cases xs) auto

  2246

  2247 lemma list_all2_induct

  2248   [consumes 1, case_names Nil Cons, induct set: list_all2]:

  2249   assumes P: "list_all2 P xs ys"

  2250   assumes Nil: "R [] []"

  2251   assumes Cons: "\<And>x xs y ys. \<lbrakk>P x y; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"

  2252   shows "R xs ys"

  2253 using P

  2254 by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)

  2255

  2256 lemma list_all2_rev [iff]:

  2257 "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"

  2258 by (simp add: list_all2_def zip_rev cong: conj_cong)

  2259

  2260 lemma list_all2_rev1:

  2261 "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"

  2262 by (subst list_all2_rev [symmetric]) simp

  2263

  2264 lemma list_all2_append1:

  2265 "list_all2 P (xs @ ys) zs =

  2266 (EX us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>

  2267 list_all2 P xs us \<and> list_all2 P ys vs)"

  2268 apply (simp add: list_all2_def zip_append1)

  2269 apply (rule iffI)

  2270  apply (rule_tac x = "take (length xs) zs" in exI)

  2271  apply (rule_tac x = "drop (length xs) zs" in exI)

  2272  apply (force split: nat_diff_split simp add: min_def, clarify)

  2273 apply (simp add: ball_Un)

  2274 done

  2275

  2276 lemma list_all2_append2:

  2277 "list_all2 P xs (ys @ zs) =

  2278 (EX us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>

  2279 list_all2 P us ys \<and> list_all2 P vs zs)"

  2280 apply (simp add: list_all2_def zip_append2)

  2281 apply (rule iffI)

  2282  apply (rule_tac x = "take (length ys) xs" in exI)

  2283  apply (rule_tac x = "drop (length ys) xs" in exI)

  2284  apply (force split: nat_diff_split simp add: min_def, clarify)

  2285 apply (simp add: ball_Un)

  2286 done

  2287

  2288 lemma list_all2_append:

  2289   "length xs = length ys \<Longrightarrow>

  2290   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"

  2291 by (induct rule:list_induct2, simp_all)

  2292

  2293 lemma list_all2_appendI [intro?, trans]:

  2294   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"

  2295 by (simp add: list_all2_append list_all2_lengthD)

  2296

  2297 lemma list_all2_conv_all_nth:

  2298 "list_all2 P xs ys =

  2299 (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"

  2300 by (force simp add: list_all2_def set_zip)

  2301

  2302 lemma list_all2_trans:

  2303   assumes tr: "!!a b c. P1 a b ==> P2 b c ==> P3 a c"

  2304   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> list_all2 P3 as cs"

  2305         (is "!!bs cs. PROP ?Q as bs cs")

  2306 proof (induct as)

  2307   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"

  2308   show "!!cs. PROP ?Q (x # xs) bs cs"

  2309   proof (induct bs)

  2310     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"

  2311     show "PROP ?Q (x # xs) (y # ys) cs"

  2312       by (induct cs) (auto intro: tr I1 I2)

  2313   qed simp

  2314 qed simp

  2315

  2316 lemma list_all2_all_nthI [intro?]:

  2317   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"

  2318 by (simp add: list_all2_conv_all_nth)

  2319

  2320 lemma list_all2I:

  2321   "\<forall>x \<in> set (zip a b). split P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"

  2322 by (simp add: list_all2_def)

  2323

  2324 lemma list_all2_nthD:

  2325   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

  2326 by (simp add: list_all2_conv_all_nth)

  2327

  2328 lemma list_all2_nthD2:

  2329   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

  2330 by (frule list_all2_lengthD) (auto intro: list_all2_nthD)

  2331

  2332 lemma list_all2_map1:

  2333   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"

  2334 by (simp add: list_all2_conv_all_nth)

  2335

  2336 lemma list_all2_map2:

  2337   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"

  2338 by (auto simp add: list_all2_conv_all_nth)

  2339

  2340 lemma list_all2_refl [intro?]:

  2341   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"

  2342 by (simp add: list_all2_conv_all_nth)

  2343

  2344 lemma list_all2_update_cong:

  2345   "\<lbrakk> i<size xs; list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"

  2346 by (simp add: list_all2_conv_all_nth nth_list_update)

  2347

  2348 lemma list_all2_update_cong2:

  2349   "\<lbrakk>list_all2 P xs ys; P x y; i < length ys\<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"

  2350 by (simp add: list_all2_lengthD list_all2_update_cong)

  2351

  2352 lemma list_all2_takeI [simp,intro?]:

  2353   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"

  2354 apply (induct xs arbitrary: n ys)

  2355  apply simp

  2356 apply (clarsimp simp add: list_all2_Cons1)

  2357 apply (case_tac n)

  2358 apply auto

  2359 done

  2360

  2361 lemma list_all2_dropI [simp,intro?]:

  2362   "list_all2 P as bs \<Longrightarrow> list_all2 P (drop n as) (drop n bs)"

  2363 apply (induct as arbitrary: n bs, simp)

  2364 apply (clarsimp simp add: list_all2_Cons1)

  2365 apply (case_tac n, simp, simp)

  2366 done

  2367

  2368 lemma list_all2_mono [intro?]:

  2369   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"

  2370 apply (induct xs arbitrary: ys, simp)

  2371 apply (case_tac ys, auto)

  2372 done

  2373

  2374 lemma list_all2_eq:

  2375   "xs = ys \<longleftrightarrow> list_all2 (op =) xs ys"

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

  2377

  2378 lemma list_eq_iff_zip_eq:

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

  2380 by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)

  2381

  2382

  2383 subsubsection {* @{const fold} with canonical argument order *}

  2384

  2385 lemma fold_remove1_split:

  2386   assumes f: "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x"

  2387     and x: "x \<in> set xs"

  2388   shows "fold f xs = fold f (remove1 x xs) \<circ> f x"

  2389   using assms by (induct xs) (auto simp add: o_assoc [symmetric])

  2390

  2391 lemma fold_cong [fundef_cong]:

  2392   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)

  2393     \<Longrightarrow> fold f xs a = fold g ys b"

  2394   by (induct ys arbitrary: a b xs) simp_all

  2395

  2396 lemma fold_id:

  2397   assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x = id"

  2398   shows "fold f xs = id"

  2399   using assms by (induct xs) simp_all

  2400

  2401 lemma fold_commute:

  2402   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"

  2403   shows "h \<circ> fold g xs = fold f xs \<circ> h"

  2404   using assms by (induct xs) (simp_all add: fun_eq_iff)

  2405

  2406 lemma fold_commute_apply:

  2407   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"

  2408   shows "h (fold g xs s) = fold f xs (h s)"

  2409 proof -

  2410   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)

  2411   then show ?thesis by (simp add: fun_eq_iff)

  2412 qed

  2413

  2414 lemma fold_invariant:

  2415   assumes "\<And>x. x \<in> set xs \<Longrightarrow> Q x" and "P s"

  2416     and "\<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s)"

  2417   shows "P (fold f xs s)"

  2418   using assms by (induct xs arbitrary: s) simp_all

  2419

  2420 lemma fold_append [simp]:

  2421   "fold f (xs @ ys) = fold f ys \<circ> fold f xs"

  2422   by (induct xs) simp_all

  2423

  2424 lemma fold_map [code_unfold]:

  2425   "fold g (map f xs) = fold (g o f) xs"

  2426   by (induct xs) simp_all

  2427

  2428 lemma fold_rev:

  2429   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"

  2430   shows "fold f (rev xs) = fold f xs"

  2431 using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)

  2432

  2433 lemma fold_Cons_rev:

  2434   "fold Cons xs = append (rev xs)"

  2435   by (induct xs) simp_all

  2436

  2437 lemma rev_conv_fold [code]:

  2438   "rev xs = fold Cons xs []"

  2439   by (simp add: fold_Cons_rev)

  2440

  2441 lemma fold_append_concat_rev:

  2442   "fold append xss = append (concat (rev xss))"

  2443   by (induct xss) simp_all

  2444

  2445 text {* @{const Finite_Set.fold} and @{const fold} *}

  2446

  2447 lemma (in comp_fun_commute) fold_set_fold_remdups:

  2448   "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"

  2449   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)

  2450

  2451 lemma (in comp_fun_idem) fold_set_fold:

  2452   "Finite_Set.fold f y (set xs) = fold f xs y"

  2453   by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)

  2454

  2455 lemma (in ab_semigroup_idem_mult) fold1_set_fold:

  2456   assumes "xs \<noteq> []"

  2457   shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)"

  2458 proof -

  2459   interpret comp_fun_idem times by (fact comp_fun_idem)

  2460   from assms obtain y ys where xs: "xs = y # ys"

  2461     by (cases xs) auto

  2462   show ?thesis

  2463   proof (cases "set ys = {}")

  2464     case True with xs show ?thesis by simp

  2465   next

  2466     case False

  2467     then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)"

  2468       by (simp only: finite_set fold1_eq_fold_idem)

  2469     with xs show ?thesis by (simp add: fold_set_fold mult_commute)

  2470   qed

  2471 qed

  2472

  2473 lemma union_set_fold:

  2474   "set xs \<union> A = fold Set.insert xs A"

  2475 proof -

  2476   interpret comp_fun_idem Set.insert

  2477     by (fact comp_fun_idem_insert)

  2478   show ?thesis by (simp add: union_fold_insert fold_set_fold)

  2479 qed

  2480

  2481 lemma minus_set_fold:

  2482   "A - set xs = fold Set.remove xs A"

  2483 proof -

  2484   interpret comp_fun_idem Set.remove

  2485     by (fact comp_fun_idem_remove)

  2486   show ?thesis

  2487     by (simp add: minus_fold_remove [of _ A] fold_set_fold)

  2488 qed

  2489

  2490 lemma (in lattice) Inf_fin_set_fold:

  2491   "Inf_fin (set (x # xs)) = fold inf xs x"

  2492 proof -

  2493   interpret ab_semigroup_idem_mult "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2494     by (fact ab_semigroup_idem_mult_inf)

  2495   show ?thesis

  2496     by (simp add: Inf_fin_def fold1_set_fold del: set.simps)

  2497 qed

  2498

  2499 lemma (in lattice) Sup_fin_set_fold:

  2500   "Sup_fin (set (x # xs)) = fold sup xs x"

  2501 proof -

  2502   interpret ab_semigroup_idem_mult "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2503     by (fact ab_semigroup_idem_mult_sup)

  2504   show ?thesis

  2505     by (simp add: Sup_fin_def fold1_set_fold del: set.simps)

  2506 qed

  2507

  2508 lemma (in linorder) Min_fin_set_fold:

  2509   "Min (set (x # xs)) = fold min xs x"

  2510 proof -

  2511   interpret ab_semigroup_idem_mult "min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2512     by (fact ab_semigroup_idem_mult_min)

  2513   show ?thesis

  2514     by (simp add: Min_def fold1_set_fold del: set.simps)

  2515 qed

  2516

  2517 lemma (in linorder) Max_fin_set_fold:

  2518   "Max (set (x # xs)) = fold max xs x"

  2519 proof -

  2520   interpret ab_semigroup_idem_mult "max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2521     by (fact ab_semigroup_idem_mult_max)

  2522   show ?thesis

  2523     by (simp add: Max_def fold1_set_fold del: set.simps)

  2524 qed

  2525

  2526 lemma (in complete_lattice) Inf_set_fold:

  2527   "Inf (set xs) = fold inf xs top"

  2528 proof -

  2529   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2530     by (fact comp_fun_idem_inf)

  2531   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)

  2532 qed

  2533

  2534 lemma (in complete_lattice) Sup_set_fold:

  2535   "Sup (set xs) = fold sup xs bot"

  2536 proof -

  2537   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"

  2538     by (fact comp_fun_idem_sup)

  2539   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)

  2540 qed

  2541

  2542 lemma (in complete_lattice) INF_set_fold:

  2543   "INFI (set xs) f = fold (inf \<circ> f) xs top"

  2544   unfolding INF_def set_map [symmetric] Inf_set_fold fold_map ..

  2545

  2546 lemma (in complete_lattice) SUP_set_fold:

  2547   "SUPR (set xs) f = fold (sup \<circ> f) xs bot"

  2548   unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map ..

  2549

  2550

  2551 subsubsection {* Fold variants: @{const foldr} and @{const foldl} *}

  2552

  2553 text {* Correspondence *}

  2554

  2555 lemma foldr_foldl: -- {* The Third Duality Theorem'' in Bird \& Wadler: *}

  2556   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"

  2557   by (simp add: foldr_def foldl_def)

  2558

  2559 lemma foldl_foldr:

  2560   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"

  2561   by (simp add: foldr_def foldl_def)

  2562

  2563 lemma foldr_fold:

  2564   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"

  2565   shows "foldr f xs = fold f xs"

  2566   using assms unfolding foldr_def by (rule fold_rev)

  2567

  2568 lemma

  2569   foldr_Nil [code, simp]: "foldr f [] = id"

  2570   and foldr_Cons [code, simp]: "foldr f (x # xs) = f x \<circ> foldr f xs"

  2571   by (simp_all add: foldr_def)

  2572

  2573 lemma

  2574   foldl_Nil [simp]: "foldl f a [] = a"

  2575   and foldl_Cons [simp]: "foldl f a (x # xs) = foldl f (f a x) xs"

  2576   by (simp_all add: foldl_def)

  2577

  2578 lemma foldr_cong [fundef_cong]:

  2579   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f x a = g x a) \<Longrightarrow> foldr f l a = foldr g k b"

  2580   by (auto simp add: foldr_def intro!: fold_cong)

  2581

  2582 lemma foldl_cong [fundef_cong]:

  2583   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f a x = g a x) \<Longrightarrow> foldl f a l = foldl g b k"

  2584   by (auto simp add: foldl_def intro!: fold_cong)

  2585

  2586 lemma foldr_append [simp]:

  2587   "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"

  2588   by (simp add: foldr_def)

  2589

  2590 lemma foldl_append [simp]:

  2591   "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"

  2592   by (simp add: foldl_def)

  2593

  2594 lemma foldr_map [code_unfold]:

  2595   "foldr g (map f xs) a = foldr (g o f) xs a"

  2596   by (simp add: foldr_def fold_map rev_map)

  2597

  2598 lemma foldl_map [code_unfold]:

  2599   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"

  2600   by (simp add: foldl_def fold_map comp_def)

  2601

  2602 text {* Executing operations in terms of @{const foldr} -- tail-recursive! *}

  2603

  2604 lemma concat_conv_foldr [code]:

  2605   "concat xss = foldr append xss []"

  2606   by (simp add: fold_append_concat_rev foldr_def)

  2607

  2608 lemma union_set_foldr:

  2609   "set xs \<union> A = foldr Set.insert xs A"

  2610 proof -

  2611   have "\<And>x y :: 'a. insert y \<circ> insert x = insert x \<circ> insert y"

  2612     by auto

  2613   then show ?thesis by (simp add: union_set_fold foldr_fold)

  2614 qed

  2615

  2616 lemma minus_set_foldr:

  2617   "A - set xs = foldr Set.remove xs A"

  2618 proof -

  2619   have "\<And>x y :: 'a. Set.remove y \<circ> Set.remove x = Set.remove x \<circ> Set.remove y"

  2620     by (auto simp add: remove_def)

  2621   then show ?thesis by (simp add: minus_set_fold foldr_fold)

  2622 qed

  2623

  2624 lemma (in lattice) Inf_fin_set_foldr [code]:

  2625   "Inf_fin (set (x # xs)) = foldr inf xs x"

  2626   by (simp add: Inf_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2627

  2628 lemma (in lattice) Sup_fin_set_foldr [code]:

  2629   "Sup_fin (set (x # xs)) = foldr sup xs x"

  2630   by (simp add: Sup_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2631

  2632 lemma (in linorder) Min_fin_set_foldr [code]:

  2633   "Min (set (x # xs)) = foldr min xs x"

  2634   by (simp add: Min_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2635

  2636 lemma (in linorder) Max_fin_set_foldr [code]:

  2637   "Max (set (x # xs)) = foldr max xs x"

  2638   by (simp add: Max_fin_set_fold ac_simps foldr_fold fun_eq_iff del: set.simps)

  2639

  2640 lemma (in complete_lattice) Inf_set_foldr:

  2641   "Inf (set xs) = foldr inf xs top"

  2642   by (simp add: Inf_set_fold ac_simps foldr_fold fun_eq_iff)

  2643

  2644 lemma (in complete_lattice) Sup_set_foldr:

  2645   "Sup (set xs) = foldr sup xs bot"

  2646   by (simp add: Sup_set_fold ac_simps foldr_fold fun_eq_iff)

  2647

  2648 lemma (in complete_lattice) INF_set_foldr [code]:

  2649   "INFI (set xs) f = foldr (inf \<circ> f) xs top"

  2650   by (simp only: INF_def Inf_set_foldr foldr_map set_map [symmetric])

  2651

  2652 lemma (in complete_lattice) SUP_set_foldr [code]:

  2653   "SUPR (set xs) f = foldr (sup \<circ> f) xs bot"

  2654   by (simp only: SUP_def Sup_set_foldr foldr_map set_map [symmetric])

  2655

  2656

  2657 subsubsection {* @{text upt} *}

  2658

  2659 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"

  2660 -- {* simp does not terminate! *}

  2661 by (induct j) auto

  2662

  2663 lemmas upt_rec_number_of[simp] = upt_rec[of "number_of m" "number_of n"] for m n

  2664

  2665 lemma upt_conv_Nil [simp]: "j <= i ==> [i..<j] = []"

  2666 by (subst upt_rec) simp

  2667

  2668 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j <= i)"

  2669 by(induct j)simp_all

  2670

  2671 lemma upt_eq_Cons_conv:

  2672  "([i..<j] = x#xs) = (i < j & i = x & [i+1..<j] = xs)"

  2673 apply(induct j arbitrary: x xs)

  2674  apply simp

  2675 apply(clarsimp simp add: append_eq_Cons_conv)

  2676 apply arith

  2677 done

  2678

  2679 lemma upt_Suc_append: "i <= j ==> [i..<(Suc j)] = [i..<j]@[j]"

  2680 -- {* Only needed if @{text upt_Suc} is deleted from the simpset. *}

  2681 by simp

  2682

  2683 lemma upt_conv_Cons: "i < j ==> [i..<j] = i # [Suc i..<j]"

  2684   by (simp add: upt_rec)

  2685

  2686 lemma upt_add_eq_append: "i<=j ==> [i..<j+k] = [i..<j]@[j..<j+k]"

  2687 -- {* LOOPS as a simprule, since @{text "j <= j"}. *}

  2688 by (induct k) auto

  2689

  2690 lemma length_upt [simp]: "length [i..<j] = j - i"

  2691 by (induct j) (auto simp add: Suc_diff_le)

  2692

  2693 lemma nth_upt [simp]: "i + k < j ==> [i..<j] ! k = i + k"

  2694 apply (induct j)

  2695 apply (auto simp add: less_Suc_eq nth_append split: nat_diff_split)

  2696 done

  2697

  2698

  2699 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"

  2700 by(simp add:upt_conv_Cons)

  2701

  2702 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"

  2703 apply(cases j)

  2704  apply simp

  2705 by(simp add:upt_Suc_append)

  2706

  2707 lemma take_upt [simp]: "i+m <= n ==> take m [i..<n] = [i..<i+m]"

  2708 apply (induct m arbitrary: i, simp)

  2709 apply (subst upt_rec)

  2710 apply (rule sym)

  2711 apply (subst upt_rec)

  2712 apply (simp del: upt.simps)

  2713 done

  2714

  2715 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"

  2716 apply(induct j)

  2717 apply auto

  2718 done

  2719

  2720 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"

  2721 by (induct n) auto

  2722

  2723 lemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"

  2724 apply (induct n m  arbitrary: i rule: diff_induct)

  2725 prefer 3 apply (subst map_Suc_upt[symmetric])

  2726 apply (auto simp add: less_diff_conv)

  2727 done

  2728

  2729 lemma nth_take_lemma:

  2730   "k <= length xs ==> k <= length ys ==>

  2731      (!!i. i < k --> xs!i = ys!i) ==> take k xs = take k ys"

  2732 apply (atomize, induct k arbitrary: xs ys)

  2733 apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib, clarify)

  2734 txt {* Both lists must be non-empty *}

  2735 apply (case_tac xs, simp)

  2736 apply (case_tac ys, clarify)

  2737  apply (simp (no_asm_use))

  2738 apply clarify

  2739 txt {* prenexing's needed, not miniscoping *}

  2740 apply (simp (no_asm_use) add: all_simps [symmetric] del: all_simps)

  2741 apply blast

  2742 done

  2743

  2744 lemma nth_equalityI:

  2745  "[| length xs = length ys; ALL i < length xs. xs!i = ys!i |] ==> xs = ys"

  2746   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all

  2747

  2748 lemma map_nth:

  2749   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"

  2750   by (rule nth_equalityI, auto)

  2751

  2752 (* needs nth_equalityI *)

  2753 lemma list_all2_antisym:

  2754   "\<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>

  2755   \<Longrightarrow> xs = ys"

  2756   apply (simp add: list_all2_conv_all_nth)

  2757   apply (rule nth_equalityI, blast, simp)

  2758   done

  2759

  2760 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) ==> xs = ys"

  2761 -- {* The famous take-lemma. *}

  2762 apply (drule_tac x = "max (length xs) (length ys)" in spec)

  2763 apply (simp add: le_max_iff_disj)

  2764 done

  2765

  2766

  2767 lemma take_Cons':

  2768      "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"

  2769 by (cases n) simp_all

  2770

  2771 lemma drop_Cons':

  2772      "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"

  2773 by (cases n) simp_all

  2774

  2775 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"

  2776 by (cases n) simp_all

  2777

  2778 lemmas take_Cons_number_of = take_Cons'[of "number_of v"] for v

  2779 lemmas drop_Cons_number_of = drop_Cons'[of "number_of v"] for v

  2780 lemmas nth_Cons_number_of = nth_Cons'[of _ _ "number_of v"] for v

  2781

  2782 declare take_Cons_number_of [simp]

  2783         drop_Cons_number_of [simp]

  2784         nth_Cons_number_of [simp]

  2785

  2786

  2787 subsubsection {* @{text upto}: interval-list on @{typ int} *}

  2788

  2789 (* FIXME make upto tail recursive? *)

  2790

  2791 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where

  2792 "upto i j = (if i \<le> j then i # [i+1..j] else [])"

  2793 by auto

  2794 termination

  2795 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto

  2796

  2797 declare upto.simps[code, simp del]

  2798

  2799 lemmas upto_rec_number_of[simp] = upto.simps[of "number_of m" "number_of n"] for m n

  2800

  2801 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"

  2802 by(simp add: upto.simps)

  2803

  2804 lemma set_upto[simp]: "set[i..j] = {i..j}"

  2805 proof(induct i j rule:upto.induct)

  2806   case (1 i j)

  2807   from this show ?case

  2808     unfolding upto.simps[of i j] simp_from_to[of i j] by auto

  2809 qed

  2810

  2811

  2812 subsubsection {* @{text "distinct"} and @{text remdups} *}

  2813

  2814 lemma distinct_tl:

  2815   "distinct xs \<Longrightarrow> distinct (tl xs)"

  2816   by (cases xs) simp_all

  2817

  2818 lemma distinct_append [simp]:

  2819 "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"

  2820 by (induct xs) auto

  2821

  2822 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"

  2823 by(induct xs) auto

  2824

  2825 lemma set_remdups [simp]: "set (remdups xs) = set xs"

  2826 by (induct xs) (auto simp add: insert_absorb)

  2827

  2828 lemma distinct_remdups [iff]: "distinct (remdups xs)"

  2829 by (induct xs) auto

  2830

  2831 lemma distinct_remdups_id: "distinct xs ==> remdups xs = xs"

  2832 by (induct xs, auto)

  2833

  2834 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"

  2835 by (metis distinct_remdups distinct_remdups_id)

  2836

  2837 lemma finite_distinct_list: "finite A \<Longrightarrow> EX xs. set xs = A & distinct xs"

  2838 by (metis distinct_remdups finite_list set_remdups)

  2839

  2840 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"

  2841 by (induct x, auto)

  2842

  2843 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"

  2844 by (induct x, auto)

  2845

  2846 lemma length_remdups_leq[iff]: "length(remdups xs) <= length xs"

  2847 by (induct xs) auto

  2848

  2849 lemma length_remdups_eq[iff]:

  2850   "(length (remdups xs) = length xs) = (remdups xs = xs)"

  2851 apply(induct xs)

  2852  apply auto

  2853 apply(subgoal_tac "length (remdups xs) <= length xs")

  2854  apply arith

  2855 apply(rule length_remdups_leq)

  2856 done

  2857

  2858 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"

  2859 apply(induct xs)

  2860 apply auto

  2861 done

  2862

  2863 lemma distinct_map:

  2864   "distinct(map f xs) = (distinct xs & inj_on f (set xs))"

  2865 by (induct xs) auto

  2866

  2867

  2868 lemma distinct_filter [simp]: "distinct xs ==> distinct (filter P xs)"

  2869 by (induct xs) auto

  2870

  2871 lemma distinct_upt[simp]: "distinct[i..<j]"

  2872 by (induct j) auto

  2873

  2874 lemma distinct_upto[simp]: "distinct[i..j]"

  2875 apply(induct i j rule:upto.induct)

  2876 apply(subst upto.simps)

  2877 apply(simp)

  2878 done

  2879

  2880 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"

  2881 apply(induct xs arbitrary: i)

  2882  apply simp

  2883 apply (case_tac i)

  2884  apply simp_all

  2885 apply(blast dest:in_set_takeD)

  2886 done

  2887

  2888 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"

  2889 apply(induct xs arbitrary: i)

  2890  apply simp

  2891 apply (case_tac i)

  2892  apply simp_all

  2893 done

  2894

  2895 lemma distinct_list_update:

  2896 assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"

  2897 shows "distinct (xs[i:=a])"

  2898 proof (cases "i < length xs")

  2899   case True

  2900   with a have "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"

  2901     apply (drule_tac id_take_nth_drop) by simp

  2902   with d True show ?thesis

  2903     apply (simp add: upd_conv_take_nth_drop)

  2904     apply (drule subst [OF id_take_nth_drop]) apply assumption

  2905     apply simp apply (cases "a = xs!i") apply simp by blast

  2906 next

  2907   case False with d show ?thesis by auto

  2908 qed

  2909

  2910 lemma distinct_concat:

  2911   assumes "distinct xs"

  2912   and "\<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys"

  2913   and "\<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}"

  2914   shows "distinct (concat xs)"

  2915   using assms by (induct xs) auto

  2916

  2917 text {* It is best to avoid this indexed version of distinct, but

  2918 sometimes it is useful. *}

  2919

  2920 lemma distinct_conv_nth:

  2921 "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j --> xs!i \<noteq> xs!j)"

  2922 apply (induct xs, simp, simp)

  2923 apply (rule iffI, clarsimp)

  2924  apply (case_tac i)

  2925 apply (case_tac j, simp)

  2926 apply (simp add: set_conv_nth)

  2927  apply (case_tac j)

  2928 apply (clarsimp simp add: set_conv_nth, simp)

  2929 apply (rule conjI)

  2930 (*TOO SLOW

  2931 apply (metis Zero_neq_Suc gr0_conv_Suc in_set_conv_nth lessI less_trans_Suc nth_Cons' nth_Cons_Suc)

  2932 *)

  2933  apply (clarsimp simp add: set_conv_nth)

  2934  apply (erule_tac x = 0 in allE, simp)

  2935  apply (erule_tac x = "Suc i" in allE, simp, clarsimp)

  2936 (*TOO SLOW

  2937 apply (metis Suc_Suc_eq lessI less_trans_Suc nth_Cons_Suc)

  2938 *)

  2939 apply (erule_tac x = "Suc i" in allE, simp)

  2940 apply (erule_tac x = "Suc j" in allE, simp)

  2941 done

  2942

  2943 lemma nth_eq_iff_index_eq:

  2944  "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"

  2945 by(auto simp: distinct_conv_nth)

  2946

  2947 lemma distinct_card: "distinct xs ==> card (set xs) = size xs"

  2948 by (induct xs) auto

  2949

  2950 lemma card_distinct: "card (set xs) = size xs ==> distinct xs"

  2951 proof (induct xs)

  2952   case Nil thus ?case by simp

  2953 next

  2954   case (Cons x xs)

  2955   show ?case

  2956   proof (cases "x \<in> set xs")

  2957     case False with Cons show ?thesis by simp

  2958   next

  2959     case True with Cons.prems

  2960     have "card (set xs) = Suc (length xs)"

  2961       by (simp add: card_insert_if split: split_if_asm)

  2962     moreover have "card (set xs) \<le> length xs" by (rule card_length)

  2963     ultimately have False by simp

  2964     thus ?thesis ..

  2965   qed

  2966 qed

  2967

  2968 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"

  2969 by (induct xs) (auto)

  2970

  2971 lemma not_distinct_decomp: "~ distinct ws ==> EX xs ys zs y. ws = xs@[y]@ys@[y]@zs"

  2972 apply (induct n == "length ws" arbitrary:ws) apply simp

  2973 apply(case_tac ws) apply simp

  2974 apply (simp split:split_if_asm)

  2975 apply (metis Cons_eq_appendI eq_Nil_appendI split_list)

  2976 done

  2977

  2978 lemma not_distinct_conv_prefix:

  2979   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"

  2980   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")

  2981 proof

  2982   assume "?L" then show "?R"

  2983   proof (induct "length as" arbitrary: as rule: less_induct)

  2984     case less

  2985     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"

  2986       using not_distinct_decomp[OF less.prems] by auto

  2987     show ?case

  2988     proof (cases "distinct (xs @ y # ys)")

  2989       case True

  2990       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)

  2991       then show ?thesis by blast

  2992     next

  2993       case False

  2994       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"

  2995         by atomize_elim auto

  2996       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)

  2997       then show ?thesis by blast

  2998     qed

  2999   qed

  3000 qed (auto simp: dec_def)

  3001

  3002 lemma length_remdups_concat:

  3003   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"

  3004   by (simp add: distinct_card [symmetric])

  3005

  3006 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"

  3007 proof -

  3008   have xs: "concat[xs] = xs" by simp

  3009   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp

  3010 qed

  3011

  3012 lemma remdups_remdups:

  3013   "remdups (remdups xs) = remdups xs"

  3014   by (induct xs) simp_all

  3015

  3016 lemma distinct_butlast:

  3017   assumes "xs \<noteq> []" and "distinct xs"

  3018   shows "distinct (butlast xs)"

  3019 proof -

  3020   from xs \<noteq> [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto

  3021   with distinct xs show ?thesis by simp

  3022 qed

  3023

  3024 lemma remdups_map_remdups:

  3025   "remdups (map f (remdups xs)) = remdups (map f xs)"

  3026   by (induct xs) simp_all

  3027

  3028 lemma distinct_zipI1:

  3029   assumes "distinct xs"

  3030   shows "distinct (zip xs ys)"

  3031 proof (rule zip_obtain_same_length)

  3032   fix xs' :: "'a list" and ys' :: "'b list" and n

  3033   assume "length xs' = length ys'"

  3034   assume "xs' = take n xs"

  3035   with assms have "distinct xs'" by simp

  3036   with length xs' = length ys' show "distinct (zip xs' ys')"

  3037     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)

  3038 qed

  3039

  3040 lemma distinct_zipI2:

  3041   assumes "distinct ys"

  3042   shows "distinct (zip xs ys)"

  3043 proof (rule zip_obtain_same_length)

  3044   fix xs' :: "'b list" and ys' :: "'a list" and n

  3045   assume "length xs' = length ys'"

  3046   assume "ys' = take n ys"

  3047   with assms have "distinct ys'" by simp

  3048   with length xs' = length ys' show "distinct (zip xs' ys')"

  3049     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)

  3050 qed

  3051

  3052 (* The next two lemmas help Sledgehammer. *)

  3053

  3054 lemma distinct_singleton: "distinct [x]" by simp

  3055

  3056 lemma distinct_length_2_or_more:

  3057 "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"

  3058 by (metis distinct.simps(2) hd.simps hd_in_set list.simps(2) set_ConsD set_rev_mp set_subset_Cons)

  3059

  3060 subsubsection {* List summation: @{const listsum} and @{text"\<Sum>"}*}

  3061

  3062 lemma (in monoid_add) listsum_simps [simp]:

  3063   "listsum [] = 0"

  3064   "listsum (x # xs) = x + listsum xs"

  3065   by (simp_all add: listsum_def)

  3066

  3067 lemma (in monoid_add) listsum_append [simp]:

  3068   "listsum (xs @ ys) = listsum xs + listsum ys"

  3069   by (induct xs) (simp_all add: add.assoc)

  3070

  3071 lemma (in comm_monoid_add) listsum_rev [simp]:

  3072   "listsum (rev xs) = listsum xs"

  3073   by (simp add: listsum_def foldr_def fold_rev fun_eq_iff add_ac)

  3074

  3075 lemma (in monoid_add) fold_plus_listsum_rev:

  3076   "fold plus xs = plus (listsum (rev xs))"

  3077 proof

  3078   fix x

  3079   have "fold plus xs x = fold plus xs (x + 0)" by simp

  3080   also have "\<dots> = fold plus (x # xs) 0" by simp

  3081   also have "\<dots> = foldr plus (rev xs @ [x]) 0" by (simp add: foldr_def)

  3082   also have "\<dots> = listsum (rev xs @ [x])" by (simp add: listsum_def)

  3083   also have "\<dots> = listsum (rev xs) + listsum [x]" by simp

  3084   finally show "fold plus xs x = listsum (rev xs) + x" by simp

  3085 qed

  3086

  3087 lemma (in semigroup_add) foldl_assoc:

  3088   "foldl plus (x + y) zs = x + foldl plus y zs"

  3089   by (simp add: foldl_def fold_commute_apply [symmetric] fun_eq_iff add_assoc)

  3090

  3091 lemma (in ab_semigroup_add) foldr_conv_foldl:

  3092   "foldr plus xs a = foldl plus a xs"

  3093   by (simp add: foldl_def foldr_fold fun_eq_iff add_ac)

  3094

  3095 text {*

  3096   Note: @{text "n \<le> foldl (op +) n ns"} looks simpler, but is more

  3097   difficult to use because it requires an additional transitivity step.

  3098 *}

  3099

  3100 lemma start_le_sum:

  3101   fixes m n :: nat

  3102   shows "m \<le> n \<Longrightarrow> m \<le> foldl plus n ns"

  3103   by (simp add: foldl_def add_commute fold_plus_listsum_rev)

  3104

  3105 lemma elem_le_sum:

  3106   fixes m n :: nat

  3107   shows "n \<in> set ns \<Longrightarrow> n \<le> foldl plus 0 ns"

  3108   by (force intro: start_le_sum simp add: in_set_conv_decomp)

  3109

  3110 lemma sum_eq_0_conv [iff]:

  3111   fixes m :: nat

  3112   shows "foldl plus m ns = 0 \<longleftrightarrow> m = 0 \<and> (\<forall>n \<in> set ns. n = 0)"

  3113   by (induct ns arbitrary: m) auto

  3114

  3115 text{* Some syntactic sugar for summing a function over a list: *}

  3116

  3117 syntax

  3118   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3SUM _<-_. _)" [0, 51, 10] 10)

  3119 syntax (xsymbols)

  3120   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

  3121 syntax (HTML output)

  3122   "_listsum" :: "pttrn => 'a list => 'b => 'b"    ("(3\<Sum>_\<leftarrow>_. _)" [0, 51, 10] 10)

  3123

  3124 translations -- {* Beware of argument permutation! *}

  3125   "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)"

  3126   "\<Sum>x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"

  3127

  3128 lemma (in comm_monoid_add) listsum_map_remove1:

  3129   "x \<in> set xs \<Longrightarrow> listsum (map f xs) = f x + listsum (map f (remove1 x xs))"

  3130   by (induct xs) (auto simp add: ac_simps)

  3131

  3132 lemma (in monoid_add) list_size_conv_listsum:

  3133   "list_size f xs = listsum (map f xs) + size xs"

  3134   by (induct xs) auto

  3135

  3136 lemma (in monoid_add) length_concat:

  3137   "length (concat xss) = listsum (map length xss)"

  3138   by (induct xss) simp_all

  3139

  3140 lemma (in monoid_add) listsum_map_filter:

  3141   assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> f x = 0"

  3142   shows "listsum (map f (filter P xs)) = listsum (map f xs)"

  3143   using assms by (induct xs) auto

  3144

  3145 lemma (in monoid_add) distinct_listsum_conv_Setsum:

  3146   "distinct xs \<Longrightarrow> listsum xs = Setsum (set xs)"

  3147   by (induct xs) simp_all

  3148

  3149 lemma listsum_eq_0_nat_iff_nat [simp]:

  3150   "listsum ns = (0::nat) \<longleftrightarrow> (\<forall>n \<in> set ns. n = 0)"

  3151   by (simp add: listsum_def foldr_conv_foldl)

  3152

  3153 lemma elem_le_listsum_nat:

  3154   "k < size ns \<Longrightarrow> ns ! k \<le> listsum (ns::nat list)"

  3155 apply(induct ns arbitrary: k)

  3156  apply simp

  3157 apply(fastforce simp add:nth_Cons split: nat.split)

  3158 done

  3159

  3160 lemma listsum_update_nat:

  3161   "k<size ns \<Longrightarrow> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"

  3162 apply(induct ns arbitrary:k)

  3163  apply (auto split:nat.split)

  3164 apply(drule elem_le_listsum_nat)

  3165 apply arith

  3166 done

  3167

  3168 lemma (in monoid_add) listsum_triv:

  3169   "(\<Sum>x\<leftarrow>xs. r) = of_nat (length xs) * r"

  3170   by (induct xs) (simp_all add: left_distrib)

  3171

  3172 lemma (in monoid_add) listsum_0 [simp]:

  3173   "(\<Sum>x\<leftarrow>xs. 0) = 0"

  3174   by (induct xs) (simp_all add: left_distrib)

  3175

  3176 text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}

  3177 lemma (in ab_group_add) uminus_listsum_map:

  3178   "- listsum (map f xs) = listsum (map (uminus \<circ> f) xs)"

  3179   by (induct xs) simp_all

  3180

  3181 lemma (in comm_monoid_add) listsum_addf:

  3182   "(\<Sum>x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)"

  3183   by (induct xs) (simp_all add: algebra_simps)

  3184

  3185 lemma (in ab_group_add) listsum_subtractf:

  3186   "(\<Sum>x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)"

  3187   by (induct xs) (simp_all add: algebra_simps)

  3188

  3189 lemma (in semiring_0) listsum_const_mult:

  3190   "(\<Sum>x\<leftarrow>xs. c * f x) = c * (\<Sum>x\<leftarrow>xs. f x)"

  3191   by (induct xs) (simp_all add: algebra_simps)

  3192

  3193 lemma (in semiring_0) listsum_mult_const:

  3194   "(\<Sum>x\<leftarrow>xs. f x * c) = (\<Sum>x\<leftarrow>xs. f x) * c"

  3195   by (induct xs) (simp_all add: algebra_simps)

  3196

  3197 lemma (in ordered_ab_group_add_abs) listsum_abs:

  3198   "\<bar>listsum xs\<bar> \<le> listsum (map abs xs)"

  3199   by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])

  3200

  3201 lemma listsum_mono:

  3202   fixes f g :: "'a \<Rightarrow> 'b::{monoid_add, ordered_ab_semigroup_add}"

  3203   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)"

  3204   by (induct xs) (simp, simp add: add_mono)

  3205

  3206 lemma (in monoid_add) listsum_distinct_conv_setsum_set:

  3207   "distinct xs \<Longrightarrow> listsum (map f xs) = setsum f (set xs)"

  3208   by (induct xs) simp_all

  3209

  3210 lemma (in monoid_add) interv_listsum_conv_setsum_set_nat:

  3211   "listsum (map f [m..<n]) = setsum f (set [m..<n])"

  3212   by (simp add: listsum_distinct_conv_setsum_set)

  3213

  3214 lemma (in monoid_add) interv_listsum_conv_setsum_set_int:

  3215   "listsum (map f [k..l]) = setsum f (set [k..l])"

  3216   by (simp add: listsum_distinct_conv_setsum_set)

  3217

  3218 text {* General equivalence between @{const listsum} and @{const setsum} *}

  3219 lemma (in monoid_add) listsum_setsum_nth:

  3220   "listsum xs = (\<Sum> i = 0 ..< length xs. xs ! i)"

  3221   using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)

  3222

  3223

  3224 subsubsection {* @{const insert} *}

  3225

  3226 lemma in_set_insert [simp]:

  3227   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"

  3228   by (simp add: List.insert_def)

  3229

  3230 lemma not_in_set_insert [simp]:

  3231   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"

  3232   by (simp add: List.insert_def)

  3233

  3234 lemma insert_Nil [simp]:

  3235   "List.insert x [] = [x]"

  3236   by simp

  3237

  3238 lemma set_insert [simp]:

  3239   "set (List.insert x xs) = insert x (set xs)"

  3240   by (auto simp add: List.insert_def)

  3241

  3242 lemma distinct_insert [simp]:

  3243   "distinct xs \<Longrightarrow> distinct (List.insert x xs)"

  3244   by (simp add: List.insert_def)

  3245

  3246 lemma insert_remdups:

  3247   "List.insert x (remdups xs) = remdups (List.insert x xs)"

  3248   by (simp add: List.insert_def)

  3249

  3250

  3251 subsubsection {* @{text remove1} *}

  3252

  3253 lemma remove1_append:

  3254   "remove1 x (xs @ ys) =

  3255   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"

  3256 by (induct xs) auto

  3257

  3258 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"

  3259 by (induct zs) auto

  3260

  3261 lemma in_set_remove1[simp]:

  3262   "a \<noteq> b \<Longrightarrow> a : set(remove1 b xs) = (a : set xs)"

  3263 apply (induct xs)

  3264 apply auto

  3265 done

  3266

  3267 lemma set_remove1_subset: "set(remove1 x xs) <= set xs"

  3268 apply(induct xs)

  3269  apply simp

  3270 apply simp

  3271 apply blast

  3272 done

  3273

  3274 lemma set_remove1_eq [simp]: "distinct xs ==> set(remove1 x xs) = set xs - {x}"

  3275 apply(induct xs)

  3276  apply simp

  3277 apply simp

  3278 apply blast

  3279 done

  3280

  3281 lemma length_remove1:

  3282   "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"

  3283 apply (induct xs)

  3284  apply (auto dest!:length_pos_if_in_set)

  3285 done

  3286

  3287 lemma remove1_filter_not[simp]:

  3288   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"

  3289 by(induct xs) auto

  3290

  3291 lemma filter_remove1:

  3292   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"

  3293 by (induct xs) auto

  3294

  3295 lemma notin_set_remove1[simp]: "x ~: set xs ==> x ~: set(remove1 y xs)"

  3296 apply(insert set_remove1_subset)

  3297 apply fast

  3298 done

  3299

  3300 lemma distinct_remove1[simp]: "distinct xs ==> distinct(remove1 x xs)"

  3301 by (induct xs) simp_all

  3302

  3303 lemma remove1_remdups:

  3304   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"

  3305   by (induct xs) simp_all

  3306

  3307 lemma remove1_idem:

  3308   assumes "x \<notin> set xs"

  3309   shows "remove1 x xs = xs"

  3310   using assms by (induct xs) simp_all

  3311

  3312

  3313 subsubsection {* @{text removeAll} *}

  3314

  3315 lemma removeAll_filter_not_eq:

  3316   "removeAll x = filter (\<lambda>y. x \<noteq> y)"

  3317 proof

  3318   fix xs

  3319   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"

  3320     by (induct xs) auto

  3321 qed

  3322

  3323 lemma removeAll_append[simp]:

  3324   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"

  3325 by (induct xs) auto

  3326

  3327 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"

  3328 by (induct xs) auto

  3329

  3330 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"

  3331 by (induct xs) auto

  3332

  3333 (* Needs count:: 'a \<Rightarrow> a' list \<Rightarrow> nat

  3334 lemma length_removeAll:

  3335   "length(removeAll x xs) = length xs - count x xs"

  3336 *)

  3337

  3338 lemma removeAll_filter_not[simp]:

  3339   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"

  3340 by(induct xs) auto

  3341

  3342 lemma distinct_removeAll:

  3343   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"

  3344   by (simp add: removeAll_filter_not_eq)

  3345

  3346 lemma distinct_remove1_removeAll:

  3347   "distinct xs ==> remove1 x xs = removeAll x xs"

  3348 by (induct xs) simp_all

  3349

  3350 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>

  3351   map f (removeAll x xs) = removeAll (f x) (map f xs)"

  3352 by (induct xs) (simp_all add:inj_on_def)

  3353

  3354 lemma map_removeAll_inj: "inj f \<Longrightarrow>

  3355   map f (removeAll x xs) = removeAll (f x) (map f xs)"

  3356 by(metis map_removeAll_inj_on subset_inj_on subset_UNIV)

  3357

  3358

  3359 subsubsection {* @{text replicate} *}

  3360

  3361 lemma length_replicate [simp]: "length (replicate n x) = n"

  3362 by (induct n) auto

  3363

  3364 lemma Ex_list_of_length: "\<exists>xs. length xs = n"

  3365 by (rule exI[of _ "replicate n undefined"]) simp

  3366

  3367 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"

  3368 by (induct n) auto

  3369

  3370 lemma map_replicate_const:

  3371   "map (\<lambda> x. k) lst = replicate (length lst) k"

  3372   by (induct lst) auto

  3373

  3374 lemma replicate_app_Cons_same:

  3375 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"

  3376 by (induct n) auto

  3377

  3378 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"

  3379 apply (induct n, simp)

  3380 apply (simp add: replicate_app_Cons_same)

  3381 done

  3382

  3383 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"

  3384 by (induct n) auto

  3385

  3386 text{* Courtesy of Matthias Daum: *}

  3387 lemma append_replicate_commute:

  3388   "replicate n x @ replicate k x = replicate k x @ replicate n x"

  3389 apply (simp add: replicate_add [THEN sym])

  3390 apply (simp add: add_commute)

  3391 done

  3392

  3393 text{* Courtesy of Andreas Lochbihler: *}

  3394 lemma filter_replicate:

  3395   "filter P (replicate n x) = (if P x then replicate n x else [])"

  3396 by(induct n) auto

  3397

  3398 lemma hd_replicate [simp]: "n \<noteq> 0 ==> hd (replicate n x) = x"

  3399 by (induct n) auto

  3400

  3401 lemma tl_replicate [simp]: "n \<noteq> 0 ==> tl (replicate n x) = replicate (n - 1) x"

  3402 by (induct n) auto

  3403

  3404 lemma last_replicate [simp]: "n \<noteq> 0 ==> last (replicate n x) = x"

  3405 by (atomize (full), induct n) auto

  3406

  3407 lemma nth_replicate[simp]: "i < n ==> (replicate n x)!i = x"

  3408 apply (induct n arbitrary: i, simp)

  3409 apply (simp add: nth_Cons split: nat.split)

  3410 done

  3411

  3412 text{* Courtesy of Matthias Daum (2 lemmas): *}

  3413 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"

  3414 apply (case_tac "k \<le> i")

  3415  apply  (simp add: min_def)

  3416 apply (drule not_leE)

  3417 apply (simp add: min_def)

  3418 apply (subgoal_tac "replicate k x = replicate i x @ replicate (k - i) x")

  3419  apply  simp

  3420 apply (simp add: replicate_add [symmetric])

  3421 done

  3422

  3423 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"

  3424 apply (induct k arbitrary: i)

  3425  apply simp

  3426 apply clarsimp

  3427 apply (case_tac i)

  3428  apply simp

  3429 apply clarsimp

  3430 done

  3431

  3432

  3433 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"

  3434 by (induct n) auto

  3435

  3436 lemma set_replicate [simp]: "n \<noteq> 0 ==> set (replicate n x) = {x}"

  3437 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)

  3438

  3439 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"

  3440 by auto

  3441

  3442 lemma in_set_replicate[simp]: "(x : set (replicate n y)) = (x = y & n \<noteq> 0)"

  3443 by (simp add: set_replicate_conv_if)

  3444

  3445 lemma Ball_set_replicate[simp]:

  3446   "(ALL x : set(replicate n a). P x) = (P a | n=0)"

  3447 by(simp add: set_replicate_conv_if)

  3448

  3449 lemma Bex_set_replicate[simp]:

  3450   "(EX x : set(replicate n a). P x) = (P a & n\<noteq>0)"

  3451 by(simp add: set_replicate_conv_if)

  3452

  3453 lemma replicate_append_same:

  3454   "replicate i x @ [x] = x # replicate i x"

  3455   by (induct i) simp_all

  3456

  3457 lemma map_replicate_trivial:

  3458   "map (\<lambda>i. x) [0..<i] = replicate i x"

  3459   by (induct i) (simp_all add: replicate_append_same)

  3460

  3461 lemma concat_replicate_trivial[simp]:

  3462   "concat (replicate i []) = []"

  3463   by (induct i) (auto simp add: map_replicate_const)

  3464

  3465 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"

  3466 by (induct n) auto

  3467

  3468 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"

  3469 by (induct n) auto

  3470

  3471 lemma replicate_eq_replicate[simp]:

  3472   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n & (m\<noteq>0 \<longrightarrow> x=y))"

  3473 apply(induct m arbitrary: n)

  3474  apply simp

  3475 apply(induct_tac n)

  3476 apply auto

  3477 done

  3478

  3479 lemma replicate_length_filter:

  3480   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"

  3481   by (induct xs) auto

  3482

  3483 lemma comm_append_are_replicate:

  3484   fixes xs ys :: "'a list"

  3485   assumes "xs \<noteq> []" "ys \<noteq> []"

  3486   assumes "xs @ ys = ys @ xs"

  3487   shows "\<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"

  3488   using assms

  3489 proof (induct "length (xs @ ys)" arbitrary: xs ys rule: less_induct)

  3490   case less

  3491

  3492   def xs' \<equiv> "if (length xs \<le> length ys) then xs else ys"

  3493     and ys' \<equiv> "if (length xs \<le> length ys) then ys else xs"

  3494   then have

  3495     prems': "length xs' \<le> length ys'"

  3496             "xs' @ ys' = ys' @ xs'"

  3497       and "xs' \<noteq> []"

  3498       and len: "length (xs @ ys) = length (xs' @ ys')"

  3499     using less by (auto intro: less.hyps)

  3500

  3501   from prems'

  3502   obtain ws where "ys' = xs' @ ws"

  3503     by (auto simp: append_eq_append_conv2)

  3504

  3505   have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ys'"

  3506   proof (cases "ws = []")

  3507     case True

  3508     then have "concat (replicate 1 xs') = xs'"

  3509       and "concat (replicate 1 xs') = ys'"

  3510       using ys' = xs' @ ws by auto

  3511     then show ?thesis by blast

  3512   next

  3513     case False

  3514     from ys' = xs' @ ws and xs' @ ys' = ys' @ xs'

  3515     have "xs' @ ws = ws @ xs'" by simp

  3516     then have "\<exists>m n zs. concat (replicate m zs) = xs' \<and> concat (replicate n zs) = ws"

  3517       using False and xs' \<noteq> [] and ys' = xs' @ ws and len

  3518       by (intro less.hyps) auto

  3519     then obtain m n zs where "concat (replicate m zs) = xs'"

  3520       and "concat (replicate n zs) = ws" by blast

  3521     moreover

  3522     then have "concat (replicate (m + n) zs) = ys'"

  3523       using ys' = xs' @ ws

  3524       by (simp add: replicate_add)

  3525     ultimately

  3526     show ?thesis by blast

  3527   qed

  3528   then show ?case

  3529     using xs'_def ys'_def by metis

  3530 qed

  3531

  3532 lemma comm_append_is_replicate:

  3533   fixes xs ys :: "'a list"

  3534   assumes "xs \<noteq> []" "ys \<noteq> []"

  3535   assumes "xs @ ys = ys @ xs"

  3536   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"

  3537

  3538 proof -

  3539   obtain m n zs where "concat (replicate m zs) = xs"

  3540     and "concat (replicate n zs) = ys"

  3541     using assms by (metis comm_append_are_replicate)

  3542   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"

  3543     using xs \<noteq> [] and ys \<noteq> []

  3544     by (auto simp: replicate_add)

  3545   then show ?thesis by blast

  3546 qed

  3547

  3548

  3549 subsubsection{*@{text rotate1} and @{text rotate}*}

  3550

  3551 lemma rotate_simps[simp]: "rotate1 [] = [] \<and> rotate1 (x#xs) = xs @ [x]"

  3552 by(simp add:rotate1_def)

  3553

  3554 lemma rotate0[simp]: "rotate 0 = id"

  3555 by(simp add:rotate_def)

  3556

  3557 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"

  3558 by(simp add:rotate_def)

  3559

  3560 lemma rotate_add:

  3561   "rotate (m+n) = rotate m o rotate n"

  3562 by(simp add:rotate_def funpow_add)

  3563

  3564 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"

  3565 by(simp add:rotate_add)

  3566

  3567 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"

  3568 by(simp add:rotate_def funpow_swap1)

  3569

  3570 lemma rotate1_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate1 xs = xs"

  3571 by(cases xs) simp_all

  3572

  3573 lemma rotate_length01[simp]: "length xs <= 1 \<Longrightarrow> rotate n xs = xs"

  3574 apply(induct n)

  3575  apply simp

  3576 apply (simp add:rotate_def)

  3577 done

  3578

  3579 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"

  3580 by(simp add:rotate1_def split:list.split)

  3581

  3582 lemma rotate_drop_take:

  3583   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"

  3584 apply(induct n)

  3585  apply simp

  3586 apply(simp add:rotate_def)

  3587 apply(cases "xs = []")

  3588  apply (simp)

  3589 apply(case_tac "n mod length xs = 0")

  3590  apply(simp add:mod_Suc)

  3591  apply(simp add: rotate1_hd_tl drop_Suc take_Suc)

  3592 apply(simp add:mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]

  3593                 take_hd_drop linorder_not_le)

  3594 done

  3595

  3596 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"

  3597 by(simp add:rotate_drop_take)

  3598

  3599 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"

  3600 by(simp add:rotate_drop_take)

  3601

  3602 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"

  3603 by(simp add:rotate1_def split:list.split)

  3604

  3605 lemma length_rotate[simp]: "length(rotate n xs) = length xs"

  3606 by (induct n arbitrary: xs) (simp_all add:rotate_def)

  3607

  3608 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"

  3609 by(simp add:rotate1_def split:list.split) blast

  3610

  3611 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"

  3612 by (induct n) (simp_all add:rotate_def)

  3613

  3614 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"

  3615 by(simp add:rotate_drop_take take_map drop_map)

  3616

  3617 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"

  3618 by (cases xs) (auto simp add:rotate1_def)

  3619

  3620 lemma set_rotate[simp]: "set(rotate n xs) = set xs"

  3621 by (induct n) (simp_all add:rotate_def)

  3622

  3623 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"

  3624 by(simp add:rotate1_def split:list.split)

  3625

  3626 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"

  3627 by (induct n) (simp_all add:rotate_def)

  3628

  3629 lemma rotate_rev:

  3630   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"

  3631 apply(simp add:rotate_drop_take rev_drop rev_take)

  3632 apply(cases "length xs = 0")

  3633  apply simp

  3634 apply(cases "n mod length xs = 0")

  3635  apply simp

  3636 apply(simp add:rotate_drop_take rev_drop rev_take)

  3637 done

  3638

  3639 lemma hd_rotate_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd(rotate n xs) = xs!(n mod length xs)"

  3640 apply(simp add:rotate_drop_take hd_append hd_drop_conv_nth hd_conv_nth)

  3641 apply(subgoal_tac "length xs \<noteq> 0")

  3642  prefer 2 apply simp

  3643 using mod_less_divisor[of "length xs" n] by arith

  3644

  3645

  3646 subsubsection {* @{text sublist} --- a generalization of @{text nth} to sets *}

  3647

  3648 lemma sublist_empty [simp]: "sublist xs {} = []"

  3649 by (auto simp add: sublist_def)

  3650

  3651 lemma sublist_nil [simp]: "sublist [] A = []"

  3652 by (auto simp add: sublist_def)

  3653

  3654 lemma length_sublist:

  3655   "length(sublist xs I) = card{i. i < length xs \<and> i : I}"

  3656 by(simp add: sublist_def length_filter_conv_card cong:conj_cong)

  3657

  3658 lemma sublist_shift_lemma_Suc:

  3659   "map fst (filter (%p. P(Suc(snd p))) (zip xs is)) =

  3660    map fst (filter (%p. P(snd p)) (zip xs (map Suc is)))"

  3661 apply(induct xs arbitrary: "is")

  3662  apply simp

  3663 apply (case_tac "is")

  3664  apply simp

  3665 apply simp

  3666 done

  3667

  3668 lemma sublist_shift_lemma:

  3669      "map fst [p<-zip xs [i..<i + length xs] . snd p : A] =

  3670       map fst [p<-zip xs [0..<length xs] . snd p + i : A]"

  3671 by (induct xs rule: rev_induct) (simp_all add: add_commute)

  3672

  3673 lemma sublist_append:

  3674      "sublist (l @ l') A = sublist l A @ sublist l' {j. j + length l : A}"

  3675 apply (unfold sublist_def)

  3676 apply (induct l' rule: rev_induct, simp)

  3677 apply (simp add: upt_add_eq_append[of 0] sublist_shift_lemma)

  3678 apply (simp add: add_commute)

  3679 done

  3680

  3681 lemma sublist_Cons:

  3682 "sublist (x # l) A = (if 0:A then [x] else []) @ sublist l {j. Suc j : A}"

  3683 apply (induct l rule: rev_induct)

  3684  apply (simp add: sublist_def)

  3685 apply (simp del: append_Cons add: append_Cons[symmetric] sublist_append)

  3686 done

  3687

  3688 lemma set_sublist: "set(sublist xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"

  3689 apply(induct xs arbitrary: I)

  3690 apply(auto simp: sublist_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)

  3691 done

  3692

  3693 lemma set_sublist_subset: "set(sublist xs I) \<subseteq> set xs"

  3694 by(auto simp add:set_sublist)

  3695

  3696 lemma notin_set_sublistI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(sublist xs I)"

  3697 by(auto simp add:set_sublist)

  3698

  3699 lemma in_set_sublistD: "x \<in> set(sublist xs I) \<Longrightarrow> x \<in> set xs"

  3700 by(auto simp add:set_sublist)

  3701

  3702 lemma sublist_singleton [simp]: "sublist [x] A = (if 0 : A then [x] else [])"

  3703 by (simp add: sublist_Cons)

  3704

  3705

  3706 lemma distinct_sublistI[simp]: "distinct xs \<Longrightarrow> distinct(sublist xs I)"

  3707 apply(induct xs arbitrary: I)

  3708  apply simp

  3709 apply(auto simp add:sublist_Cons)

  3710 done

  3711

  3712

  3713 lemma sublist_upt_eq_take [simp]: "sublist l {..<n} = take n l"

  3714 apply (induct l rule: rev_induct, simp)

  3715 apply (simp split: nat_diff_split add: sublist_append)

  3716 done

  3717

  3718 lemma filter_in_sublist:

  3719  "distinct xs \<Longrightarrow> filter (%x. x \<in> set(sublist xs s)) xs = sublist xs s"

  3720 proof (induct xs arbitrary: s)

  3721   case Nil thus ?case by simp

  3722 next

  3723   case (Cons a xs)

  3724   moreover hence "!x. x: set xs \<longrightarrow> x \<noteq> a" by auto

  3725   ultimately show ?case by(simp add: sublist_Cons cong:filter_cong)

  3726 qed

  3727

  3728

  3729 subsubsection {* @{const splice} *}

  3730

  3731 lemma splice_Nil2 [simp, code]: "splice xs [] = xs"

  3732 by (cases xs) simp_all

  3733

  3734 declare splice.simps(1,3)[code]

  3735 declare splice.simps(2)[simp del]

  3736

  3737 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"

  3738 by (induct xs ys rule: splice.induct) auto

  3739

  3740

  3741 subsubsection {* Transpose *}

  3742

  3743 function transpose where

  3744 "transpose []             = []" |

  3745 "transpose ([]     # xss) = transpose xss" |

  3746 "transpose ((x#xs) # xss) =

  3747   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"

  3748 by pat_completeness auto

  3749

  3750 lemma transpose_aux_filter_head:

  3751   "concat (map (list_case [] (\<lambda>h t. [h])) xss) =

  3752   map (\<lambda>xs. hd xs) [ys\<leftarrow>xss . ys \<noteq> []]"

  3753   by (induct xss) (auto split: list.split)

  3754

  3755 lemma transpose_aux_filter_tail:

  3756   "concat (map (list_case [] (\<lambda>h t. [t])) xss) =

  3757   map (\<lambda>xs. tl xs) [ys\<leftarrow>xss . ys \<noteq> []]"

  3758   by (induct xss) (auto split: list.split)

  3759

  3760 lemma transpose_aux_max:

  3761   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =

  3762   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) [ys\<leftarrow>xss . ys\<noteq>[]] 0))"

  3763   (is "max _ ?foldB = Suc (max _ ?foldA)")

  3764 proof (cases "[ys\<leftarrow>xss . ys\<noteq>[]] = []")

  3765   case True

  3766   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"

  3767   proof (induct xss)

  3768     case (Cons x xs)

  3769     moreover hence "x = []" by (cases x) auto

  3770     ultimately show ?case by auto

  3771   qed simp

  3772   thus ?thesis using True by simp

  3773 next

  3774   case False

  3775

  3776   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0 - 1"

  3777     by (induct xss) auto

  3778   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) [ys\<leftarrow>xss . ys \<noteq> []] 0"

  3779     by (induct xss) auto

  3780

  3781   have "0 < ?foldB"

  3782   proof -

  3783     from False

  3784     obtain z zs where zs: "[ys\<leftarrow>xss . ys \<noteq> []] = z#zs" by (auto simp: neq_Nil_conv)

  3785     hence "z \<in> set ([ys\<leftarrow>xss . ys \<noteq> []])" by auto

  3786     hence "z \<noteq> []" by auto

  3787     thus ?thesis

  3788       unfolding foldB zs

  3789       by (auto simp: max_def intro: less_le_trans)

  3790   qed

  3791   thus ?thesis

  3792     unfolding foldA foldB max_Suc_Suc[symmetric]

  3793     by simp

  3794 qed

  3795

  3796 termination transpose

  3797   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")

  3798      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)

  3799

  3800 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"

  3801   by (induct rule: transpose.induct) simp_all

  3802

  3803 lemma length_transpose:

  3804   fixes xs :: "'a list list"

  3805   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"

  3806   by (induct rule: transpose.induct)

  3807     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max

  3808                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)

  3809

  3810 lemma nth_transpose:

  3811   fixes xs :: "'a list list"

  3812   assumes "i < length (transpose xs)"

  3813   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) [ys \<leftarrow> xs. i < length ys]"

  3814 using assms proof (induct arbitrary: i rule: transpose.induct)

  3815   case (3 x xs xss)

  3816   def XS == "(x # xs) # xss"

  3817   hence [simp]: "XS \<noteq> []" by auto

  3818   thus ?case

  3819   proof (cases i)

  3820     case 0

  3821     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)

  3822   next

  3823     case (Suc j)

  3824     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp

  3825     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp

  3826     { fix x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"

  3827       by (cases x) simp_all

  3828     } note *** = this

  3829

  3830     have j_less: "j < length (transpose (xs # concat (map (list_case [] (\<lambda>h t. [t])) xss)))"

  3831       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)

  3832

  3833     show ?thesis

  3834       unfolding transpose.simps i = Suc j nth_Cons_Suc "3.hyps"[OF j_less]

  3835       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])

  3836       apply (rule_tac y=x in list.exhaust)

  3837       by auto

  3838   qed

  3839 qed simp_all

  3840

  3841 lemma transpose_map_map:

  3842   "transpose (map (map f) xs) = map (map f) (transpose xs)"

  3843 proof (rule nth_equalityI, safe)

  3844   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"

  3845     by (simp add: length_transpose foldr_map comp_def)

  3846   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp

  3847

  3848   fix i assume "i < length (transpose (map (map f) xs))"

  3849   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"

  3850     by (simp add: nth_transpose filter_map comp_def)

  3851 qed

  3852

  3853

  3854 subsubsection {* (In)finiteness *}

  3855

  3856 lemma finite_maxlen:

  3857   "finite (M::'a list set) ==> EX n. ALL s:M. size s < n"

  3858 proof (induct rule: finite.induct)

  3859   case emptyI show ?case by simp

  3860 next

  3861   case (insertI M xs)

  3862   then obtain n where "\<forall>s\<in>M. length s < n" by blast

  3863   hence "ALL s:insert xs M. size s < max n (size xs) + 1" by auto

  3864   thus ?case ..

  3865 qed

  3866

  3867 lemma lists_length_Suc_eq:

  3868   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =

  3869     (\<lambda>(xs, n). n#xs)  ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"

  3870   by (auto simp: length_Suc_conv)

  3871

  3872 lemma

  3873   assumes "finite A"

  3874   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"

  3875   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"

  3876   using finite A

  3877   by (induct n)

  3878      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)

  3879

  3880 lemma finite_lists_length_le:

  3881   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"

  3882  (is "finite ?S")

  3883 proof-

  3884   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto

  3885   thus ?thesis by (auto intro: finite_lists_length_eq[OF finite A])

  3886 qed

  3887

  3888 lemma card_lists_length_le:

  3889   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"

  3890 proof -

  3891   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"

  3892     using finite A

  3893     by (subst card_UN_disjoint)

  3894        (auto simp add: card_lists_length_eq finite_lists_length_eq)

  3895   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}"

  3896     by auto

  3897   finally show ?thesis by simp

  3898 qed

  3899

  3900 lemma card_lists_distinct_length_eq:

  3901   assumes "k < card A"

  3902   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"

  3903 using assms

  3904 proof (induct k)

  3905   case 0

  3906   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto

  3907   then show ?case by simp

  3908 next

  3909   case (Suc k)

  3910   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"

  3911   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto

  3912

  3913   from Suc have "k < card A" by simp

  3914   moreover have "finite A" using assms by (simp add: card_ge_0_finite)

  3915   moreover have "finite {xs. ?k_list k xs}"

  3916     using finite_lists_length_eq[OF finite A, of k]

  3917     by - (rule finite_subset, auto)

  3918   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"

  3919     by auto

  3920   moreover have "\<And>i. i \<in>Collect (?k_list k) \<Longrightarrow> card (A - set i) = card A - k"

  3921     by (simp add: card_Diff_subset distinct_card)

  3922   moreover have "{xs. ?k_list (Suc k) xs} =

  3923       (\<lambda>(xs, n). n#xs)  \<Union>(\<lambda>xs. {xs} \<times> (A - set xs))  {xs. ?k_list k xs}"

  3924     by (auto simp: length_Suc_conv)

  3925   moreover

  3926   have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp

  3927   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"

  3928     by (subst setprod_insert[symmetric]) (simp add: atLeastAtMost_insertL)+

  3929   ultimately show ?case

  3930     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)

  3931 qed

  3932

  3933 lemma infinite_UNIV_listI: "~ finite(UNIV::'a list set)"

  3934 apply(rule notI)

  3935 apply(drule finite_maxlen)

  3936 apply (metis UNIV_I length_replicate less_not_refl)

  3937 done

  3938

  3939

  3940 subsection {* Sorting *}

  3941

  3942 text{* Currently it is not shown that @{const sort} returns a

  3943 permutation of its input because the nicest proof is via multisets,

  3944 which are not yet available. Alternatively one could define a function

  3945 that counts the number of occurrences of an element in a list and use

  3946 that instead of multisets to state the correctness property. *}

  3947

  3948 context linorder

  3949 begin

  3950

  3951 lemma length_insort [simp]:

  3952   "length (insort_key f x xs) = Suc (length xs)"

  3953   by (induct xs) simp_all

  3954

  3955 lemma insort_key_left_comm:

  3956   assumes "f x \<noteq> f y"

  3957   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"

  3958   by (induct xs) (auto simp add: assms dest: antisym)

  3959

  3960 lemma insort_left_comm:

  3961   "insort x (insort y xs) = insort y (insort x xs)"

  3962   by (cases "x = y") (auto intro: insort_key_left_comm)

  3963

  3964 lemma comp_fun_commute_insort:

  3965   "comp_fun_commute insort"

  3966 proof

  3967 qed (simp add: insort_left_comm fun_eq_iff)

  3968

  3969 lemma sort_key_simps [simp]:

  3970   "sort_key f [] = []"

  3971   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"

  3972   by (simp_all add: sort_key_def)

  3973

  3974 lemma (in linorder) sort_key_conv_fold:

  3975   assumes "inj_on f (set xs)"

  3976   shows "sort_key f xs = fold (insort_key f) xs []"

  3977 proof -

  3978   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"

  3979   proof (rule fold_rev, rule ext)

  3980     fix zs

  3981     fix x y

  3982     assume "x \<in> set xs" "y \<in> set xs"

  3983     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)

  3984     have **: "x = y \<longleftrightarrow> y = x" by auto

  3985     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"

  3986       by (induct zs) (auto intro: * simp add: **)

  3987   qed

  3988   then show ?thesis by (simp add: sort_key_def foldr_def)

  3989 qed

  3990

  3991 lemma (in linorder) sort_conv_fold:

  3992   "sort xs = fold insort xs []"

  3993   by (rule sort_key_conv_fold) simp

  3994

  3995 lemma length_sort[simp]: "length (sort_key f xs) = length xs"

  3996 by (induct xs, auto)

  3997

  3998 lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"

  3999 apply(induct xs arbitrary: x) apply simp

  4000 by simp (blast intro: order_trans)

  4001

  4002 lemma sorted_tl:

  4003   "sorted xs \<Longrightarrow> sorted (tl xs)"

  4004   by (cases xs) (simp_all add: sorted_Cons)

  4005

  4006 lemma sorted_append:

  4007   "sorted (xs@ys) = (sorted xs & sorted ys & (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"

  4008 by (induct xs) (auto simp add:sorted_Cons)

  4009

  4010 lemma sorted_nth_mono:

  4011   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"

  4012 by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)

  4013

  4014 lemma sorted_rev_nth_mono:

  4015   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"

  4016 using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]

  4017       rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]

  4018 by auto

  4019

  4020 lemma sorted_nth_monoI:

  4021   "(\<And> i j. \<lbrakk> i \<le> j ; j < length xs \<rbrakk> \<Longrightarrow> xs ! i \<le> xs ! j) \<Longrightarrow> sorted xs"

  4022 proof (induct xs)

  4023   case (Cons x xs)

  4024   have "sorted xs"

  4025   proof (rule Cons.hyps)

  4026     fix i j assume "i \<le> j" and "j < length xs"

  4027     with Cons.prems[of "Suc i" "Suc j"]

  4028     show "xs ! i \<le> xs ! j" by auto

  4029   qed

  4030   moreover

  4031   {

  4032     fix y assume "y \<in> set xs"

  4033     then obtain j where "j < length xs" and "xs ! j = y"

  4034       unfolding in_set_conv_nth by blast

  4035     with Cons.prems[of 0 "Suc j"]

  4036     have "x \<le> y"

  4037       by auto

  4038   }

  4039   ultimately

  4040   show ?case

  4041     unfolding sorted_Cons by auto

  4042 qed simp

  4043

  4044 lemma sorted_equals_nth_mono:

  4045   "sorted xs = (\<forall>j < length xs. \<forall>i \<le> j. xs ! i \<le> xs ! j)"

  4046 by (auto intro: sorted_nth_monoI sorted_nth_mono)

  4047

  4048 lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"

  4049 by (induct xs) auto

  4050

  4051 lemma set_sort[simp]: "set(sort_key f xs) = set xs"

  4052 by (induct xs) (simp_all add:set_insort)

  4053

  4054 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"

  4055 by(induct xs)(auto simp:set_insort)

  4056

  4057 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"

  4058   by (induct xs) (simp_all add: distinct_insort)

  4059

  4060 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"

  4061   by (induct xs) (auto simp:sorted_Cons set_insort)

  4062

  4063 lemma sorted_insort: "sorted (insort x xs) = sorted xs"

  4064   using sorted_insort_key [where f="\<lambda>x. x"] by simp

  4065

  4066 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"

  4067   by (induct xs) (auto simp:sorted_insort_key)

  4068

  4069 theorem sorted_sort [simp]: "sorted (sort xs)"

  4070   using sorted_sort_key [where f="\<lambda>x. x"] by simp

  4071

  4072 lemma sorted_butlast:

  4073   assumes "xs \<noteq> []" and "sorted xs"

  4074   shows "sorted (butlast xs)"

  4075 proof -

  4076   from xs \<noteq> [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto

  4077   with sorted xs show ?thesis by (simp add: sorted_append)

  4078 qed

  4079

  4080 lemma insort_not_Nil [simp]:

  4081   "insort_key f a xs \<noteq> []"

  4082   by (induct xs) simp_all

  4083

  4084 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"

  4085 by (cases xs) auto

  4086

  4087 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"

  4088   by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)

  4089

  4090 lemma sorted_map_remove1:

  4091   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"

  4092   by (induct xs) (auto simp add: sorted_Cons)

  4093

  4094 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"

  4095   using sorted_map_remove1 [of "\<lambda>x. x"] by simp

  4096

  4097 lemma insort_key_remove1:

  4098   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"

  4099   shows "insort_key f a (remove1 a xs) = xs"

  4100 using assms proof (induct xs)

  4101   case (Cons x xs)

  4102   then show ?case

  4103   proof (cases "x = a")

  4104     case False

  4105     then have "f x \<noteq> f a" using Cons.prems by auto

  4106     then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons)

  4107     with f x \<noteq> f a show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons)

  4108   qed (auto simp: sorted_Cons insort_is_Cons)

  4109 qed simp

  4110

  4111 lemma insort_remove1:

  4112   assumes "a \<in> set xs" and "sorted xs"

  4113   shows "insort a (remove1 a xs) = xs"

  4114 proof (rule insort_key_remove1)

  4115   from a \<in> set xs show "a \<in> set xs" .

  4116   from sorted xs show "sorted (map (\<lambda>x. x) xs)" by simp

  4117   from a \<in> set xs have "a \<in> set (filter (op = a) xs)" by auto

  4118   then have "set (filter (op = a) xs) \<noteq> {}" by auto

  4119   then have "filter (op = a) xs \<noteq> []" by (auto simp only: set_empty)

  4120   then have "length (filter (op = a) xs) > 0" by simp

  4121   then obtain n where n: "Suc n = length (filter (op = a) xs)"

  4122     by (cases "length (filter (op = a) xs)") simp_all

  4123   moreover have "replicate (Suc n) a = a # replicate n a"

  4124     by simp

  4125   ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)

  4126 qed

  4127

  4128 lemma sorted_remdups[simp]:

  4129   "sorted l \<Longrightarrow> sorted (remdups l)"

  4130 by (induct l) (auto simp: sorted_Cons)

  4131

  4132 lemma sorted_distinct_set_unique:

  4133 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"

  4134 shows "xs = ys"

  4135 proof -

  4136   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)

  4137   from assms show ?thesis

  4138   proof(induct rule:list_induct2[OF 1])

  4139     case 1 show ?case by simp

  4140   next

  4141     case 2 thus ?case by (simp add:sorted_Cons)

  4142        (metis Diff_insert_absorb antisym insertE insert_iff)

  4143   qed

  4144 qed

  4145

  4146 lemma map_sorted_distinct_set_unique:

  4147   assumes "inj_on f (set xs \<union> set ys)"

  4148   assumes "sorted (map f xs)" "distinct (map f xs)"

  4149     "sorted (map f ys)" "distinct (map f ys)"

  4150   assumes "set xs = set ys"

  4151   shows "xs = ys"

  4152 proof -

  4153   from assms have "map f xs = map f ys"

  4154     by (simp add: sorted_distinct_set_unique)

  4155   moreover with inj_on f (set xs \<union> set ys) show "xs = ys"

  4156     by (blast intro: map_inj_on)

  4157 qed

  4158

  4159 lemma finite_sorted_distinct_unique:

  4160 shows "finite A \<Longrightarrow> EX! xs. set xs = A & sorted xs & distinct xs"

  4161 apply(drule finite_distinct_list)

  4162 apply clarify

  4163 apply(rule_tac a="sort xs" in ex1I)

  4164 apply (auto simp: sorted_distinct_set_unique)

  4165 done

  4166

  4167 lemma

  4168   assumes "sorted xs"

  4169   shows sorted_take: "sorted (take n xs)"

  4170   and sorted_drop: "sorted (drop n xs)"

  4171 proof -

  4172   from assms have "sorted (take n xs @ drop n xs)" by simp

  4173   then show "sorted (take n xs)" and "sorted (drop n xs)"

  4174     unfolding sorted_append by simp_all

  4175 qed

  4176

  4177 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"

  4178   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)

  4179

  4180 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"

  4181   by (subst takeWhile_eq_take) (auto dest: sorted_take)

  4182

  4183 lemma sorted_filter:

  4184   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"

  4185   by (induct xs) (simp_all add: sorted_Cons)

  4186

  4187 lemma foldr_max_sorted:

  4188   assumes "sorted (rev xs)"

  4189   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"

  4190 using assms proof (induct xs)

  4191   case (Cons x xs)

  4192   moreover hence "sorted (rev xs)" using sorted_append by auto

  4193   ultimately show ?case

  4194     by (cases xs, auto simp add: sorted_append max_def)

  4195 qed simp

  4196

  4197 lemma filter_equals_takeWhile_sorted_rev:

  4198   assumes sorted: "sorted (rev (map f xs))"

  4199   shows "[x \<leftarrow> xs. t < f x] = takeWhile (\<lambda> x. t < f x) xs"

  4200     (is "filter ?P xs = ?tW")

  4201 proof (rule takeWhile_eq_filter[symmetric])

  4202   let "?dW" = "dropWhile ?P xs"

  4203   fix x assume "x \<in> set ?dW"

  4204   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"

  4205     unfolding in_set_conv_nth by auto

  4206   hence "length ?tW + i < length (?tW @ ?dW)"

  4207     unfolding length_append by simp

  4208   hence i': "length (map f ?tW) + i < length (map f xs)" by simp

  4209   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>

  4210         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"

  4211     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]

  4212     unfolding map_append[symmetric] by simp

  4213   hence "f x \<le> f (?dW ! 0)"

  4214     unfolding nth_append_length_plus nth_i

  4215     using i preorder_class.le_less_trans[OF le0 i] by simp

  4216   also have "... \<le> t"

  4217     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]

  4218     using hd_conv_nth[of "?dW"] by simp

  4219   finally show "\<not> t < f x" by simp

  4220 qed

  4221

  4222 lemma insort_insert_key_triv:

  4223   "f x \<in> f  set xs \<Longrightarrow> insort_insert_key f x xs = xs"

  4224   by (simp add: insort_insert_key_def)

  4225

  4226 lemma insort_insert_triv:

  4227   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"

  4228   using insort_insert_key_triv [of "\<lambda>x. x"] by simp

  4229

  4230 lemma insort_insert_insort_key:

  4231   "f x \<notin> f  set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"

  4232   by (simp add: insort_insert_key_def)

  4233

  4234 lemma insort_insert_insort:

  4235   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"

  4236   using insort_insert_insort_key [of "\<lambda>x. x"] by simp

  4237

  4238 lemma set_insort_insert:

  4239   "set (insort_insert x xs) = insert x (set xs)"

  4240   by (auto simp add: insort_insert_key_def set_insort)

  4241

  4242 lemma distinct_insort_insert:

  4243   assumes "distinct xs"

  4244   shows "distinct (insort_insert_key f x xs)"

  4245   using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)

  4246

  4247 lemma sorted_insort_insert_key:

  4248   assumes "sorted (map f xs)"

  4249   shows "sorted (map f (insort_insert_key f x xs))"

  4250   using assms by (simp add: insort_insert_key_def sorted_insort_key)

  4251

  4252 lemma sorted_insort_insert:

  4253   assumes "sorted xs"

  4254   shows "sorted (insort_insert x xs)"

  4255   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp

  4256

  4257 lemma filter_insort_triv:

  4258   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"

  4259   by (induct xs) simp_all

  4260

  4261 lemma filter_insort:

  4262   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"

  4263   using assms by (induct xs)

  4264     (auto simp add: sorted_Cons, subst insort_is_Cons, auto)

  4265

  4266 lemma filter_sort:

  4267   "filter P (sort_key f xs) = sort_key f (filter P xs)"

  4268   by (induct xs) (simp_all add: filter_insort_triv filter_insort)

  4269

  4270 lemma sorted_map_same:

  4271   "sorted (map f [x\<leftarrow>xs. f x = g xs])"

  4272 proof (induct xs arbitrary: g)

  4273   case Nil then show ?case by simp

  4274 next

  4275   case (Cons x xs)

  4276   then have "sorted (map f [y\<leftarrow>xs . f y = (\<lambda>xs. f x) xs])" .

  4277   moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g \<circ> Cons x) xs])" .

  4278   ultimately show ?case by (simp_all add: sorted_Cons)

  4279 qed

  4280

  4281 lemma sorted_same:

  4282   "sorted [x\<leftarrow>xs. x = g xs]"

  4283   using sorted_map_same [of "\<lambda>x. x"] by simp

  4284

  4285 lemma remove1_insort [simp]:

  4286   "remove1 x (insort x xs) = xs"

  4287   by (induct xs) simp_all

  4288

  4289 end

  4290

  4291 lemma sorted_upt[simp]: "sorted[i..<j]"

  4292 by (induct j) (simp_all add:sorted_append)

  4293

  4294 lemma sorted_upto[simp]: "sorted[i..j]"

  4295 apply(induct i j rule:upto.induct)

  4296 apply(subst upto.simps)

  4297 apply(simp add:sorted_Cons)

  4298 done

  4299

  4300

  4301 subsubsection {* @{const transpose} on sorted lists *}

  4302

  4303 lemma sorted_transpose[simp]:

  4304   shows "sorted (rev (map length (transpose xs)))"

  4305   by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose

  4306     length_filter_conv_card intro: card_mono)

  4307

  4308 lemma transpose_max_length:

  4309   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x \<noteq> []]"

  4310   (is "?L = ?R")

  4311 proof (cases "transpose xs = []")

  4312   case False

  4313   have "?L = foldr max (map length (transpose xs)) 0"

  4314     by (simp add: foldr_map comp_def)

  4315   also have "... = length (transpose xs ! 0)"

  4316     using False sorted_transpose by (simp add: foldr_max_sorted)

  4317   finally show ?thesis

  4318     using False by (simp add: nth_transpose)

  4319 next

  4320   case True

  4321   hence "[x \<leftarrow> xs. x \<noteq> []] = []"

  4322     by (auto intro!: filter_False simp: transpose_empty)

  4323   thus ?thesis by (simp add: transpose_empty True)

  4324 qed

  4325

  4326 lemma length_transpose_sorted:

  4327   fixes xs :: "'a list list"

  4328   assumes sorted: "sorted (rev (map length xs))"

  4329   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"

  4330 proof (cases "xs = []")

  4331   case False

  4332   thus ?thesis

  4333     using foldr_max_sorted[OF sorted] False

  4334     unfolding length_transpose foldr_map comp_def

  4335     by simp

  4336 qed simp

  4337

  4338 lemma nth_nth_transpose_sorted[simp]:

  4339   fixes xs :: "'a list list"

  4340   assumes sorted: "sorted (rev (map length xs))"

  4341   and i: "i < length (transpose xs)"

  4342   and j: "j < length [ys \<leftarrow> xs. i < length ys]"

  4343   shows "transpose xs ! i ! j = xs ! j  ! i"

  4344   using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]

  4345     nth_transpose[OF i] nth_map[OF j]

  4346   by (simp add: takeWhile_nth)

  4347

  4348 lemma transpose_column_length:

  4349   fixes xs :: "'a list list"

  4350   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"

  4351   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"

  4352 proof -

  4353   have "xs \<noteq> []" using i < length xs by auto

  4354   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]

  4355   { fix j assume "j \<le> i"

  4356     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this i < length xs]

  4357   } note sortedE = this[consumes 1]

  4358

  4359   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}

  4360     = {..< length (xs ! i)}"

  4361   proof safe

  4362     fix j

  4363     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"

  4364     with this(2) nth_transpose[OF this(1)]

  4365     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp

  4366     from nth_mem[OF this] takeWhile_nth[OF this]

  4367     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)

  4368   next

  4369     fix j assume "j < length (xs ! i)"

  4370     thus "j < length (transpose xs)"

  4371       using foldr_max_sorted[OF sorted] xs \<noteq> [] sortedE[OF le0]

  4372       by (auto simp: length_transpose comp_def foldr_map)

  4373

  4374     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"

  4375       using i < length xs j < length (xs ! i) less_Suc_eq_le

  4376       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)

  4377     with nth_transpose[OF j < length (transpose xs)]

  4378     show "i < length (transpose xs ! j)" by simp

  4379   qed

  4380   thus ?thesis by (simp add: length_filter_conv_card)

  4381 qed

  4382

  4383 lemma transpose_column:

  4384   fixes xs :: "'a list list"

  4385   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"

  4386   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))

  4387     = xs ! i" (is "?R = _")

  4388 proof (rule nth_equalityI, safe)

  4389   show length: "length ?R = length (xs ! i)"

  4390     using transpose_column_length[OF assms] by simp

  4391

  4392   fix j assume j: "j < length ?R"

  4393   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]

  4394   from j have j_less: "j < length (xs ! i)" using length by simp

  4395   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"

  4396   proof (rule length_takeWhile_less_P_nth)

  4397     show "Suc i \<le> length xs" using i < length xs by simp

  4398     fix k assume "k < Suc i"

  4399     hence "k \<le> i" by auto

  4400     with sorted_rev_nth_mono[OF sorted this] i < length xs

  4401     have "length (xs ! i) \<le> length (xs ! k)" by simp

  4402     thus "Suc j \<le> length (xs ! k)" using j_less by simp

  4403   qed

  4404   have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]"

  4405     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]

  4406     using i_less_tW by (simp_all add: Suc_le_eq)

  4407   from j show "?R ! j = xs ! i ! j"

  4408     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]

  4409     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])

  4410 qed

  4411

  4412 lemma transpose_transpose:

  4413   fixes xs :: "'a list list"

  4414   assumes sorted: "sorted (rev (map length xs))"

  4415   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")

  4416 proof -

  4417   have len: "length ?L = length ?R"

  4418     unfolding length_transpose transpose_max_length

  4419     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]

  4420     by simp

  4421

  4422   { fix i assume "i < length ?R"

  4423     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]

  4424     have "i < length xs" by simp

  4425   } note * = this

  4426   show ?thesis

  4427     by (rule nth_equalityI)

  4428        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)

  4429 qed

  4430

  4431 theorem transpose_rectangle:

  4432   assumes "xs = [] \<Longrightarrow> n = 0"

  4433   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"

  4434   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"

  4435     (is "?trans = ?map")

  4436 proof (rule nth_equalityI)

  4437   have "sorted (rev (map length xs))"

  4438     by (auto simp: rev_nth rect intro!: sorted_nth_monoI)

  4439   from foldr_max_sorted[OF this] assms

  4440   show len: "length ?trans = length ?map"

  4441     by (simp_all add: length_transpose foldr_map comp_def)

  4442   moreover

  4443   { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs"

  4444       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }

  4445   ultimately show "\<forall>i < length ?trans. ?trans ! i = ?map ! i"

  4446     by (auto simp: nth_transpose intro: nth_equalityI)

  4447 qed

  4448

  4449

  4450 subsubsection {* @{text sorted_list_of_set} *}

  4451

  4452 text{* This function maps (finite) linearly ordered sets to sorted

  4453 lists. Warning: in most cases it is not a good idea to convert from

  4454 sets to lists but one should convert in the other direction (via

  4455 @{const set}). *}

  4456

  4457 context linorder

  4458 begin

  4459

  4460 definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where

  4461   "sorted_list_of_set = Finite_Set.fold insort []"

  4462

  4463 lemma sorted_list_of_set_empty [simp]:

  4464   "sorted_list_of_set {} = []"

  4465   by (simp add: sorted_list_of_set_def)

  4466

  4467 lemma sorted_list_of_set_insert [simp]:

  4468   assumes "finite A"

  4469   shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"

  4470 proof -

  4471   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)

  4472   with assms show ?thesis by (simp add: sorted_list_of_set_def fold_insert_remove)

  4473 qed

  4474

  4475 lemma sorted_list_of_set [simp]:

  4476   "finite A \<Longrightarrow> set (sorted_list_of_set A) = A \<and> sorted (sorted_list_of_set A)

  4477     \<and> distinct (sorted_list_of_set A)"

  4478   by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)

  4479

  4480 lemma sorted_list_of_set_sort_remdups:

  4481   "sorted_list_of_set (set xs) = sort (remdups xs)"

  4482 proof -

  4483   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)

  4484   show ?thesis by (simp add: sorted_list_of_set_def sort_conv_fold fold_set_fold_remdups)

  4485 qed

  4486

  4487 lemma sorted_list_of_set_remove:

  4488   assumes "finite A"

  4489   shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"

  4490 proof (cases "x \<in> A")

  4491   case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp

  4492   with False show ?thesis by (simp add: remove1_idem)

  4493 next

  4494   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)

  4495   with assms show ?thesis by simp

  4496 qed

  4497

  4498 end

  4499

  4500 lemma sorted_list_of_set_range [simp]:

  4501   "sorted_list_of_set {m..<n} = [m..<n]"

  4502   by (rule sorted_distinct_set_unique) simp_all

  4503

  4504

  4505 subsubsection {* @{text lists}: the list-forming operator over sets *}

  4506

  4507 inductive_set

  4508   lists :: "'a set => 'a list set"

  4509   for A :: "'a set"

  4510 where

  4511     Nil [intro!, simp]: "[]: lists A"

  4512   | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"

  4513

  4514 inductive_cases listsE [elim!,no_atp]: "x#l : lists A"

  4515 inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"

  4516

  4517 lemma listsp_mono [mono]: "A \<le> B ==> listsp A \<le> listsp B"

  4518 by (rule predicate1I, erule listsp.induct, (blast dest: predicate1D)+)

  4519

  4520 lemmas lists_mono = listsp_mono [to_set pred_subset_eq]

  4521

  4522 lemma listsp_infI:

  4523   assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using l

  4524 by induct blast+

  4525

  4526 lemmas lists_IntI = listsp_infI [to_set]

  4527

  4528 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"

  4529 proof (rule mono_inf [where f=listsp, THEN order_antisym])

  4530   show "mono listsp" by (simp add: mono_def listsp_mono)

  4531   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI predicate1I)

  4532 qed

  4533

  4534 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]

  4535

  4536 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set pred_equals_eq]

  4537

  4538 lemma Cons_in_lists_iff[simp]: "x#xs : lists A \<longleftrightarrow> x:A \<and> xs : lists A"

  4539 by auto

  4540

  4541 lemma append_in_listsp_conv [iff]:

  4542      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"

  4543 by (induct xs) auto

  4544

  4545 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]

  4546

  4547 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"

  4548 -- {* eliminate @{text listsp} in favour of @{text set} *}

  4549 by (induct xs) auto

  4550

  4551 lemmas in_lists_conv_set = in_listsp_conv_set [to_set]

  4552

  4553 lemma in_listspD [dest!,no_atp]: "listsp A xs ==> \<forall>x\<in>set xs. A x"

  4554 by (rule in_listsp_conv_set [THEN iffD1])

  4555

  4556 lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]

  4557

  4558 lemma in_listspI [intro!,no_atp]: "\<forall>x\<in>set xs. A x ==> listsp A xs"

  4559 by (rule in_listsp_conv_set [THEN iffD2])

  4560

  4561 lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]

  4562

  4563 lemma lists_eq_set: "lists A = {xs. set xs <= A}"

  4564 by auto

  4565

  4566 lemma lists_empty [simp]: "lists {} = {[]}"

  4567 by auto

  4568

  4569 lemma lists_UNIV [simp]: "lists UNIV = UNIV"

  4570 by auto

  4571

  4572

  4573 subsubsection {* Inductive definition for membership *}

  4574

  4575 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"

  4576 where

  4577     elem:  "ListMem x (x # xs)"

  4578   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"

  4579

  4580 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"

  4581 apply (rule iffI)

  4582  apply (induct set: ListMem)

  4583   apply auto

  4584 apply (induct xs)

  4585  apply (auto intro: ListMem.intros)

  4586 done

  4587

  4588

  4589 subsubsection {* Lists as Cartesian products *}

  4590

  4591 text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from

  4592 @{term A} and tail drawn from @{term Xs}.*}

  4593

  4594 definition

  4595   set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where

  4596   "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"

  4597

  4598 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])A"

  4599 by (auto simp add: set_Cons_def)

  4600

  4601 text{*Yields the set of lists, all of the same length as the argument and

  4602 with elements drawn from the corresponding element of the argument.*}

  4603

  4604 primrec

  4605   listset :: "'a set list \<Rightarrow> 'a list set" where

  4606      "listset [] = {[]}"

  4607   |  "listset (A # As) = set_Cons A (listset As)"

  4608

  4609

  4610 subsection {* Relations on Lists *}

  4611

  4612 subsubsection {* Length Lexicographic Ordering *}

  4613

  4614 text{*These orderings preserve well-foundedness: shorter lists

  4615   precede longer lists. These ordering are not used in dictionaries.*}

  4616

  4617 primrec -- {*The lexicographic ordering for lists of the specified length*}

  4618   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where

  4619     "lexn r 0 = {}"

  4620   | "lexn r (Suc n) = (map_pair (%(x, xs). x#xs) (%(x, xs). x#xs)  (r <*lex*> lexn r n)) Int

  4621       {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"

  4622

  4623 definition

  4624   lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  4625   "lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}

  4626

  4627 definition

  4628   lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where

  4629   "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"

  4630         -- {*Compares lists by their length and then lexicographically*}

  4631

  4632 lemma wf_lexn: "wf r ==> wf (lexn r n)"

  4633 apply (induct n, simp, simp)

  4634 apply(rule wf_subset)

  4635  prefer 2 apply (rule Int_lower1)

  4636 apply(rule wf_map_pair_image)

  4637  prefer 2 apply (rule inj_onI, auto)

  4638 done

  4639

  4640 lemma lexn_length:

  4641   "(xs, ys) : lexn r n ==> length xs = n \<and> length ys = n"

  4642 by (induct n arbitrary: xs ys) auto

  4643

  4644 lemma wf_lex [intro!]: "wf r ==> wf (lex r)"

  4645 apply (unfold lex_def)

  4646 apply (rule wf_UN)

  4647 apply (blast intro: wf_lexn, clarify)

  4648 apply (rename_tac m n)

  4649 apply (subgoal_tac "m \<noteq> n")

  4650  prefer 2 apply blast

  4651 apply (blast dest: lexn_length not_sym)

  4652 done

  4653

  4654 lemma lexn_conv:

  4655   "lexn r n =

  4656     {(xs,ys). length xs = n \<and> length ys = n \<and>

  4657     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y):r)}"

  4658 apply (induct n, simp)

  4659 apply (simp add: image_Collect lex_prod_def, safe, blast)

  4660  apply (rule_tac x = "ab # xys" in exI, simp)

  4661 apply (case_tac xys, simp_all, blast)

  4662 done

  4663

  4664 lemma lex_conv:

  4665   "lex r =

  4666     {(xs,ys). length xs = length ys \<and>

  4667     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y):r)}"

  4668 by (force simp add: lex_def lexn_conv)

  4669

  4670 lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"

  4671 by (unfold lenlex_def) blast

  4672

  4673 lemma lenlex_conv:

  4674     "lenlex r = {(xs,ys). length xs < length ys |

  4675                  length xs = length ys \<and> (xs, ys) : lex r}"

  4676 by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)

  4677

  4678 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"

  4679 by (simp add: lex_conv)

  4680

  4681 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"

  4682 by (simp add:lex_conv)

  4683

  4684 lemma Cons_in_lex [simp]:

  4685     "((x # xs, y # ys) : lex r) =

  4686       ((x, y) : r \<and> length xs = length ys | x = y \<and> (xs, ys) : lex r)"

  4687 apply (simp add: lex_conv)

  4688 apply (rule iffI)

  4689  prefer 2 apply (blast intro: Cons_eq_appendI, clarify)

  4690 apply (case_tac xys, simp, simp)

  4691 apply blast

  4692 done

  4693

  4694

  4695 subsubsection {* Lexicographic Ordering *}

  4696

  4697 text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".

  4698     This ordering does \emph{not} preserve well-foundedness.

  4699      Author: N. Voelker, March 2005. *}

  4700

  4701 definition

  4702   lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  4703   "lexord r = {(x,y ). \<exists> a v. y = x @ a # v \<or>

  4704             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"

  4705

  4706 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"

  4707 by (unfold lexord_def, induct_tac y, auto)

  4708

  4709 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"

  4710 by (unfold lexord_def, induct_tac x, auto)

  4711

  4712 lemma lexord_cons_cons[simp]:

  4713      "((a # x, b # y) \<in> lexord r) = ((a,b)\<in> r | (a = b & (x,y)\<in> lexord r))"

  4714   apply (unfold lexord_def, safe, simp_all)

  4715   apply (case_tac u, simp, simp)

  4716   apply (case_tac u, simp, clarsimp, blast, blast, clarsimp)

  4717   apply (erule_tac x="b # u" in allE)

  4718   by force

  4719

  4720 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons

  4721

  4722 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"

  4723 by (induct_tac x, auto)

  4724

  4725 lemma lexord_append_left_rightI:

  4726      "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"

  4727 by (induct_tac u, auto)

  4728

  4729 lemma lexord_append_leftI: " (u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"

  4730 by (induct x, auto)

  4731

  4732 lemma lexord_append_leftD:

  4733      "\<lbrakk> (x @ u, x @ v) \<in> lexord r; (! a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"

  4734 by (erule rev_mp, induct_tac x, auto)

  4735

  4736 lemma lexord_take_index_conv:

  4737    "((x,y) : lexord r) =

  4738     ((length x < length y \<and> take (length x) y = x) \<or>

  4739      (\<exists>i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) \<in> r))"

  4740   apply (unfold lexord_def Let_def, clarsimp)

  4741   apply (rule_tac f = "(% a b. a \<or> b)" in arg_cong2)

  4742   apply auto

  4743   apply (rule_tac x="hd (drop (length x) y)" in exI)

  4744   apply (rule_tac x="tl (drop (length x) y)" in exI)

  4745   apply (erule subst, simp add: min_def)

  4746   apply (rule_tac x ="length u" in exI, simp)

  4747   apply (rule_tac x ="take i x" in exI)

  4748   apply (rule_tac x ="x ! i" in exI)

  4749   apply (rule_tac x ="y ! i" in exI, safe)

  4750   apply (rule_tac x="drop (Suc i) x" in exI)

  4751   apply (drule sym, simp add: drop_Suc_conv_tl)

  4752   apply (rule_tac x="drop (Suc i) y" in exI)

  4753   by (simp add: drop_Suc_conv_tl)

  4754

  4755 -- {* lexord is extension of partial ordering List.lex *}

  4756 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"

  4757   apply (rule_tac x = y in spec)

  4758   apply (induct_tac x, clarsimp)

  4759   by (clarify, case_tac x, simp, force)

  4760

  4761 lemma lexord_irreflexive: "ALL x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"

  4762 by (induct xs) auto

  4763

  4764 text{* By Ren\'e Thiemann: *}

  4765 lemma lexord_partial_trans:

  4766   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)

  4767    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"

  4768 proof (induct xs arbitrary: ys zs)

  4769   case Nil

  4770   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)

  4771 next

  4772   case (Cons x xs yys zzs)

  4773   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def

  4774     by (cases yys, auto)

  4775   note Cons = Cons[unfolded yys]

  4776   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto

  4777   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def

  4778     by (cases zzs, auto)

  4779   note Cons = Cons[unfolded zzs]

  4780   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto

  4781   {

  4782     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"

  4783     from Cons(1)[OF _ this] Cons(2)

  4784     have "(xs,zs) \<in> lexord r" by auto

  4785   } note ind1 = this

  4786   {

  4787     assume "(x,y) \<in> r" and "(y,z) \<in> r"

  4788     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto

  4789   } note ind2 = this

  4790   from one two ind1 ind2

  4791   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast

  4792   thus ?case unfolding zzs by auto

  4793 qed

  4794

  4795 lemma lexord_trans:

  4796     "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"

  4797 by(auto simp: trans_def intro:lexord_partial_trans)

  4798

  4799 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"

  4800 by (rule transI, drule lexord_trans, blast)

  4801

  4802 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"

  4803   apply (rule_tac x = y in spec)

  4804   apply (induct_tac x, rule allI)

  4805   apply (case_tac x, simp, simp)

  4806   apply (rule allI, case_tac x, simp, simp)

  4807   by blast

  4808

  4809

  4810 subsubsection {* Lexicographic combination of measure functions *}

  4811

  4812 text {* These are useful for termination proofs *}

  4813

  4814 definition

  4815   "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"

  4816

  4817 lemma wf_measures[simp]: "wf (measures fs)"

  4818 unfolding measures_def

  4819 by blast

  4820

  4821 lemma in_measures[simp]:

  4822   "(x, y) \<in> measures [] = False"

  4823   "(x, y) \<in> measures (f # fs)

  4824          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"

  4825 unfolding measures_def

  4826 by auto

  4827

  4828 lemma measures_less: "f x < f y ==> (x, y) \<in> measures (f#fs)"

  4829 by simp

  4830

  4831 lemma measures_lesseq: "f x <= f y ==> (x, y) \<in> measures fs ==> (x, y) \<in> measures (f#fs)"

  4832 by auto

  4833

  4834

  4835 subsubsection {* Lifting Relations to Lists: one element *}

  4836

  4837 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where

  4838 "listrel1 r = {(xs,ys).

  4839    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"

  4840

  4841 lemma listrel1I:

  4842   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>

  4843   (xs, ys) \<in> listrel1 r"

  4844 unfolding listrel1_def by auto

  4845

  4846 lemma listrel1E:

  4847   "\<lbrakk> (xs, ys) \<in> listrel1 r;

  4848      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P

  4849    \<rbrakk> \<Longrightarrow> P"

  4850 unfolding listrel1_def by auto

  4851

  4852 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"

  4853 unfolding listrel1_def by blast

  4854

  4855 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"

  4856 unfolding listrel1_def by blast

  4857

  4858 lemma Cons_listrel1_Cons [iff]:

  4859   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>

  4860    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"

  4861 by (simp add: listrel1_def Cons_eq_append_conv) (blast)

  4862

  4863 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"

  4864 by (metis Cons_listrel1_Cons)

  4865

  4866 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"

  4867 by (metis Cons_listrel1_Cons)

  4868

  4869 lemma append_listrel1I:

  4870   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r

  4871     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"

  4872 unfolding listrel1_def

  4873 by auto (blast intro: append_eq_appendI)+

  4874

  4875 lemma Cons_listrel1E1[elim!]:

  4876   assumes "(x # xs, ys) \<in> listrel1 r"

  4877     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"

  4878     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"

  4879   shows R

  4880 using assms by (cases ys) blast+

  4881

  4882 lemma Cons_listrel1E2[elim!]:

  4883   assumes "(xs, y # ys) \<in> listrel1 r"

  4884     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"

  4885     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"

  4886   shows R

  4887 using assms by (cases xs) blast+

  4888

  4889 lemma snoc_listrel1_snoc_iff:

  4890   "(xs @ [x], ys @ [y]) \<in> listrel1 r

  4891     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")

  4892 proof

  4893   assume ?L thus ?R

  4894     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)

  4895 next

  4896   assume ?R then show ?L unfolding listrel1_def by force

  4897 qed

  4898

  4899 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"

  4900 unfolding listrel1_def by auto

  4901

  4902 lemma listrel1_mono:

  4903   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"

  4904 unfolding listrel1_def by blast

  4905

  4906

  4907 lemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"

  4908 unfolding listrel1_def by blast

  4909

  4910 lemma in_listrel1_converse:

  4911   "(x,y) : listrel1 (r^-1) \<longleftrightarrow> (x,y) : (listrel1 r)^-1"

  4912 unfolding listrel1_def by blast

  4913

  4914 lemma listrel1_iff_update:

  4915   "(xs,ys) \<in> (listrel1 r)

  4916    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")

  4917 proof

  4918   assume "?L"

  4919   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"

  4920     unfolding listrel1_def by auto

  4921   then have "ys = xs[length u := y]" and "length u < length xs"

  4922     and "(xs ! length u, y) \<in> r" by auto

  4923   then show "?R" by auto

  4924 next

  4925   assume "?R"

  4926   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"

  4927     by auto

  4928   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"

  4929     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)

  4930   then show "?L" by (auto simp: listrel1_def)

  4931 qed

  4932

  4933

  4934 text{* Accessible part and wellfoundedness: *}

  4935

  4936 lemma Cons_acc_listrel1I [intro!]:

  4937   "x \<in> acc r \<Longrightarrow> xs \<in> acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> acc (listrel1 r)"

  4938 apply (induct arbitrary: xs set: acc)

  4939 apply (erule thin_rl)

  4940 apply (erule acc_induct)

  4941 apply (rule accI)

  4942 apply (blast)

  4943 done

  4944

  4945 lemma lists_accD: "xs \<in> lists (acc r) \<Longrightarrow> xs \<in> acc (listrel1 r)"

  4946 apply (induct set: lists)

  4947  apply (rule accI)

  4948  apply simp

  4949 apply (rule accI)

  4950 apply (fast dest: acc_downward)

  4951 done

  4952

  4953 lemma lists_accI: "xs \<in> acc (listrel1 r) \<Longrightarrow> xs \<in> lists (acc r)"

  4954 apply (induct set: acc)

  4955 apply clarify

  4956 apply (rule accI)

  4957 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)

  4958 done

  4959

  4960 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"

  4961 by(metis wf_acc_iff in_lists_conv_set lists_accI lists_accD Cons_in_lists_iff)

  4962

  4963

  4964 subsubsection {* Lifting Relations to Lists: all elements *}

  4965

  4966 inductive_set

  4967   listrel :: "('a * 'a)set => ('a list * 'a list)set"

  4968   for r :: "('a * 'a)set"

  4969 where

  4970     Nil:  "([],[]) \<in> listrel r"

  4971   | Cons: "[| (x,y) \<in> r; (xs,ys) \<in> listrel r |] ==> (x#xs, y#ys) \<in> listrel r"

  4972

  4973 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"

  4974 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"

  4975 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"

  4976 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"

  4977

  4978

  4979 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"

  4980 by(induct rule: listrel.induct) auto

  4981

  4982 lemma listrel_iff_zip: "(xs,ys) : listrel r \<longleftrightarrow>

  4983   length xs = length ys & (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")

  4984 proof

  4985   assume ?L thus ?R by induct (auto intro: listrel_eq_len)

  4986 next

  4987   assume ?R thus ?L

  4988     apply (clarify)

  4989     by (induct rule: list_induct2) (auto intro: listrel.intros)

  4990 qed

  4991

  4992 lemma listrel_iff_nth: "(xs,ys) : listrel r \<longleftrightarrow>

  4993   length xs = length ys & (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")

  4994 by (auto simp add: all_set_conv_all_nth listrel_iff_zip)

  4995

  4996

  4997 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"

  4998 apply clarify

  4999 apply (erule listrel.induct)

  5000 apply (blast intro: listrel.intros)+

  5001 done

  5002

  5003 lemma listrel_subset: "r \<subseteq> A \<times> A \<Longrightarrow> listrel r \<subseteq> lists A \<times> lists A"

  5004 apply clarify

  5005 apply (erule listrel.induct, auto)

  5006 done

  5007

  5008 lemma listrel_refl_on: "refl_on A r \<Longrightarrow> refl_on (lists A) (listrel r)"

  5009 apply (simp add: refl_on_def listrel_subset Ball_def)

  5010 apply (rule allI)

  5011 apply (induct_tac x)

  5012 apply (auto intro: listrel.intros)

  5013 done

  5014

  5015 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)"

  5016 apply (auto simp add: sym_def)

  5017 apply (erule listrel.induct)

  5018 apply (blast intro: listrel.intros)+

  5019 done

  5020

  5021 lemma listrel_trans: "trans r \<Longrightarrow> trans (listrel r)"

  5022 apply (simp add: trans_def)

  5023 apply (intro allI)

  5024 apply (rule impI)

  5025 apply (erule listrel.induct)

  5026 apply (blast intro: listrel.intros)+

  5027 done

  5028

  5029 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"

  5030 by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans)

  5031

  5032 lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"

  5033 using listrel_refl_on[of UNIV, OF refl_rtrancl]

  5034 by(auto simp: refl_on_def)

  5035

  5036 lemma listrel_rtrancl_trans:

  5037   "\<lbrakk> (xs,ys) : listrel(r^*);  (ys,zs) : listrel(r^*) \<rbrakk>

  5038   \<Longrightarrow> (xs,zs) : listrel(r^*)"

  5039 by (metis listrel_trans trans_def trans_rtrancl)

  5040

  5041

  5042 lemma listrel_Nil [simp]: "listrel r  {[]} = {[]}"

  5043 by (blast intro: listrel.intros)

  5044

  5045 lemma listrel_Cons:

  5046      "listrel r  {x#xs} = set_Cons (r{x}) (listrel r  {xs})"

  5047 by (auto simp add: set_Cons_def intro: listrel.intros)

  5048

  5049 text {* Relating @{term listrel1}, @{term listrel} and closures: *}

  5050

  5051 lemma listrel1_rtrancl_subset_rtrancl_listrel1:

  5052   "listrel1 (r^*) \<subseteq> (listrel1 r)^*"

  5053 proof (rule subrelI)

  5054   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r^*)"

  5055   { fix x y us vs

  5056     have "(x,y) : r^* \<Longrightarrow> (us @ x # vs, us @ y # vs) : (listrel1 r)^*"

  5057     proof(induct rule: rtrancl.induct)

  5058       case rtrancl_refl show ?case by simp

  5059     next

  5060       case rtrancl_into_rtrancl thus ?case

  5061         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)

  5062     qed }

  5063   thus "(xs,ys) \<in> (listrel1 r)^*" using 1 by(blast elim: listrel1E)

  5064 qed

  5065

  5066 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)^* \<Longrightarrow> length x = length y"

  5067 by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)

  5068

  5069 lemma rtrancl_listrel1_ConsI1:

  5070   "(xs,ys) : (listrel1 r)^* \<Longrightarrow> (x#xs,x#ys) : (listrel1 r)^*"

  5071 apply(induct rule: rtrancl.induct)

  5072  apply simp

  5073 by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)

  5074

  5075 lemma rtrancl_listrel1_ConsI2:

  5076   "(x,y) \<in> r^* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)^*

  5077   \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)^*"

  5078   by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1

  5079     subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])

  5080

  5081 lemma listrel1_subset_listrel:

  5082   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"

  5083 by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)

  5084

  5085 lemma listrel_reflcl_if_listrel1:

  5086   "(xs,ys) : listrel1 r \<Longrightarrow> (xs,ys) : listrel(r^*)"

  5087 by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)

  5088

  5089 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"

  5090 proof

  5091   { fix x y assume "(x,y) \<in> listrel (r^*)"

  5092     then have "(x,y) \<in> (listrel1 r)^*"

  5093     by induct (auto intro: rtrancl_listrel1_ConsI2) }

  5094   then show "listrel (r^*) \<subseteq> (listrel1 r)^*"

  5095     by (rule subrelI)

  5096 next

  5097   show "listrel (r^*) \<supseteq> (listrel1 r)^*"

  5098   proof(rule subrelI)

  5099     fix xs ys assume "(xs,ys) \<in> (listrel1 r)^*"

  5100     then show "(xs,ys) \<in> listrel (r^*)"

  5101     proof induct

  5102       case base show ?case by(auto simp add: listrel_iff_zip set_zip)

  5103     next

  5104       case (step ys zs)

  5105       thus ?case  by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)

  5106     qed

  5107   qed

  5108 qed

  5109

  5110 lemma rtrancl_listrel1_if_listrel:

  5111   "(xs,ys) : listrel r \<Longrightarrow> (xs,ys) : (listrel1 r)^*"

  5112 by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)

  5113

  5114 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)^*"

  5115 by(fast intro:rtrancl_listrel1_if_listrel)

  5116

  5117

  5118 subsection {* Size function *}

  5119

  5120 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (list_size f)"

  5121 by (rule is_measure_trivial)

  5122

  5123 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (option_size f)"

  5124 by (rule is_measure_trivial)

  5125

  5126 lemma list_size_estimation[termination_simp]:

  5127   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < list_size f xs"

  5128 by (induct xs) auto

  5129

  5130 lemma list_size_estimation'[termination_simp]:

  5131   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> list_size f xs"

  5132 by (induct xs) auto

  5133

  5134 lemma list_size_map[simp]: "list_size f (map g xs) = list_size (f o g) xs"

  5135 by (induct xs) auto

  5136

  5137 lemma list_size_append[simp]: "list_size f (xs @ ys) = list_size f xs + list_size f ys"

  5138 by (induct xs, auto)

  5139

  5140 lemma list_size_pointwise[termination_simp]:

  5141   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> list_size f xs \<le> list_size g xs"

  5142 by (induct xs) force+

  5143

  5144

  5145 subsection {* Monad operation *}

  5146

  5147 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where

  5148   "bind xs f = concat (map f xs)"

  5149

  5150 hide_const (open) bind

  5151

  5152 lemma bind_simps [simp]:

  5153   "List.bind [] f = []"

  5154   "List.bind (x # xs) f = f x @ List.bind xs f"

  5155   by (simp_all add: bind_def)

  5156

  5157

  5158 subsection {* Transfer *}

  5159

  5160 definition

  5161   embed_list :: "nat list \<Rightarrow> int list"

  5162 where

  5163   "embed_list l = map int l"

  5164

  5165 definition

  5166   nat_list :: "int list \<Rightarrow> bool"

  5167 where

  5168   "nat_list l = nat_set (set l)"

  5169

  5170 definition

  5171   return_list :: "int list \<Rightarrow> nat list"

  5172 where

  5173   "return_list l = map nat l"

  5174

  5175 lemma transfer_nat_int_list_return_embed: "nat_list l \<longrightarrow>

  5176     embed_list (return_list l) = l"

  5177   unfolding embed_list_def return_list_def nat_list_def nat_set_def

  5178   apply (induct l)

  5179   apply auto

  5180 done

  5181

  5182 lemma transfer_nat_int_list_functions:

  5183   "l @ m = return_list (embed_list l @ embed_list m)"

  5184   "[] = return_list []"

  5185   unfolding return_list_def embed_list_def

  5186   apply auto

  5187   apply (induct l, auto)

  5188   apply (induct m, auto)

  5189 done

  5190

  5191 (*

  5192 lemma transfer_nat_int_fold1: "fold f l x =

  5193     fold (%x. f (nat x)) (embed_list l) x";

  5194 *)

  5195

  5196

  5197 subsection {* Code generation *}

  5198

  5199 subsubsection {* Counterparts for set-related operations *}

  5200

  5201 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where

  5202   "member xs x \<longleftrightarrow> x \<in> set xs"

  5203

  5204 text {*

  5205   Use @{text member} only for generating executable code.  Otherwise use

  5206   @{prop "x \<in> set xs"} instead --- it is much easier to reason about.

  5207 *}

  5208

  5209 lemma member_rec [code]:

  5210   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"

  5211   "member [] y \<longleftrightarrow> False"

  5212   by (auto simp add: member_def)

  5213

  5214 lemma in_set_member (* FIXME delete candidate *):

  5215   "x \<in> set xs \<longleftrightarrow> member xs x"

  5216   by (simp add: member_def)

  5217

  5218 definition list_all :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5219   list_all_iff: "list_all P xs \<longleftrightarrow> Ball (set xs) P"

  5220

  5221 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5222   list_ex_iff: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"

  5223

  5224 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where

  5225   list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"

  5226

  5227 text {*

  5228   Usually you should prefer @{text "\<forall>x\<in>set xs"}, @{text "\<exists>x\<in>set xs"}

  5229   and @{text "\<exists>!x. x\<in>set xs \<and> _"} over @{const list_all}, @{const list_ex}

  5230   and @{const list_ex1} in specifications.

  5231 *}

  5232

  5233 lemma list_all_simps [simp, code]:

  5234   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"

  5235   "list_all P [] \<longleftrightarrow> True"

  5236   by (simp_all add: list_all_iff)

  5237

  5238 lemma list_ex_simps [simp, code]:

  5239   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"

  5240   "list_ex P [] \<longleftrightarrow> False"

  5241   by (simp_all add: list_ex_iff)

  5242

  5243 lemma list_ex1_simps [simp, code]:

  5244   "list_ex1 P [] = False"

  5245   "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)"

  5246   by (auto simp add: list_ex1_iff list_all_iff)

  5247

  5248 lemma Ball_set_list_all: (* FIXME delete candidate *)

  5249   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  5250   by (simp add: list_all_iff)

  5251

  5252 lemma Bex_set_list_ex: (* FIXME delete candidate *)

  5253   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  5254   by (simp add: list_ex_iff)

  5255

  5256 lemma list_all_append [simp]:

  5257   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"

  5258   by (auto simp add: list_all_iff)

  5259

  5260 lemma list_ex_append [simp]:

  5261   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"

  5262   by (auto simp add: list_ex_iff)

  5263

  5264 lemma list_all_rev [simp]:

  5265   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"

  5266   by (simp add: list_all_iff)

  5267

  5268 lemma list_ex_rev [simp]:

  5269   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"

  5270   by (simp add: list_ex_iff)

  5271

  5272 lemma list_all_length:

  5273   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"

  5274   by (auto simp add: list_all_iff set_conv_nth)

  5275

  5276 lemma list_ex_length:

  5277   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"

  5278   by (auto simp add: list_ex_iff set_conv_nth)

  5279

  5280 lemma list_all_cong [fundef_cong]:

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

  5282   by (simp add: list_all_iff)

  5283

  5284 lemma list_any_cong [fundef_cong]:

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

  5286   by (simp add: list_ex_iff)

  5287

  5288 text {* Bounded quantification and summation over nats. *}

  5289

  5290 lemma atMost_upto [code_unfold]:

  5291   "{..n} = set [0..<Suc n]"

  5292   by auto

  5293

  5294 lemma atLeast_upt [code_unfold]:

  5295   "{..<n} = set [0..<n]"

  5296   by auto

  5297

  5298 lemma greaterThanLessThan_upt [code_unfold]:

  5299   "{n<..<m} = set [Suc n..<m]"

  5300   by auto

  5301

  5302 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]

  5303

  5304 lemma greaterThanAtMost_upt [code_unfold]:

  5305   "{n<..m} = set [Suc n..<Suc m]"

  5306   by auto

  5307

  5308 lemma atLeastAtMost_upt [code_unfold]:

  5309   "{n..m} = set [n..<Suc m]"

  5310   by auto

  5311

  5312 lemma all_nat_less_eq [code_unfold]:

  5313   "(\<forall>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"

  5314   by auto

  5315

  5316 lemma ex_nat_less_eq [code_unfold]:

  5317   "(\<exists>m<n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"

  5318   by auto

  5319

  5320 lemma all_nat_less [code_unfold]:

  5321   "(\<forall>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"

  5322   by auto

  5323

  5324 lemma ex_nat_less [code_unfold]:

  5325   "(\<exists>m\<le>n\<Colon>nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"

  5326   by auto

  5327

  5328 lemma setsum_set_upt_conv_listsum_nat [code_unfold]:

  5329   "setsum f (set [m..<n]) = listsum (map f [m..<n])"

  5330   by (simp add: interv_listsum_conv_setsum_set_nat)

  5331

  5332 text {* Summation over ints. *}

  5333

  5334 lemma greaterThanLessThan_upto [code_unfold]:

  5335   "{i<..<j::int} = set [i+1..j - 1]"

  5336 by auto

  5337

  5338 lemma atLeastLessThan_upto [code_unfold]:

  5339   "{i..<j::int} = set [i..j - 1]"

  5340 by auto

  5341

  5342 lemma greaterThanAtMost_upto [code_unfold]:

  5343   "{i<..j::int} = set [i+1..j]"

  5344 by auto

  5345

  5346 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]

  5347

  5348 lemma setsum_set_upto_conv_listsum_int [code_unfold]:

  5349   "setsum f (set [i..j::int]) = listsum (map f [i..j])"

  5350   by (simp add: interv_listsum_conv_setsum_set_int)

  5351

  5352

  5353 subsubsection {* Optimizing by rewriting *}

  5354

  5355 definition null :: "'a list \<Rightarrow> bool" where

  5356   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"

  5357

  5358 text {*

  5359   Efficient emptyness check is implemented by @{const null}.

  5360 *}

  5361

  5362 lemma null_rec [code]:

  5363   "null (x # xs) \<longleftrightarrow> False"

  5364   "null [] \<longleftrightarrow> True"

  5365   by (simp_all add: null_def)

  5366

  5367 lemma eq_Nil_null: (* FIXME delete candidate *)

  5368   "xs = [] \<longleftrightarrow> null xs"

  5369   by (simp add: null_def)

  5370

  5371 lemma equal_Nil_null [code_unfold]:

  5372   "HOL.equal xs [] \<longleftrightarrow> null xs"

  5373   by (simp add: equal eq_Nil_null)

  5374

  5375 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5376   [code_abbrev]: "maps f xs = concat (map f xs)"

  5377

  5378 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where

  5379   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"

  5380

  5381 text {*

  5382   Operations @{const maps} and @{const map_filter} avoid

  5383   intermediate lists on execution -- do not use for proving.

  5384 *}

  5385

  5386 lemma maps_simps [code]:

  5387   "maps f (x # xs) = f x @ maps f xs"

  5388   "maps f [] = []"

  5389   by (simp_all add: maps_def)

  5390

  5391 lemma map_filter_simps [code]:

  5392   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"

  5393   "map_filter f [] = []"

  5394   by (simp_all add: map_filter_def split: option.split)

  5395

  5396 lemma concat_map_maps: (* FIXME delete candidate *)

  5397   "concat (map f xs) = maps f xs"

  5398   by (simp add: maps_def)

  5399

  5400 lemma map_filter_map_filter [code_unfold]:

  5401   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"

  5402   by (simp add: map_filter_def)

  5403

  5404 text {* Optimized code for @{text"\<forall>i\<in>{a..b::int}"} and @{text"\<forall>n:{a..<b::nat}"}

  5405 and similiarly for @{text"\<exists>"}. *}

  5406

  5407 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where

  5408   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"

  5409

  5410 lemma [code]:

  5411   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"

  5412 proof -

  5413   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"

  5414   proof -

  5415     fix n

  5416     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"

  5417     then show "P n" by (cases "n = i") simp_all

  5418   qed

  5419   show ?thesis by (auto simp add: all_interval_nat_def intro: *)

  5420 qed

  5421

  5422 lemma list_all_iff_all_interval_nat [code_unfold]:

  5423   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"

  5424   by (simp add: list_all_iff all_interval_nat_def)

  5425

  5426 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:

  5427   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"

  5428   by (simp add: list_ex_iff all_interval_nat_def)

  5429

  5430 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where

  5431   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"

  5432

  5433 lemma [code]:

  5434   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"

  5435 proof -

  5436   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"

  5437   proof -

  5438     fix k

  5439     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"

  5440     then show "P k" by (cases "k = i") simp_all

  5441   qed

  5442   show ?thesis by (auto simp add: all_interval_int_def intro: *)

  5443 qed

  5444

  5445 lemma list_all_iff_all_interval_int [code_unfold]:

  5446   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"

  5447   by (simp add: list_all_iff all_interval_int_def)

  5448

  5449 lemma list_ex_iff_not_all_inverval_int [code_unfold]:

  5450   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"

  5451   by (simp add: list_ex_iff all_interval_int_def)

  5452

  5453 hide_const (open) member null maps map_filter all_interval_nat all_interval_int

  5454

  5455

  5456 subsubsection {* Pretty lists *}

  5457

  5458 use "Tools/list_code.ML"

  5459

  5460 code_type list

  5461   (SML "_ list")

  5462   (OCaml "_ list")

  5463   (Haskell "![(_)]")

  5464   (Scala "List[(_)]")

  5465

  5466 code_const Nil

  5467   (SML "[]")

  5468   (OCaml "[]")

  5469   (Haskell "[]")

  5470   (Scala "!Nil")

  5471

  5472 code_instance list :: equal

  5473   (Haskell -)

  5474

  5475 code_const "HOL.equal \<Colon> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"

  5476   (Haskell infix 4 "==")

  5477

  5478 code_reserved SML

  5479   list

  5480

  5481 code_reserved OCaml

  5482   list

  5483

  5484 setup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}

  5485

  5486

  5487 subsubsection {* Use convenient predefined operations *}

  5488

  5489 code_const "op @"

  5490   (SML infixr 7 "@")

  5491   (OCaml infixr 6 "@")

  5492   (Haskell infixr 5 "++")

  5493   (Scala infixl 7 "++")

  5494

  5495 code_const map

  5496   (Haskell "map")

  5497

  5498 code_const filter

  5499   (Haskell "filter")

  5500

  5501 code_const concat

  5502   (Haskell "concat")

  5503

  5504 code_const List.maps

  5505   (Haskell "concatMap")

  5506

  5507 code_const rev

  5508   (Haskell "reverse")

  5509

  5510 code_const zip

  5511   (Haskell "zip")

  5512

  5513 code_const List.null

  5514   (Haskell "null")

  5515

  5516 code_const takeWhile

  5517   (Haskell "takeWhile")

  5518

  5519 code_const dropWhile

  5520   (Haskell "dropWhile")

  5521

  5522 code_const list_all

  5523   (Haskell "all")

  5524

  5525 code_const list_ex

  5526   (Haskell "any")

  5527

  5528

  5529 subsubsection {* Implementation of sets by lists *}

  5530

  5531 text {* Basic operations *}

  5532

  5533 lemma is_empty_set [code]:

  5534   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"

  5535   by (simp add: Set.is_empty_def null_def)

  5536

  5537 lemma empty_set [code]:

  5538   "{} = set []"

  5539   by simp

  5540

  5541 lemma [code]:

  5542   "x \<in> set xs \<longleftrightarrow> List.member xs x"

  5543   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"

  5544   by (simp_all add: member_def)

  5545

  5546 lemma UNIV_coset [code]:

  5547   "UNIV = List.coset []"

  5548   by simp

  5549

  5550 lemma insert_code [code]:

  5551   "insert x (set xs) = set (List.insert x xs)"

  5552   "insert x (List.coset xs) = List.coset (removeAll x xs)"

  5553   by simp_all

  5554

  5555 lemma remove_code [code]:

  5556   "Set.remove x (set xs) = set (removeAll x xs)"

  5557   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"

  5558   by (simp_all add: remove_def Compl_insert)

  5559

  5560 lemma Ball_set [code]:

  5561   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  5562   by (simp add: list_all_iff)

  5563

  5564 lemma Bex_set [code]:

  5565   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  5566   by (simp add: list_ex_iff)

  5567

  5568 lemma card_set [code]:

  5569   "card (set xs) = length (remdups xs)"

  5570 proof -

  5571   have "card (set (remdups xs)) = length (remdups xs)"

  5572     by (rule distinct_card) simp

  5573   then show ?thesis by simp

  5574 qed

  5575

  5576

  5577 text {* Operations on relations *}

  5578

  5579 lemma product_code [code]:

  5580   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"

  5581   by (auto simp add: Product_Type.product_def)

  5582

  5583 lemma Id_on_set [code]:

  5584   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"

  5585   by (auto simp add: Id_on_def)

  5586

  5587 lemma trancl_set_ntrancl [code]:

  5588   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"

  5589   by (simp add: finite_trancl_ntranl)

  5590

  5591 lemma set_rel_comp [code]:

  5592   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"

  5593   by (auto simp add: Bex_def)

  5594

  5595 lemma wf_set [code]:

  5596   "wf (set xs) = acyclic (set xs)"

  5597   by (simp add: wf_iff_acyclic_if_finite)

  5598

  5599 end