src/HOL/List.thy
 author haftmann Thu Feb 14 12:24:42 2013 +0100 (2013-02-14) changeset 51112 da97167e03f7 parent 51096 60e4b75fefe1 child 51160 599ff65b85e2 permissions -rw-r--r--
abandoned theory Plain
     1 (*  Title:      HOL/List.thy

     2     Author:     Tobias Nipkow

     3 *)

     4

     5 header {* The datatype of finite lists *}

     6

     7 theory List

     8 imports Presburger Code_Numeral Quotient ATP

     9 begin

    10

    11 datatype 'a list =

    12     Nil    ("[]")

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

    14

    15 syntax

    16   -- {* list Enumeration *}

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

    18

    19 translations

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

    21   "[x]" == "x#[]"

    22

    23

    24 subsection {* Basic list processing functions *}

    25

    26 primrec hd :: "'a list \<Rightarrow> 'a" where

    27 "hd (x # xs) = x"

    28

    29 primrec tl :: "'a list \<Rightarrow> 'a list" where

    30 "tl [] = []" |

    31 "tl (x # xs) = xs"

    32

    33 primrec last :: "'a list \<Rightarrow> 'a" where

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

    35

    36 primrec butlast :: "'a list \<Rightarrow> 'a list" where

    37 "butlast []= []" |

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

    39

    40 primrec set :: "'a list \<Rightarrow> 'a set" where

    41 "set [] = {}" |

    42 "set (x # xs) = insert x (set xs)"

    43

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

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

    46

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

    48 "map f [] = []" |

    49 "map f (x # xs) = f x # map f xs"

    50

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

    52 append_Nil: "[] @ ys = ys" |

    53 append_Cons: "(x#xs) @ ys = x # xs @ ys"

    54

    55 primrec rev :: "'a list \<Rightarrow> 'a list" where

    56 "rev [] = []" |

    57 "rev (x # xs) = rev xs @ [x]"

    58

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

    60 "filter P [] = []" |

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

    62

    63 syntax

    64   -- {* Special syntax for filter *}

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

    66

    67 translations

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

    69

    70 syntax (xsymbols)

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

    72 syntax (HTML output)

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

    74

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

    76 fold_Nil:  "fold f [] = id" |

    77 fold_Cons: "fold f (x # xs) = fold f xs \<circ> f x"

    78

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

    80 foldr_Nil:  "foldr f [] = id" |

    81 foldr_Cons: "foldr f (x # xs) = f x \<circ> foldr f xs"

    82

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

    84 foldl_Nil:  "foldl f a [] = a" |

    85 foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"

    86

    87 primrec concat:: "'a list list \<Rightarrow> 'a list" where

    88 "concat [] = []" |

    89 "concat (x # xs) = x @ concat xs"

    90

    91 definition (in monoid_add) listsum :: "'a list \<Rightarrow> 'a" where

    92 "listsum xs = foldr plus xs 0"

    93

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

    95 drop_Nil: "drop n [] = []" |

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

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

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

    99

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

   101 take_Nil:"take n [] = []" |

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

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

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

   105

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

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

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

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

   110

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

   112 "list_update [] i v = []" |

   113 "list_update (x # xs) i v =

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

   115

   116 nonterminal lupdbinds and lupdbind

   117

   118 syntax

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

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

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

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

   123

   124 translations

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

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

   127

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

   129 "takeWhile P [] = []" |

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

   131

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

   133 "dropWhile P [] = []" |

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

   135

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

   137 "zip xs [] = []" |

   138 zip_Cons: "zip xs (y # ys) =

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

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

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

   142

   143 primrec product :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where

   144 "product [] _ = []" |

   145 "product (x#xs) ys = map (Pair x) ys @ product xs ys"

   146

   147 hide_const (open) product

   148

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

   150 upt_0: "[i..<0] = []" |

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

   152

   153 definition insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

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

   155

   156 hide_const (open) insert

   157 hide_fact (open) insert_def

   158

   159 primrec find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where

   160 "find _ [] = None" |

   161 "find P (x#xs) = (if P x then Some x else find P xs)"

   162

   163 hide_const (open) find

   164

   165 primrec those :: "'a option list \<Rightarrow> 'a list option"

   166 where

   167 "those [] = Some []" |

   168 "those (x # xs) = (case x of

   169   None \<Rightarrow> None

   170 | Some y \<Rightarrow> Option.map (Cons y) (those xs))"

   171

   172 primrec remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   173 "remove1 x [] = []" |

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

   175

   176 primrec removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where

   177 "removeAll x [] = []" |

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

   179

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

   181 "distinct [] \<longleftrightarrow> True" |

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

   183

   184 primrec remdups :: "'a list \<Rightarrow> 'a list" where

   185 "remdups [] = []" |

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

   187

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

   189 replicate_0: "replicate 0 x = []" |

   190 replicate_Suc: "replicate (Suc n) x = x # replicate n x"

   191

   192 text {*

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

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

   195

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

   197 "length \<equiv> size"

   198

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

   200 "rotate1 [] = []" |

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

   202

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

   204 "rotate n = rotate1 ^^ n"

   205

   206 definition list_all2 :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool" where

   207 "list_all2 P xs ys =

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

   209

   210 definition sublist :: "'a list => nat set => 'a list" where

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

   212

   213 primrec sublists :: "'a list \<Rightarrow> 'a list list" where

   214 "sublists [] = [[]]" |

   215 "sublists (x#xs) = (let xss = sublists xs in map (Cons x) xss @ xss)"

   216

   217 primrec n_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where

   218 "n_lists 0 xs = [[]]" |

   219 "n_lists (Suc n) xs = concat (map (\<lambda>ys. map (\<lambda>y. y # ys) xs) (n_lists n xs))"

   220

   221 hide_const (open) n_lists

   222

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

   224 "splice [] ys = ys" |

   225 "splice xs [] = xs" |

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

   227

   228 text{*

   229 \begin{figure}[htbp]

   230 \fbox{

   231 \begin{tabular}{l}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   248 @{lemma "List.product [a,b] [c,d] = [(a, c), (a, d), (b, c), (b, d)]" by simp}\\

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

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

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

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

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

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

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

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

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

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

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

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

   261 @{lemma "List.find (%i::int. i>0) [0,0] = None" by simp}\\

   262 @{lemma "List.find (%i::int. i>0) [0,1,0,2] = Some 1" by simp}\\

   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 "sublists [a,b] = [[a, b], [a], [b], []]" by simp}\\

   269 @{lemma "List.n_lists 2 [a,b,c] = [[a, a], [b, a], [c, a], [a, b], [b, b], [c, b], [a, c], [b, c], [c, c]]" by (simp add: eval_nat_numeral)}\\

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

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

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

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

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

   275 \end{tabular}}

   276 \caption{Characteristic examples}

   277 \label{fig:Characteristic}

   278 \end{figure}

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

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

   281 *}

   282

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

   284 not for efficient implementations. *}

   285

   286 context linorder

   287 begin

   288

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

   290   Nil [iff]: "sorted []"

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

   292

   293 lemma sorted_single [iff]:

   294   "sorted [x]"

   295   by (rule sorted.Cons) auto

   296

   297 lemma sorted_many:

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

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

   300

   301 lemma sorted_many_eq [simp, code]:

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

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

   304

   305 lemma [code]:

   306   "sorted [] \<longleftrightarrow> True"

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

   308   by simp_all

   309

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

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

   312 "insort_key f x (y#ys) =

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

   314

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

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

   317

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

   319 "insort_insert_key f x xs =

   320   (if f x \<in> f  set xs then xs else insort_key f x xs)"

   321

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

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

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

   325

   326 end

   327

   328

   329 subsubsection {* List comprehension *}

   330

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

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

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

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

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

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

   337

   338 The qualifiers after the dot are

   339 \begin{description}

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

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

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

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

   344 \end{description}

   345

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

   347 misunderstandings, the translation into desugared form is not reversed

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

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

   350

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

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

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

   354 definitions for the list comprehensions in question.  *}

   355

   356 nonterminal lc_qual and lc_quals

   357

   358 syntax

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

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

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

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

   363   "_lc_end" :: "lc_quals" ("]")

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

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

   366

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

   368    translation of [e. p<-xs]

   369 translations

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

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

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

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

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

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

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

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

   378 *)

   379

   380 syntax (xsymbols)

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

   382 syntax (HTML output)

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

   384

   385 parse_translation (advanced) {*

   386   let

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

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

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

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

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

   392

   393     fun single x = ConsC $x$ NilC;

   394

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

   396       let

   397         (* FIXME proper name context!? *)

   398         val x =

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

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

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

   402         val case2 =

   403           Syntax.const @{syntax_const "_case1"} $  404 Syntax.const @{const_syntax dummy_pattern}$ NilC;

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

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

   407

   408     fun abs_tr ctxt p e opti =

   409       (case Term_Position.strip_positions p of

   410         Free (s, T) =>

   411           let

   412             val thy = Proof_Context.theory_of ctxt;

   413             val s' = Proof_Context.intern_const ctxt s;

   414           in

   415             if Sign.declared_const thy s'

   416             then (pat_tr ctxt p e opti, false)

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

   418           end

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

   420

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

   428       | lc_tr ctxt

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

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

   431           (case abs_tr ctxt p e true of

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

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

   439

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

   441 *}

   442

   443 ML {*

   444   let

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

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

   447   in

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   474   end;

   475 *}

   476

   477 (*

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

   479 *)

   480

   481

   482 ML {*

   483 (* Simproc for rewriting list comprehensions applied to List.set to set

   484    comprehension. *)

   485

   486 signature LIST_TO_SET_COMPREHENSION =

   487 sig

   488   val simproc : simpset -> cterm -> thm option

   489 end

   490

   491 structure List_to_Set_Comprehension : LIST_TO_SET_COMPREHENSION =

   492 struct

   493

   494 (* conversion *)

   495

   496 fun all_exists_conv cv ctxt ct =

   497   (case Thm.term_of ct of

   498     Const (@{const_name HOL.Ex}, _) $Abs _ =>   499 Conv.arg_conv (Conv.abs_conv (all_exists_conv cv o #2) ctxt) ct   500 | _ => cv ctxt ct)   501   502 fun all_but_last_exists_conv cv ctxt ct =   503 (case Thm.term_of ct of   504 Const (@{const_name HOL.Ex}, _)$ Abs (_, _, Const (@{const_name HOL.Ex}, _) $_) =>   505 Conv.arg_conv (Conv.abs_conv (all_but_last_exists_conv cv o #2) ctxt) ct   506 | _ => cv ctxt ct)   507   508 fun Collect_conv cv ctxt ct =   509 (case Thm.term_of ct of   510 Const (@{const_name Set.Collect}, _)$ Abs _ => Conv.arg_conv (Conv.abs_conv cv ctxt) ct

   511   | _ => raise CTERM ("Collect_conv", [ct]))

   512

   513 fun Trueprop_conv cv ct =

   514   (case Thm.term_of ct of

   515     Const (@{const_name Trueprop}, _) $_ => Conv.arg_conv cv ct   516 | _ => raise CTERM ("Trueprop_conv", [ct]))   517   518 fun eq_conv cv1 cv2 ct =   519 (case Thm.term_of ct of   520 Const (@{const_name HOL.eq}, _)$ _ $_ => Conv.combination_conv (Conv.arg_conv cv1) cv2 ct   521 | _ => raise CTERM ("eq_conv", [ct]))   522   523 fun conj_conv cv1 cv2 ct =   524 (case Thm.term_of ct of   525 Const (@{const_name HOL.conj}, _)$ _ $_ => Conv.combination_conv (Conv.arg_conv cv1) cv2 ct   526 | _ => raise CTERM ("conj_conv", [ct]))   527   528 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)   529   530 fun conjunct_assoc_conv ct =   531 Conv.try_conv   532 (rewr_conv' @{thm conj_assoc} then_conv conj_conv Conv.all_conv conjunct_assoc_conv) ct   533   534 fun right_hand_set_comprehension_conv conv ctxt =   535 Trueprop_conv (eq_conv Conv.all_conv   536 (Collect_conv (all_exists_conv conv o #2) ctxt))   537   538   539 (* term abstraction of list comprehension patterns *)   540   541 datatype termlets = If | Case of (typ * int)   542   543 fun simproc ss redex =   544 let   545 val ctxt = Simplifier.the_context ss   546 val thy = Proof_Context.theory_of ctxt   547 val set_Nil_I = @{thm trans} OF [@{thm set.simps(1)}, @{thm empty_def}]   548 val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}   549 val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}   550 val del_refl_eq = @{lemma "(t = t & P) == P" by simp}   551 fun mk_set T = Const (@{const_name List.set}, HOLogic.listT T --> HOLogic.mk_setT T)   552 fun dest_set (Const (@{const_name List.set}, _)$ xs) = xs

   553     fun dest_singleton_list (Const (@{const_name List.Cons}, _)

   554           $t$ (Const (@{const_name List.Nil}, _))) = t

   555       | dest_singleton_list t = raise TERM ("dest_singleton_list", [t])

   556     (* We check that one case returns a singleton list and all other cases

   557        return [], and return the index of the one singleton list case *)

   558     fun possible_index_of_singleton_case cases =

   559       let

   560         fun check (i, case_t) s =

   561           (case strip_abs_body case_t of

   562             (Const (@{const_name List.Nil}, _)) => s

   563           | _ => (case s of NONE => SOME i | SOME _ => NONE))

   564       in

   565         fold_index check cases NONE

   566       end

   567     (* returns (case_expr type index chosen_case) option  *)

   568     fun dest_case case_term =

   569       let

   570         val (case_const, args) = strip_comb case_term

   571       in

   572         (case try dest_Const case_const of

   573           SOME (c, T) =>

   574             (case Datatype.info_of_case thy c of

   575               SOME _ =>

   576                 (case possible_index_of_singleton_case (fst (split_last args)) of

   577                   SOME i =>

   578                     let

   579                       val (Ts, _) = strip_type T

   580                       val T' = List.last Ts

   581                     in SOME (List.last args, T', i, nth args i) end

   582                 | NONE => NONE)

   583             | NONE => NONE)

   584         | NONE => NONE)

   585       end

   586     (* returns condition continuing term option *)

   587     fun dest_if (Const (@{const_name If}, _) $cond$ then_t $Const (@{const_name Nil}, _)) =   588 SOME (cond, then_t)   589 | dest_if _ = NONE   590 fun tac _ [] = rtac set_singleton 1 ORELSE rtac inst_Collect_mem_eq 1   591 | tac ctxt (If :: cont) =   592 Splitter.split_tac [@{thm split_if}] 1   593 THEN rtac @{thm conjI} 1   594 THEN rtac @{thm impI} 1   595 THEN Subgoal.FOCUS (fn {prems, context, ...} =>   596 CONVERSION (right_hand_set_comprehension_conv (K   597 (conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv   598 then_conv   599 rewr_conv' @{lemma "(True & P) = P" by simp})) context) 1) ctxt 1   600 THEN tac ctxt cont   601 THEN rtac @{thm impI} 1   602 THEN Subgoal.FOCUS (fn {prems, context, ...} =>   603 CONVERSION (right_hand_set_comprehension_conv (K   604 (conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv   605 then_conv rewr_conv' @{lemma "(False & P) = False" by simp})) context) 1) ctxt 1   606 THEN rtac set_Nil_I 1   607 | tac ctxt (Case (T, i) :: cont) =   608 let   609 val info = Datatype.the_info thy (fst (dest_Type T))   610 in   611 (* do case distinction *)   612 Splitter.split_tac [#split info] 1   613 THEN EVERY (map_index (fn (i', _) =>   614 (if i' < length (#case_rewrites info) - 1 then rtac @{thm conjI} 1 else all_tac)   615 THEN REPEAT_DETERM (rtac @{thm allI} 1)   616 THEN rtac @{thm impI} 1   617 THEN (if i' = i then   618 (* continue recursively *)   619 Subgoal.FOCUS (fn {prems, context, ...} =>   620 CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K   621 ((conj_conv   622 (eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv   623 (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq (#inject info)))))   624 Conv.all_conv)   625 then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))   626 then_conv conjunct_assoc_conv)) context   627 then_conv (Trueprop_conv (eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt) =>   628 Conv.repeat_conv   629 (all_but_last_exists_conv   630 (K (rewr_conv'   631 @{lemma "(EX x. x = t & P x) = P t" by simp})) ctxt)) context)))) 1) ctxt 1   632 THEN tac ctxt cont   633 else   634 Subgoal.FOCUS (fn {prems, context, ...} =>   635 CONVERSION   636 (right_hand_set_comprehension_conv (K   637 (conj_conv   638 ((eq_conv Conv.all_conv   639 (rewr_conv' (List.last prems))) then_conv   640 (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) (#distinct info))))   641 Conv.all_conv then_conv   642 (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv   643 Trueprop_conv   644 (eq_conv Conv.all_conv   645 (Collect_conv (fn (_, ctxt) =>   646 Conv.repeat_conv   647 (Conv.bottom_conv   648 (K (rewr_conv'   649 @{lemma "(EX x. P) = P" by simp})) ctxt)) context))) 1) ctxt 1   650 THEN rtac set_Nil_I 1)) (#case_rewrites info))   651 end   652 fun make_inner_eqs bound_vs Tis eqs t =   653 (case dest_case t of   654 SOME (x, T, i, cont) =>   655 let   656 val (vs, body) = strip_abs (Pattern.eta_long (map snd bound_vs) cont)   657 val x' = incr_boundvars (length vs) x   658 val eqs' = map (incr_boundvars (length vs)) eqs   659 val (constr_name, _) = nth (the (Datatype.get_constrs thy (fst (dest_Type T)))) i   660 val constr_t =   661 list_comb   662 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))   663 val constr_eq = Const (@{const_name HOL.eq}, T --> T --> @{typ bool})$ constr_t $x'   664 in   665 make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body   666 end   667 | NONE =>   668 (case dest_if t of   669 SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont   670 | NONE =>   671 if eqs = [] then NONE (* no rewriting, nothing to be done *)   672 else   673 let   674 val Type (@{type_name List.list}, [rT]) = fastype_of1 (map snd bound_vs, t)   675 val pat_eq =   676 (case try dest_singleton_list t of   677 SOME t' =>   678 Const (@{const_name HOL.eq}, rT --> rT --> @{typ bool})$

   679                         Bound (length bound_vs) $t'   680 | NONE =>   681 Const (@{const_name Set.member}, rT --> HOLogic.mk_setT rT --> @{typ bool})$

   682                         Bound (length bound_vs) $(mk_set rT$ t))

   683                 val reverse_bounds = curry subst_bounds

   684                   ((map Bound ((length bound_vs - 1) downto 0)) @ [Bound (length bound_vs)])

   685                 val eqs' = map reverse_bounds eqs

   686                 val pat_eq' = reverse_bounds pat_eq

   687                 val inner_t =

   688                   fold (fn (_, T) => fn t => HOLogic.exists_const T $absdummy T t)   689 (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')   690 val lhs = term_of redex   691 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)   692 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))   693 in   694 SOME   695 ((Goal.prove ctxt [] [] rewrite_rule_t   696 (fn {context, ...} => tac context (rev Tis))) RS @{thm eq_reflection})   697 end))   698 in   699 make_inner_eqs [] [] [] (dest_set (term_of redex))   700 end   701   702 end   703 *}   704   705 simproc_setup list_to_set_comprehension ("set xs") = {* K List_to_Set_Comprehension.simproc *}   706   707 code_datatype set coset   708   709 hide_const (open) coset   710   711   712 subsubsection {* @{const Nil} and @{const Cons} *}   713   714 lemma not_Cons_self [simp]:   715 "xs \<noteq> x # xs"   716 by (induct xs) auto   717   718 lemma not_Cons_self2 [simp]:   719 "x # xs \<noteq> xs"   720 by (rule not_Cons_self [symmetric])   721   722 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"   723 by (induct xs) auto   724   725 lemma length_induct:   726 "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"   727 by (rule measure_induct [of length]) iprover   728   729 lemma list_nonempty_induct [consumes 1, case_names single cons]:   730 assumes "xs \<noteq> []"   731 assumes single: "\<And>x. P [x]"   732 assumes cons: "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)"   733 shows "P xs"   734 using xs \<noteq> [] proof (induct xs)   735 case Nil then show ?case by simp   736 next   737 case (Cons x xs) show ?case proof (cases xs)   738 case Nil with single show ?thesis by simp   739 next   740 case Cons then have "xs \<noteq> []" by simp   741 moreover with Cons.hyps have "P xs" .   742 ultimately show ?thesis by (rule cons)   743 qed   744 qed   745   746 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"   747 by (auto intro!: inj_onI)   748   749   750 subsubsection {* @{const length} *}   751   752 text {*   753 Needs to come before @{text "@"} because of theorem @{text   754 append_eq_append_conv}.   755 *}   756   757 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"   758 by (induct xs) auto   759   760 lemma length_map [simp]: "length (map f xs) = length xs"   761 by (induct xs) auto   762   763 lemma length_rev [simp]: "length (rev xs) = length xs"   764 by (induct xs) auto   765   766 lemma length_tl [simp]: "length (tl xs) = length xs - 1"   767 by (cases xs) auto   768   769 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"   770 by (induct xs) auto   771   772 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"   773 by (induct xs) auto   774   775 lemma length_pos_if_in_set: "x : set xs \<Longrightarrow> length xs > 0"   776 by auto   777   778 lemma length_Suc_conv:   779 "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"   780 by (induct xs) auto   781   782 lemma Suc_length_conv:   783 "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"   784 apply (induct xs, simp, simp)   785 apply blast   786 done   787   788 lemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False"   789 by (induct xs) auto   790   791 lemma list_induct2 [consumes 1, case_names Nil Cons]:   792 "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>   793 (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))   794 \<Longrightarrow> P xs ys"   795 proof (induct xs arbitrary: ys)   796 case Nil then show ?case by simp   797 next   798 case (Cons x xs ys) then show ?case by (cases ys) simp_all   799 qed   800   801 lemma list_induct3 [consumes 2, case_names Nil Cons]:   802 "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>   803 (\<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))   804 \<Longrightarrow> P xs ys zs"   805 proof (induct xs arbitrary: ys zs)   806 case Nil then show ?case by simp   807 next   808 case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)   809 (cases zs, simp_all)   810 qed   811   812 lemma list_induct4 [consumes 3, case_names Nil Cons]:   813 "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>   814 P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>   815 length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>   816 P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"   817 proof (induct xs arbitrary: ys zs ws)   818 case Nil then show ?case by simp   819 next   820 case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)   821 qed   822   823 lemma list_induct2':   824 "\<lbrakk> P [] [];   825 \<And>x xs. P (x#xs) [];   826 \<And>y ys. P [] (y#ys);   827 \<And>x xs y ys. P xs ys \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>   828 \<Longrightarrow> P xs ys"   829 by (induct xs arbitrary: ys) (case_tac x, auto)+   830   831 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"   832 by (rule Eq_FalseI) auto   833   834 simproc_setup list_neq ("(xs::'a list) = ys") = {*   835 (*   836 Reduces xs=ys to False if xs and ys cannot be of the same length.   837 This is the case if the atomic sublists of one are a submultiset   838 of those of the other list and there are fewer Cons's in one than the other.   839 *)   840   841 let   842   843 fun len (Const(@{const_name Nil},_)) acc = acc   844 | len (Const(@{const_name Cons},_)$ _ $xs) (ts,n) = len xs (ts,n+1)   845 | len (Const(@{const_name append},_)$ xs $ys) acc = len xs (len ys acc)   846 | len (Const(@{const_name rev},_)$ xs) acc = len xs acc

   847   | len (Const(@{const_name map},_) $_$ xs) acc = len xs acc

   848   | len t (ts,n) = (t::ts,n);

   849

   850 fun list_neq _ ss ct =

   851   let

   852     val (Const(_,eqT) $lhs$ rhs) = Thm.term_of ct;

   853     val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);

   854     fun prove_neq() =

   855       let

   856         val Type(_,listT::_) = eqT;

   857         val size = HOLogic.size_const listT;

   858         val eq_len = HOLogic.mk_eq (size $lhs, size$ rhs);

   859         val neq_len = HOLogic.mk_Trueprop (HOLogic.Not $eq_len);   860 val thm = Goal.prove (Simplifier.the_context ss) [] [] neq_len   861 (K (simp_tac (Simplifier.inherit_context ss @{simpset}) 1));   862 in SOME (thm RS @{thm neq_if_length_neq}) end   863 in   864 if m < n andalso submultiset (op aconv) (ls,rs) orelse   865 n < m andalso submultiset (op aconv) (rs,ls)   866 then prove_neq() else NONE   867 end;   868 in list_neq end;   869 *}   870   871   872 subsubsection {* @{text "@"} -- append *}   873   874 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"   875 by (induct xs) auto   876   877 lemma append_Nil2 [simp]: "xs @ [] = xs"   878 by (induct xs) auto   879   880 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"   881 by (induct xs) auto   882   883 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"   884 by (induct xs) auto   885   886 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"   887 by (induct xs) auto   888   889 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"   890 by (induct xs) auto   891   892 lemma append_eq_append_conv [simp, no_atp]:   893 "length xs = length ys \<or> length us = length vs   894 ==> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"   895 apply (induct xs arbitrary: ys)   896 apply (case_tac ys, simp, force)   897 apply (case_tac ys, force, simp)   898 done   899   900 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =   901 (EX us. xs = zs @ us & us @ ys = ts | xs @ us = zs & ys = us@ ts)"   902 apply (induct xs arbitrary: ys zs ts)   903 apply fastforce   904 apply(case_tac zs)   905 apply simp   906 apply fastforce   907 done   908   909 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"   910 by simp   911   912 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"   913 by simp   914   915 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"   916 by simp   917   918 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"   919 using append_same_eq [of _ _ "[]"] by auto   920   921 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"   922 using append_same_eq [of "[]"] by auto   923   924 lemma hd_Cons_tl [simp,no_atp]: "xs \<noteq> [] ==> hd xs # tl xs = xs"   925 by (induct xs) auto   926   927 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"   928 by (induct xs) auto   929   930 lemma hd_append2 [simp]: "xs \<noteq> [] ==> hd (xs @ ys) = hd xs"   931 by (simp add: hd_append split: list.split)   932   933 lemma tl_append: "tl (xs @ ys) = (case xs of [] => tl ys | z#zs => zs @ ys)"   934 by (simp split: list.split)   935   936 lemma tl_append2 [simp]: "xs \<noteq> [] ==> tl (xs @ ys) = tl xs @ ys"   937 by (simp add: tl_append split: list.split)   938   939   940 lemma Cons_eq_append_conv: "x#xs = ys@zs =   941 (ys = [] & x#xs = zs | (EX ys'. x#ys' = ys & xs = ys'@zs))"   942 by(cases ys) auto   943   944 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =   945 (ys = [] & zs = x#xs | (EX ys'. ys = x#ys' & ys'@zs = xs))"   946 by(cases ys) auto   947   948   949 text {* Trivial rules for solving @{text "@"}-equations automatically. *}   950   951 lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"   952 by simp   953   954 lemma Cons_eq_appendI:   955 "[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"   956 by (drule sym) simp   957   958 lemma append_eq_appendI:   959 "[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"   960 by (drule sym) simp   961   962   963 text {*   964 Simplification procedure for all list equalities.   965 Currently only tries to rearrange @{text "@"} to see if   966 - both lists end in a singleton list,   967 - or both lists end in the same list.   968 *}   969   970 simproc_setup list_eq ("(xs::'a list) = ys") = {*   971 let   972 fun last (cons as Const (@{const_name Cons}, _)$ _ $xs) =   973 (case xs of Const (@{const_name Nil}, _) => cons | _ => last xs)   974 | last (Const(@{const_name append},_)$ _ $ys) = last ys   975 | last t = t;   976   977 fun list1 (Const(@{const_name Cons},_)$ _ $Const(@{const_name Nil},_)) = true   978 | list1 _ = false;   979   980 fun butlast ((cons as Const(@{const_name Cons},_)$ x) $xs) =   981 (case xs of Const (@{const_name Nil}, _) => xs | _ => cons$ butlast xs)

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

  5871           if c = cons'

  5872           then SOME (t1, t2)

  5873           else NONE

  5874       | dest_cons _ = NONE;

  5875     val (ts, t') = Code_Thingol.unfoldr dest_cons t;

  5876   in case t'

  5877    of IConst { name = c, ... } => if c = nil' then SOME ts else NONE

  5878     | _ => NONE

  5879   end;

  5880

  5881 fun default_list (target_fxy, target_cons) pr fxy t1 t2 =

  5882   Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (

  5883     pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,

  5884     Code_Printer.str target_cons,

  5885     pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2

  5886   );

  5887

  5888 fun add_literal_list target =

  5889   let

  5890     fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =

  5891       case Option.map (cons t1) (implode_list nil' cons' t2)

  5892        of SOME ts =>

  5893             Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)

  5894         | NONE =>

  5895             default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;

  5896   in Code_Target.add_const_syntax target @{const_name Cons}

  5897     (SOME (Code_Printer.complex_const_syntax (2, ([@{const_name Nil}, @{const_name Cons}], pretty))))

  5898   end

  5899

  5900 end;

  5901 *}

  5902

  5903 code_type list

  5904   (SML "_ list")

  5905   (OCaml "_ list")

  5906   (Haskell "![(_)]")

  5907   (Scala "List[(_)]")

  5908

  5909 code_const Nil

  5910   (SML "[]")

  5911   (OCaml "[]")

  5912   (Haskell "[]")

  5913   (Scala "!Nil")

  5914

  5915 code_instance list :: equal

  5916   (Haskell -)

  5917

  5918 code_const "HOL.equal \<Colon> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"

  5919   (Haskell infix 4 "==")

  5920

  5921 code_reserved SML

  5922   list

  5923

  5924 code_reserved OCaml

  5925   list

  5926

  5927 setup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}

  5928

  5929

  5930 subsubsection {* Use convenient predefined operations *}

  5931

  5932 code_const "op @"

  5933   (SML infixr 7 "@")

  5934   (OCaml infixr 6 "@")

  5935   (Haskell infixr 5 "++")

  5936   (Scala infixl 7 "++")

  5937

  5938 code_const map

  5939   (Haskell "map")

  5940

  5941 code_const filter

  5942   (Haskell "filter")

  5943

  5944 code_const concat

  5945   (Haskell "concat")

  5946

  5947 code_const List.maps

  5948   (Haskell "concatMap")

  5949

  5950 code_const rev

  5951   (Haskell "reverse")

  5952

  5953 code_const zip

  5954   (Haskell "zip")

  5955

  5956 code_const List.null

  5957   (Haskell "null")

  5958

  5959 code_const takeWhile

  5960   (Haskell "takeWhile")

  5961

  5962 code_const dropWhile

  5963   (Haskell "dropWhile")

  5964

  5965 code_const list_all

  5966   (Haskell "all")

  5967

  5968 code_const list_ex

  5969   (Haskell "any")

  5970

  5971

  5972 subsubsection {* Implementation of sets by lists *}

  5973

  5974 lemma is_empty_set [code]:

  5975   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"

  5976   by (simp add: Set.is_empty_def null_def)

  5977

  5978 lemma empty_set [code]:

  5979   "{} = set []"

  5980   by simp

  5981

  5982 lemma UNIV_coset [code]:

  5983   "UNIV = List.coset []"

  5984   by simp

  5985

  5986 lemma compl_set [code]:

  5987   "- set xs = List.coset xs"

  5988   by simp

  5989

  5990 lemma compl_coset [code]:

  5991   "- List.coset xs = set xs"

  5992   by simp

  5993

  5994 lemma [code]:

  5995   "x \<in> set xs \<longleftrightarrow> List.member xs x"

  5996   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"

  5997   by (simp_all add: member_def)

  5998

  5999 lemma insert_code [code]:

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

  6001   "insert x (List.coset xs) = List.coset (removeAll x xs)"

  6002   by simp_all

  6003

  6004 lemma remove_code [code]:

  6005   "Set.remove x (set xs) = set (removeAll x xs)"

  6006   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"

  6007   by (simp_all add: remove_def Compl_insert)

  6008

  6009 lemma filter_set [code]:

  6010   "Set.filter P (set xs) = set (filter P xs)"

  6011   by auto

  6012

  6013 lemma image_set [code]:

  6014   "image f (set xs) = set (map f xs)"

  6015   by simp

  6016

  6017 lemma subset_code [code]:

  6018   "set xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> B)"

  6019   "A \<le> List.coset ys \<longleftrightarrow> (\<forall>y\<in>set ys. y \<notin> A)"

  6020   "List.coset [] \<le> set [] \<longleftrightarrow> False"

  6021   by auto

  6022

  6023 text {* A frequent case – avoid intermediate sets *}

  6024 lemma [code_unfold]:

  6025   "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"

  6026   by (auto simp: list_all_iff)

  6027

  6028 lemma Ball_set [code]:

  6029   "Ball (set xs) P \<longleftrightarrow> list_all P xs"

  6030   by (simp add: list_all_iff)

  6031

  6032 lemma Bex_set [code]:

  6033   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"

  6034   by (simp add: list_ex_iff)

  6035

  6036 lemma card_set [code]:

  6037   "card (set xs) = length (remdups xs)"

  6038 proof -

  6039   have "card (set (remdups xs)) = length (remdups xs)"

  6040     by (rule distinct_card) simp

  6041   then show ?thesis by simp

  6042 qed

  6043

  6044 lemma the_elem_set [code]:

  6045   "the_elem (set [x]) = x"

  6046   by simp

  6047

  6048 lemma Pow_set [code]:

  6049   "Pow (set []) = {{}}"

  6050   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x  A)"

  6051   by (simp_all add: Pow_insert Let_def)

  6052

  6053 lemma setsum_code [code]:

  6054   "setsum f (set xs) = listsum (map f (remdups xs))"

  6055 by (simp add: listsum_distinct_conv_setsum_set)

  6056

  6057 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where

  6058   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"

  6059

  6060 lemma [code]:

  6061   "map_project f (set xs) = set (List.map_filter f xs)"

  6062   by (auto simp add: map_project_def map_filter_def image_def)

  6063

  6064 hide_const (open) map_project

  6065

  6066

  6067 text {* Operations on relations *}

  6068

  6069 lemma product_code [code]:

  6070   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"

  6071   by (auto simp add: Product_Type.product_def)

  6072

  6073 lemma Id_on_set [code]:

  6074   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"

  6075   by (auto simp add: Id_on_def)

  6076

  6077 lemma [code]:

  6078   "R  S = List.map_project (%(x, y). if x : S then Some y else None) R"

  6079 unfolding map_project_def by (auto split: prod.split split_if_asm)

  6080

  6081 lemma trancl_set_ntrancl [code]:

  6082   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"

  6083   by (simp add: finite_trancl_ntranl)

  6084

  6085 lemma set_relcomp [code]:

  6086   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"

  6087   by (auto simp add: Bex_def)

  6088

  6089 lemma wf_set [code]:

  6090   "wf (set xs) = acyclic (set xs)"

  6091   by (simp add: wf_iff_acyclic_if_finite)

  6092

  6093 end

  6094
`