(*  Title:      HOL/List.thy

     Author:     Tobias Nipkow

 *)

 header {* The datatype of finite lists *}

 theory List

 imports Presburger Code_Numeral Quotient Lifting_Set Lifting_Option Lifting_Product

 begin

 datatype_new 'a list =

     Nil    ("[]")

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

 datatype_new_compat list

 -- {* Compatibility *}

 setup {* Sign.mandatory_path "list" *}

 lemmas inducts = list.induct

 lemmas recs = list.rec

 lemmas cases = list.case

 setup {* Sign.parent_path *}

 syntax

   -- {* list Enumeration *}

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

 translations

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

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

 subsection {* Basic list processing functions *}

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

 "hd (x # xs) = x"

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

 "tl [] = []" |

 "tl (x # xs) = xs"

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

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

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

 "butlast []= []" |

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

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

 "set [] = {}" |

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

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

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

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

 "map f [] = []" |

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

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

 append_Nil: "[] @ ys = ys" |

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

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

 "rev [] = []" |

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

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

 "filter P [] = []" |

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

 syntax

   -- {* Special syntax for filter *}

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

 translations

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

 syntax (xsymbols)

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

 syntax (HTML output)

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

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

 fold_Nil:  "fold f [] = id" |

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

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

 foldr_Nil:  "foldr f [] = id" |

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

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

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

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

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

 "concat [] = []" |

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

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

 "listsum xs = foldr plus xs 0"

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

 "list_update [] i v = []" |

 "list_update (x # xs) i v =

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

 nonterminal lupdbinds and lupdbind

 syntax

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

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

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

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

 translations

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

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

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

 "takeWhile P [] = []" |

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

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

 "dropWhile P [] = []" |

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

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

 "zip xs [] = []" |

 zip_Cons: "zip xs (y # ys) =

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

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

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

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

 "product [] _ = []" |

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

 hide_const (open) product

 primrec product_lists :: "'a list list \<Rightarrow> 'a list list" where

 "product_lists [] = [[]]" |

 "product_lists (xs # xss) = concat (map (\<lambda>x. map (Cons x) (product_lists xss)) xs)"

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

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

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

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

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

 hide_const (open) insert

 hide_fact (open) insert_def

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

 "find _ [] = None" |

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

 hide_const (open) find

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

 where

 "those [] = Some []" |

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

   None \<Rightarrow> None

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

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

 "remove1 x [] = []" |

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

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

 "removeAll x [] = []" |

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

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

 "distinct [] \<longleftrightarrow> True" |

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

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

 "remdups [] = []" |

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

 fun remdups_adj :: "'a list \<Rightarrow> 'a list" where

 "remdups_adj [] = []" |

 "remdups_adj [x] = [x]" |

 "remdups_adj (x # y # xs) = (if x = y then remdups_adj (x # xs) else x # remdups_adj (y # xs))"

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

 replicate_0: "replicate 0 x = []" |

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

 text {*

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

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

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

 "length \<equiv> size"

 definition enumerate :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list" where

 enumerate_eq_zip: "enumerate n xs = zip [n..<n + length xs] xs"

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

 "rotate1 [] = []" |

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

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

 "rotate n = rotate1 ^^ n"

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

 "list_all2 P xs ys =

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

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

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

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

 "sublists [] = [[]]" |

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

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

 "n_lists 0 xs = [[]]" |

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

 hide_const (open) n_lists

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

 "splice [] ys = ys" |

 "splice xs [] = xs" |

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

 text{*

 \begin{figure}[htbp]

 \fbox{

 \begin{tabular}{l}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

 @{lemma "enumerate 3 [a,b,c] = [(3,a),(4,b),(5,c)]" by normalization}\\

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

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

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

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

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

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

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

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

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

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

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

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

 @{lemma "remdups_adj [2,2,3,1,1::nat,2,1] = [2,3,1,2,1]" by simp}\\

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

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

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

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

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

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

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

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

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

 @{lemma "sublists [a,b] = [[a, b], [a], [b], []]" by simp}\\

 @{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)}\\

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

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

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

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

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

 \end{tabular}}

 \caption{Characteristic examples}

 \label{fig:Characteristic}

 \end{figure}

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

 that should give an intuitive understanding of the above functions.

 *}

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

 not for efficient implementations. *}

 context linorder

 begin

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

   Nil [iff]: "sorted []"

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

 lemma sorted_single [iff]:

   "sorted [x]"

   by (rule sorted.Cons) auto

 lemma sorted_many:

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

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

 lemma sorted_many_eq [simp, code]:

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

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

 lemma [code]:

   "sorted [] \<longleftrightarrow> True"

   "sorted [x] \<longleftrightarrow> True"

   by simp_all

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

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

 "insort_key f x (y#ys) =

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

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

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

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

 "insort_insert_key f x xs =

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

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

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

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

 end

 subsubsection {* List comprehension *}

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

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

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

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

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

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

 The qualifiers after the dot are

 \begin{description}

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

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

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

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

 \end{description}

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

 misunderstandings, the translation into desugared form is not reversed

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

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

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

 expressions. During proofs, they may become unreadable (and

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

 definitions for the list comprehensions in question.  *}

 nonterminal lc_qual and lc_quals

 syntax

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

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

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

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

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

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

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

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

    translation of [e. p<-xs]

 translations

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

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

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

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

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

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

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

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

 *)

 syntax (xsymbols)

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

 syntax (HTML output)

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

 parse_translation {*

   let

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

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

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

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

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

     fun single x = ConsC $ x $ NilC;

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

       let

         (* FIXME proper name context!? *)

         val x =

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

         val e = if opti then single e else e;

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

         val case2 =

           Syntax.const @{syntax_const "_case1"} $

             Syntax.const @{const_syntax dummy_pattern} $ NilC;

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

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

     fun abs_tr ctxt p e opti =

       (case Term_Position.strip_positions p of

         Free (s, T) =>

           let

             val thy = Proof_Context.theory_of ctxt;

             val s' = Proof_Context.intern_const ctxt s;

           in

             if Sign.declared_const thy s'

             then (pat_tr ctxt p e opti, false)

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

           end

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

     fun lc_tr ctxt [e, Const (@{syntax_const "_lc_test"}, _) $ b, qs] =

           let

             val res =

               (case qs of

                 Const (@{syntax_const "_lc_end"}, _) => single e

               | Const (@{syntax_const "_lc_quals"}, _) $ q $ qs => lc_tr ctxt [e, q, qs]);

           in IfC $ b $ res $ NilC end

       | lc_tr ctxt

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

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

           (case abs_tr ctxt p e true of

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

           | (f, false) => concatC $ (mapC $ f $ es))

       | lc_tr ctxt

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

               Const (@{syntax_const "_lc_quals"}, _) $ q $ qs] =

           let val e' = lc_tr ctxt [e, q, qs];

           in concatC $ (mapC $ (fst (abs_tr ctxt p e' false)) $ es) end;

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

 *}

 ML_val {*

   let

     val read = Syntax.read_term @{context};

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

   in

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

   end;

 *}

 (*

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

 *)

 ML {*

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

    comprehension. *)

 signature LIST_TO_SET_COMPREHENSION =

 sig

   val simproc : Proof.context -> cterm -> thm option

 end

 structure List_to_Set_Comprehension : LIST_TO_SET_COMPREHENSION =

 struct

 (* conversion *)

 fun all_exists_conv cv ctxt ct =

   (case Thm.term_of ct of

     Const (@{const_name HOL.Ex}, _) $ Abs _ =>

       Conv.arg_conv (Conv.abs_conv (all_exists_conv cv o #2) ctxt) ct

   | _ => cv ctxt ct)

 fun all_but_last_exists_conv cv ctxt ct =

   (case Thm.term_of ct of

     Const (@{const_name HOL.Ex}, _) $ Abs (_, _, Const (@{const_name HOL.Ex}, _) $ _) =>

       Conv.arg_conv (Conv.abs_conv (all_but_last_exists_conv cv o #2) ctxt) ct

   | _ => cv ctxt ct)

 fun Collect_conv cv ctxt ct =

   (case Thm.term_of ct of

     Const (@{const_name Set.Collect}, _) $ Abs _ => Conv.arg_conv (Conv.abs_conv cv ctxt) ct

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

 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)

 fun conjunct_assoc_conv ct =

   Conv.try_conv

     (rewr_conv' @{thm conj_assoc} then_conv HOLogic.conj_conv Conv.all_conv conjunct_assoc_conv) ct

 fun right_hand_set_comprehension_conv conv ctxt =

   HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv

     (Collect_conv (all_exists_conv conv o #2) ctxt))

 (* term abstraction of list comprehension patterns *)

 datatype termlets = If | Case of (typ * int)

 fun simproc ctxt redex =

   let

     val set_Nil_I = @{thm trans} OF [@{thm set.simps(1)}, @{thm empty_def}]

     val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}

     val inst_Collect_mem_eq = @{lemma "set A = {x. x : set A}" by simp}

     val del_refl_eq = @{lemma "(t = t & P) == P" by simp}

     fun mk_set T = Const (@{const_name List.set}, HOLogic.listT T --> HOLogic.mk_setT T)

     fun dest_set (Const (@{const_name List.set}, _) $ xs) = xs

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

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

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

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

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

     fun possible_index_of_singleton_case cases =

       let

         fun check (i, case_t) s =

           (case strip_abs_body case_t of

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

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

       in

         fold_index check cases (SOME NONE) |> the_default NONE

       end

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

     fun dest_case case_term =

       let

         val (case_const, args) = strip_comb case_term

       in

         (case try dest_Const case_const of

           SOME (c, T) =>

             (case Ctr_Sugar.ctr_sugar_of_case ctxt c of

               SOME {ctrs, ...} =>

                 (case possible_index_of_singleton_case (fst (split_last args)) of

                   SOME i =>

                     let

                       val constr_names = map (fst o dest_Const) ctrs

                       val (Ts, _) = strip_type T

                       val T' = List.last Ts

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

                 | NONE => NONE)

             | NONE => NONE)

         | NONE => NONE)

       end

     (* returns condition continuing term option *)

     fun dest_if (Const (@{const_name If}, _) $ cond $ then_t $ Const (@{const_name Nil}, _)) =

           SOME (cond, then_t)

       | dest_if _ = NONE

     fun tac _ [] = rtac set_singleton 1 ORELSE rtac inst_Collect_mem_eq 1

       | tac ctxt (If :: cont) =

           Splitter.split_tac [@{thm split_if}] 1

           THEN rtac @{thm conjI} 1

           THEN rtac @{thm impI} 1

           THEN Subgoal.FOCUS (fn {prems, context, ...} =>

             CONVERSION (right_hand_set_comprehension_conv (K

               (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv

                then_conv

                rewr_conv' @{lemma "(True & P) = P" by simp})) context) 1) ctxt 1

           THEN tac ctxt cont

           THEN rtac @{thm impI} 1

           THEN Subgoal.FOCUS (fn {prems, context, ...} =>

               CONVERSION (right_hand_set_comprehension_conv (K

                 (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv

                  then_conv rewr_conv' @{lemma "(False & P) = False" by simp})) context) 1) ctxt 1

           THEN rtac set_Nil_I 1

       | tac ctxt (Case (T, i) :: cont) =

           let

             val SOME {injects, distincts, case_thms, split, ...} =

               Ctr_Sugar.ctr_sugar_of ctxt (fst (dest_Type T))

           in

             (* do case distinction *)

             Splitter.split_tac [split] 1

             THEN EVERY (map_index (fn (i', _) =>

               (if i' < length case_thms - 1 then rtac @{thm conjI} 1 else all_tac)

               THEN REPEAT_DETERM (rtac @{thm allI} 1)

               THEN rtac @{thm impI} 1

               THEN (if i' = i then

                 (* continue recursively *)

                 Subgoal.FOCUS (fn {prems, context, ...} =>

                   CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K

                       ((HOLogic.conj_conv

                         (HOLogic.eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv

                           (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq injects))))

                         Conv.all_conv)

                         then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))

                         then_conv conjunct_assoc_conv)) context

                     then_conv (HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt) =>

                       Conv.repeat_conv

                         (all_but_last_exists_conv

                           (K (rewr_conv'

                             @{lemma "(EX x. x = t & P x) = P t" by simp})) ctxt)) context)))) 1) ctxt 1

                 THEN tac ctxt cont

               else

                 Subgoal.FOCUS (fn {prems, context, ...} =>

                   CONVERSION

                     (right_hand_set_comprehension_conv (K

                       (HOLogic.conj_conv

                         ((HOLogic.eq_conv Conv.all_conv

                           (rewr_conv' (List.last prems))) then_conv

                           (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) distincts)))

                         Conv.all_conv then_conv

                         (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv

                       HOLogic.Trueprop_conv

                         (HOLogic.eq_conv Conv.all_conv

                           (Collect_conv (fn (_, ctxt) =>

                             Conv.repeat_conv

                               (Conv.bottom_conv

                                 (K (rewr_conv'

                                   @{lemma "(EX x. P) = P" by simp})) ctxt)) context))) 1) ctxt 1

                 THEN rtac set_Nil_I 1)) case_thms)

           end

     fun make_inner_eqs bound_vs Tis eqs t =

       (case dest_case t of

         SOME (x, T, i, cont, constr_name) =>

           let

             val (vs, body) = strip_abs (Envir.eta_long (map snd bound_vs) cont)

             val x' = incr_boundvars (length vs) x

             val eqs' = map (incr_boundvars (length vs)) eqs

             val constr_t =

               list_comb

                 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))

             val constr_eq = Const (@{const_name HOL.eq}, T --> T --> @{typ bool}) $ constr_t $ x'

           in

             make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body

           end

       | NONE =>

           (case dest_if t of

             SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont

           | NONE =>

             if eqs = [] then NONE (* no rewriting, nothing to be done *)

             else

               let

                 val Type (@{type_name List.list}, [rT]) = fastype_of1 (map snd bound_vs, t)

                 val pat_eq =

                   (case try dest_singleton_list t of

                     SOME t' =>

                       Const (@{const_name HOL.eq}, rT --> rT --> @{typ bool}) $

                         Bound (length bound_vs) $ t'

                   | NONE =>

                       Const (@{const_name Set.member}, rT --> HOLogic.mk_setT rT --> @{typ bool}) $

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

                 val reverse_bounds = curry subst_bounds

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

                 val eqs' = map reverse_bounds eqs

                 val pat_eq' = reverse_bounds pat_eq

                 val inner_t =

                   fold (fn (_, T) => fn t => HOLogic.exists_const T $ absdummy T t)

                     (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')

                 val lhs = term_of redex

                 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)

                 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))

               in

                 SOME

                   ((Goal.prove ctxt [] [] rewrite_rule_t

                     (fn {context, ...} => tac context (rev Tis))) RS @{thm eq_reflection})

               end))

   in

     make_inner_eqs [] [] [] (dest_set (term_of redex))

   end

 end

 *}

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

 code_datatype set coset

 hide_const (open) coset

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

 lemma not_Cons_self [simp]:

   "xs \<noteq> x # xs"

 by (induct xs) auto

 lemma not_Cons_self2 [simp]:

   "x # xs \<noteq> xs"

 by (rule not_Cons_self [symmetric])

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

 by (induct xs) auto

 lemma tl_Nil: "tl xs = [] \<longleftrightarrow> xs = [] \<or> (EX x. xs = [x])"

 by (cases xs) auto

 lemma Nil_tl: "[] = tl xs \<longleftrightarrow> xs = [] \<or> (EX x. xs = [x])"

 by (cases xs) auto

 lemma length_induct:

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

 by (fact measure_induct)

 lemma list_nonempty_induct [consumes 1, case_names single cons]:

   assumes "xs \<noteq> []"

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

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

   shows "P xs"

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

   case Nil then show ?case by simp

 next

   case (Cons x xs)

   show ?case

   proof (cases xs)

     case Nil

     with single show ?thesis by simp

   next

     case Cons

     show ?thesis

     proof (rule cons)

       from Cons show "xs \<noteq> []" by simp

       with Cons.hyps show "P xs" .

     qed

   qed

 qed

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

   by (auto intro!: inj_onI)

 subsubsection {* @{const length} *}

 text {*

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

   append_eq_append_conv}.

 *}

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (cases xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by auto

 lemma length_Suc_conv:

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

 by (induct xs) auto

 lemma Suc_length_conv:

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

 apply (induct xs, simp, simp)

 apply blast

 done

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

   by (induct xs) auto

 lemma list_induct2 [consumes 1, case_names Nil Cons]:

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

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

    \<Longrightarrow> P xs ys"

 proof (induct xs arbitrary: ys)

   case Nil then show ?case by simp

 next

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

 qed

 lemma list_induct3 [consumes 2, case_names Nil Cons]:

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

    (\<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))

    \<Longrightarrow> P xs ys zs"

 proof (induct xs arbitrary: ys zs)

   case Nil then show ?case by simp

 next

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

     (cases zs, simp_all)

 qed

 lemma list_induct4 [consumes 3, case_names Nil Cons]:

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

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

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

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

 proof (induct xs arbitrary: ys zs ws)

   case Nil then show ?case by simp

 next

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

 qed

 lemma list_induct2': 

   "\<lbrakk> P [] [];

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

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

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

  \<Longrightarrow> P xs ys"

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

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

 by (rule Eq_FalseI) auto

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

 (*

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

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

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

 *)

 let

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

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

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

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

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

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

 val ss = simpset_of @{context};

 fun list_neq ctxt ct =

   let

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

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

     fun prove_neq() =

       let

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

         val size = HOLogic.size_const listT;

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

         val neq_len = HOLogic.mk_Trueprop (HOLogic.Not $ eq_len);

         val thm = Goal.prove ctxt [] [] neq_len

           (K (simp_tac (put_simpset ss ctxt) 1));

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

   in

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

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

     then prove_neq() else NONE

   end;

 in K list_neq end;

 *}

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

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

 lemma append_eq_append_conv [simp]:

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

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

 apply (induct xs arbitrary: ys)

  apply (case_tac ys, simp, force)

 apply (case_tac ys, force, simp)

 done

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

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

 apply (induct xs arbitrary: ys zs ts)

  apply fastforce

 apply(case_tac zs)

  apply simp

 apply fastforce

 done

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

 by simp

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

 by simp

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

 by simp

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

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

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

 using append_same_eq [of "[]"] by auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

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

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

 by (simp split: list.split)

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

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

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

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

 by(cases ys) auto

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

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

 by(cases ys) auto

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

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

 by simp

 lemma Cons_eq_appendI:

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

 by (drule sym) simp

 lemma append_eq_appendI:

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

 by (drule sym) simp

 text {*

 Simplification procedure for all list equalities.

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

 - both lists end in a singleton list,

 - or both lists end in the same list.

 *}

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

   let

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

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

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

       | last t = t;

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

       | list1 _ = false;

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

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

       | butlast ((app as Const (@{const_name append}, _) $ xs) $ ys) = app $ butlast ys

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

     val rearr_ss =

       simpset_of (put_simpset HOL_basic_ss @{context}

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

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

       let

         val lastl = last lhs and lastr = last rhs;

         fun rearr conv =

           let

             val lhs1 = butlast lhs and rhs1 = butlast rhs;

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

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

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

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

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

             val thm = Goal.prove ctxt [] [] eq

               (K (simp_tac (put_simpset rearr_ss ctxt) 1));

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

       in

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

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

         else NONE

       end;

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

 *}

 subsubsection {* @{const map} *}

 lemma hd_map:

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

   by (cases xs) simp_all

 lemma map_tl:

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

   by (cases xs) simp_all

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

 by (induct xs) simp_all

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

 by (rule ext, induct_tac xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 apply(rule ext)

 apply(simp)

 done

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

 by (induct xs) auto

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

 by (induct xs) auto

 lemma map_cong [fundef_cong]:

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

   by simp

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

 by (cases xs) auto

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

 by (cases xs) auto

 lemma map_eq_Cons_conv:

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

 by (cases xs) auto

 lemma Cons_eq_map_conv:

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

 by (cases ys) auto

 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]

 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]

 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]

 lemma ex_map_conv:

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

 by(induct ys, auto simp add: Cons_eq_map_conv)

 lemma map_eq_imp_length_eq:

   assumes "map f xs = map g ys"

   shows "length xs = length ys"

   using assms

 proof (induct ys arbitrary: xs)

   case Nil then show ?case by simp

 next

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

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

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

   with xs show ?case by simp

 qed

 lemma map_inj_on:

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

   ==> xs = ys"

 apply(frule map_eq_imp_length_eq)

 apply(rotate_tac -1)

 apply(induct rule:list_induct2)

  apply simp

 apply(simp)

 apply (blast intro:sym)

 done

 lemma inj_on_map_eq_map:

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

 by(blast dest:map_inj_on)

 lemma map_injective:

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

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

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

 by(blast dest:map_injective)

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

 by (iprover dest: map_injective injD intro: inj_onI)

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

 apply (unfold inj_on_def, clarify)

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

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

 apply blast

 done

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

 by (blast dest: inj_mapD intro: inj_mapI)

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

 apply(rule inj_onI)

 apply(erule map_inj_on)

 apply(blast intro:inj_onI dest:inj_onD)

 done

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

 by (induct xs, auto)

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

 by (induct xs) auto

 lemma map_fst_zip[simp]:

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

 by (induct rule:list_induct2, simp_all)

 lemma map_snd_zip[simp]:

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

 by (induct rule:list_induct2, simp_all)

 enriched_type map: map

 by (simp_all add: id_def)

 declare map.id [simp]

 subsubsection {* @{const rev} *}

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (cases xs) auto

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

 by (cases xs) auto

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

 apply (induct xs arbitrary: ys, force)

 apply (case_tac ys, simp, force)

 done

 lemma inj_on_rev[iff]: "inj_on rev A"

 by(simp add:inj_on_def)

 lemma rev_induct [case_names Nil snoc]:

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

 apply(simplesubst rev_rev_ident[symmetric])

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

 done

 lemma rev_exhaust [case_names Nil snoc]:

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

 by (induct xs rule: rev_induct) auto

 lemmas rev_cases = rev_exhaust

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

 by(rule rev_cases[of xs]) auto

 subsubsection {* @{const set} *}

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

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by(cases xs) auto

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

 by auto

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

 by auto

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

 by (induct xs) auto

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

 by(induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct j) auto

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

 proof (induct xs)

   case Nil thus ?case by simp

 next

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

 qed

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

   by (auto elim: split_list)

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

 proof (induct xs)

   case Nil thus ?case by simp

 next

   case (Cons a xs)

   show ?case

   proof cases

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

   next

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

   qed

 qed

 lemma in_set_conv_decomp_first:

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

   by (auto dest!: split_list_first)

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

 proof (induct xs rule: rev_induct)

   case Nil thus ?case by simp

 next

   case (snoc a xs)

   show ?case

   proof cases

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

   next

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

   qed

 qed

 lemma in_set_conv_decomp_last:

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

   by (auto dest!: split_list_last)

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

 proof (induct xs)

   case Nil thus ?case by simp

 next

   case Cons thus ?case

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

 qed

 lemma split_list_propE:

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

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

 using split_list_prop [OF assms] by blast

 lemma split_list_first_prop:

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

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

 proof (induct xs)

   case Nil thus ?case by simp

 next

   case (Cons x xs)

   show ?case

   proof cases

     assume "P x"

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

   next

     assume "\<not> P x"

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

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

   qed

 qed

 lemma split_list_first_propE:

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

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

 using split_list_first_prop [OF assms] by blast

 lemma split_list_first_prop_iff:

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

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

 by (rule, erule split_list_first_prop) auto

 lemma split_list_last_prop:

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

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

 proof(induct xs rule:rev_induct)

   case Nil thus ?case by simp

 next

   case (snoc x xs)

   show ?case

   proof cases

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

   next

     assume "\<not> P x"

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

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

   qed

 qed

 lemma split_list_last_propE:

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

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

 using split_list_last_prop [OF assms] by blast

 lemma split_list_last_prop_iff:

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

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

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

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

   by (erule finite_induct)

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

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

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

 lemma set_minus_filter_out:

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

   by (induct xs) auto

 subsubsection {* @{const filter} *}

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

 by (induct xs) auto

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

 by (induct xs) simp_all

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

 by (induct xs) auto

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

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

 lemma sum_length_filter_compl:

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

 by(induct xs) simp_all

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) simp_all

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

 apply (induct xs)

  apply auto

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

 apply simp

 done

 lemma filter_map:

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

 by (induct xs) simp_all

 lemma length_filter_map[simp]:

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

 by (simp add:filter_map)

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

 by auto

 lemma length_filter_less:

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

 proof (induct xs)

   case Nil thus ?case by simp

 next

   case (Cons x xs) thus ?case

     apply (auto split:split_if_asm)

     using length_filter_le[of P xs] apply arith

   done

 qed

 lemma length_filter_conv_card:

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

 proof (induct xs)

   case Nil thus ?case by simp

 next

   case (Cons x xs)

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

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

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

   proof (cases)

     assume "p x"

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

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

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

       using Cons `p x` by simp

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

       by (simp add: card_image)

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

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

     finally show ?thesis .

   next

     assume "\<not> p x"

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

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

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

       using Cons `\<not> p x` by simp

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

       by (simp add: card_image)

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

       by (simp add:card_insert_if)

     finally show ?thesis .

   qed

 qed

 lemma Cons_eq_filterD:

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

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

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

 proof(induct ys)

   case Nil thus ?case by simp

 next

   case (Cons y ys)

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

   proof cases

     assume Py: "P y"

     show ?thesis

     proof cases

       assume "x = y"

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

       then show ?thesis ..

     next

       assume "x \<noteq> y"

       with Py Cons.prems show ?thesis by simp

     qed

   next

     assume "\<not> P y"

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

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

     then show ?thesis ..

   qed

 qed

 lemma filter_eq_ConsD:

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

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

 by(rule Cons_eq_filterD) simp

 lemma filter_eq_Cons_iff:

  "(filter P ys = x#xs) =

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

 by(auto dest:filter_eq_ConsD)

 lemma Cons_eq_filter_iff:

  "(x#xs = filter P ys) =

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

 by(auto dest:Cons_eq_filterD)

 lemma filter_cong[fundef_cong]:

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

 apply simp

 apply(erule thin_rl)

 by (induct ys) simp_all

 subsubsection {* List partitioning *}

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

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

 "partition P (x # xs) = 

   (let (yes, no) = partition P xs

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

 lemma partition_filter1:

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

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

 lemma partition_filter2:

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

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

 lemma partition_P:

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

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

 proof -

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

     by simp_all

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

 qed

 lemma partition_set:

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

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

 proof -

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

     by simp_all

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

 qed

 lemma partition_filter_conv[simp]:

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

 unfolding partition_filter2[symmetric]

 unfolding partition_filter1[symmetric] by simp

 declare partition.simps[simp del]

 subsubsection {* @{const concat} *}

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

 by (induct xs) auto

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

 by (induct xss) auto

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

 by (induct xss) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 proof (induct xs arbitrary: ys)

   case (Cons x xs ys)

   thus ?case by (cases ys) auto

 qed (auto)

 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"

 by (simp add: concat_eq_concat_iff)

 subsubsection {* @{const nth} *}

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

 by auto

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

 by auto

 declare nth.simps [simp del]

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

 by(auto simp: Nat.gr0_conv_Suc)

 lemma nth_append:

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

 apply (induct xs arbitrary: n, simp)

 apply (case_tac n, auto)

 done

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 apply (induct xs arbitrary: n, simp)

 apply (case_tac n, auto)

 done

 lemma nth_tl:

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

 using assms by (induct x) auto

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

 by(cases xs) simp_all

 lemma list_eq_iff_nth_eq:

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

 apply(induct xs arbitrary: ys)

  apply force

 apply(case_tac ys)

  apply simp

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

 done

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

 apply (induct xs, simp, simp)

 apply safe

 apply (metis nat_case_0 nth.simps zero_less_Suc)

 apply (metis less_Suc_eq_0_disj nth_Cons_Suc)

 apply (case_tac i, simp)

 apply (metis diff_Suc_Suc nat_case_Suc nth.simps zero_less_diff)

 done

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

 by(auto simp:set_conv_nth)

 lemma nth_equal_first_eq:

   assumes "x \<notin> set xs"

   assumes "n \<le> length xs"

   shows "(x # xs) ! n = x \<longleftrightarrow> n = 0" (is "?lhs \<longleftrightarrow> ?rhs")

 proof

   assume ?lhs

   show ?rhs

   proof (rule ccontr)

     assume "n \<noteq> 0"

     then have "n > 0" by simp

     with `?lhs` have "xs ! (n - 1) = x" by simp

     moreover from `n > 0` `n \<le> length xs` have "n - 1 < length xs" by simp

     ultimately have "\<exists>i<length xs. xs ! i = x" by auto

     with `x \<notin> set xs` in_set_conv_nth [of x xs] show False by simp

   qed

 next

   assume ?rhs then show ?lhs by simp

 qed

 lemma nth_non_equal_first_eq:

   assumes "x \<noteq> y"

   shows "(x # xs) ! n = y \<longleftrightarrow> xs ! (n - 1) = y \<and> n > 0" (is "?lhs \<longleftrightarrow> ?rhs")

 proof

   assume "?lhs" with assms have "n > 0" by (cases n) simp_all

   with `?lhs` show ?rhs by simp

 next

   assume "?rhs" then show "?lhs" by simp

 qed

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

 by (auto simp add: set_conv_nth)

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

 by (auto simp add: set_conv_nth)

 lemma all_nth_imp_all_set:

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

 by (auto simp add: set_conv_nth)

 lemma all_set_conv_all_nth:

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

 by (auto simp add: set_conv_nth)

 lemma rev_nth:

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

 proof (induct xs arbitrary: n)

   case Nil thus ?case by simp

 next

   case (Cons x xs)

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

   moreover

   { assume "n < length xs"

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

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

     moreover

     from n' have "length xs - Suc n = n'" by simp

     ultimately

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

   }

   ultimately

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

 qed

 lemma Skolem_list_nth:

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

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

 proof(induct k)

   case 0 show ?case by simp

 next

   case (Suc k)

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

   proof

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

   next

     assume "?L"

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

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

     thus "?R" ..

   qed

 qed

 subsubsection {* @{const list_update} *}

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

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

 lemma nth_list_update:

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

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

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

 by (simp add: nth_list_update)

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

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

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

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

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

 apply (induct xs arbitrary: i)

  apply simp

 apply (case_tac i)

 apply simp_all

 done

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

 by(metis length_0_conv length_list_update)

 lemma list_update_same_conv:

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

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

 lemma list_update_append1:

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

 apply (induct xs arbitrary: i, simp)

 apply(simp split:nat.split)

 done

 lemma list_update_append:

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

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

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

 lemma list_update_length [simp]:

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

 by (induct xs, auto)

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

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

 lemma rev_update:

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

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

 lemma update_zip:

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

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

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

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

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

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

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

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

 lemma list_update_overwrite[simp]:

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

 apply (induct xs arbitrary: i) apply simp

 apply (case_tac i, simp_all)

 done

 lemma list_update_swap:

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

 apply (induct xs arbitrary: i i')

 apply simp

 apply (case_tac i, case_tac i')

 apply auto

 apply (case_tac i')

 apply auto

 done

 lemma list_update_code [code]:

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

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

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

   by simp_all

 subsubsection {* @{const last} and @{const butlast} *}

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

 by (induct xs) auto

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

 by (induct xs) auto

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

   by simp

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

   by simp

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

 by (induct xs) (auto)

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

 by(simp add:last_append)

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

 by(simp add:last_append)

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

 by (induct xs) simp_all

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

 by (induct xs) simp_all

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

 by(rule rev_exhaust[of xs]) simp_all

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

 by(cases xs) simp_all

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

 by (induct as) auto

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

 by (induct xs rule: rev_induct) auto

 lemma butlast_append:

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

 by (induct xs arbitrary: ys) auto

 lemma append_butlast_last_id [simp]:

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

 by (induct xs) auto

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

 by (induct xs) (auto split: split_if_asm)

 lemma in_set_butlast_appendI:

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

 by (auto dest: in_set_butlastD simp add: butlast_append)

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

 apply (induct xs arbitrary: n)

  apply simp

 apply (auto split:nat.split)

 done

 lemma nth_butlast:

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

 proof (cases xs)

   case (Cons y ys)

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

     by (simp add: nth_append)

   ultimately show ?thesis using append_butlast_last_id by simp

 qed simp

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

 by(induct xs)(auto simp:neq_Nil_conv)

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

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

 lemma last_list_update:

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

 by (auto simp: last_conv_nth)

 lemma butlast_list_update:

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

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

 apply(cases xs rule:rev_cases)

 apply simp

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

 done

 lemma last_map:

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

   by (cases xs rule: rev_cases) simp_all

 lemma map_butlast:

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

   by (induct xs) simp_all

 lemma snoc_eq_iff_butlast:

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

 by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

 subsubsection {* @{const take} and @{const drop} *}

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by simp

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

 by simp

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

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

   unfolding One_nat_def by simp

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

   unfolding One_nat_def by simp

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

 by(clarsimp simp add:neq_Nil_conv)

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

 by(cases xs, simp_all)

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

 by (induct xs arbitrary: n) simp_all

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

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

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

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

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

 by (simp only: drop_tl)

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

 apply (induct xs arbitrary: n, simp)

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

 done

 lemma take_Suc_conv_app_nth:

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

 apply (induct xs arbitrary: i, simp)

 apply (case_tac i, auto)

 done

 lemma drop_Suc_conv_tl:

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

 apply (induct xs arbitrary: i, simp)

 apply (case_tac i, auto)

 done

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

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

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

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

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

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

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

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

 lemma take_append [simp]:

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

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

 lemma drop_append [simp]:

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

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

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

 apply (induct m arbitrary: xs n, auto)

 apply (case_tac xs, auto)

 apply (case_tac n, auto)

 done

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

 apply (induct m arbitrary: xs, auto)

 apply (case_tac xs, auto)

 done

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

 apply (induct m arbitrary: xs n, auto)

 apply (case_tac xs, auto)

 done

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

 apply(induct xs arbitrary: m n)

  apply simp

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

 done

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

 apply (induct n arbitrary: xs, auto)

 apply (case_tac xs, auto)

 done

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

 apply(induct xs arbitrary: n)

  apply simp

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

 done

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

 apply(induct xs arbitrary: n)

 apply simp

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

 done

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

 apply (induct n arbitrary: xs, auto)

 apply (case_tac xs, auto)

 done

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

 apply (induct n arbitrary: xs, auto)

 apply (case_tac xs, auto)

 done

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

 apply (induct xs arbitrary: i, auto)

 apply (case_tac i, auto)

 done

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

 apply (induct xs arbitrary: i, auto)

 apply (case_tac i, auto)

 done

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

 apply (induct xs arbitrary: i n, auto)

 apply (case_tac n, blast)

 apply (case_tac i, auto)

 done

 lemma nth_drop [simp]:

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

 apply (induct n arbitrary: xs i, auto)

 apply (case_tac xs, auto)

 done

 lemma butlast_take:

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

 by (simp add: butlast_conv_take min.absorb1 min.absorb2)

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

 by (simp add: butlast_conv_take drop_take add_ac)

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

 by (simp add: butlast_conv_take min.absorb1)

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

 by (simp add: butlast_conv_take drop_take add_ac)

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

 by(simp add: hd_conv_nth)

 lemma set_take_subset_set_take:

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

 apply (induct xs arbitrary: m n)

 apply simp

 apply (case_tac n)

 apply (auto simp: take_Cons)

 done

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

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

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

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

 lemma set_drop_subset_set_drop:

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

 apply(induct xs arbitrary: m n)

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

 apply (metis set_drop_subset subset_iff)

 done

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

 using set_take_subset by fast

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

 using set_drop_subset by fast

 lemma append_eq_conv_conj:

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

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

 apply (case_tac zs, auto)

 done

 lemma take_add: 

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

 apply (induct xs arbitrary: i, auto) 

 apply (case_tac i, simp_all)

 done

 lemma append_eq_append_conv_if:

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

   (if size xs\<^sub>1 \<le> size ys\<^sub>1

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

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

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

  apply simp

 apply(case_tac ys\<^sub>1)

 apply simp_all

 done

 lemma take_hd_drop:

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

 apply(induct xs arbitrary: n)

 apply simp

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

 done

 lemma id_take_nth_drop:

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

 proof -

   assume si: "i < length xs"

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

   moreover

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

     apply (rule_tac take_Suc_conv_app_nth) by arith

   ultimately show ?thesis by auto

 qed

 lemma upd_conv_take_nth_drop:

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

 proof -

   assume i: "i < length xs"

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

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

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

     using i by (simp add: list_update_append)

   finally show ?thesis .

 qed

 lemma nth_drop':

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

 apply (induct i arbitrary: xs)

 apply (simp add: neq_Nil_conv)

 apply (erule exE)+

 apply simp

 apply (case_tac xs)

 apply simp_all

 done

 subsubsection {* @{const takeWhile} and @{const dropWhile} *}

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

   by (induct xs) auto

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

 by (induct xs) auto

 lemma takeWhile_append1 [simp]:

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

 by (induct xs) auto

 lemma takeWhile_append2 [simp]:

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

 by (induct xs) auto

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

 by (induct xs) auto

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

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

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

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

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

 by (induct xs) auto

 lemma dropWhile_append1 [simp]:

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

 by (induct xs) auto

 lemma dropWhile_append2 [simp]:

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

 by (induct xs) auto

 lemma dropWhile_append3:

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

 by (induct xs) auto

 lemma dropWhile_last:

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

 by (auto simp add: dropWhile_append3 in_set_conv_decomp)

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

 by (induct xs) (auto split: split_if_asm)

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

 by (induct xs) (auto split: split_if_asm)

 lemma takeWhile_eq_all_conv[simp]:

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

 by(induct xs, auto)

 lemma dropWhile_eq_Nil_conv[simp]:

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

 by(induct xs, auto)

 lemma dropWhile_eq_Cons_conv:

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

 by(induct xs, auto)

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

 by (induct xs) (auto dest: set_takeWhileD)

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

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

 by (induct xs) auto

 lemma hd_dropWhile:

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

 using assms by (induct xs) auto

 lemma takeWhile_eq_filter:

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

   shows "takeWhile P xs = filter P xs"

 proof -

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

     by simp

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

     unfolding filter_empty_conv using assms by blast

   have "filter P xs = takeWhile P xs"

     unfolding A filter_append B

     by (auto simp add: filter_id_conv dest: set_takeWhileD)

   thus ?thesis ..

 qed

 lemma takeWhile_eq_take_P_nth:

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

   takeWhile P xs = take n xs"

 proof (induct xs arbitrary: n)

   case (Cons x xs)

   thus ?case

   proof (cases n)

     case (Suc n') note this[simp]

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

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

     proof (rule Cons.hyps)

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

     next case goal2 thus ?case using Cons by auto

     qed

     ultimately show ?thesis by simp

    qed simp

 qed simp

 lemma nth_length_takeWhile:

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

 by (induct xs) auto

 lemma length_takeWhile_less_P_nth:

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

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

 proof (rule classical)

   assume "\<not> ?thesis"

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

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

 qed

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

 property. *}

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

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

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

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

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

 apply(induct xs)

  apply simp

 apply auto

 apply(subst dropWhile_append2)

 apply auto

 done

 lemma takeWhile_not_last:

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

 apply(induct xs)

  apply simp

 apply(case_tac xs)

 apply(auto)

 done

 lemma takeWhile_cong [fundef_cong]:

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

   ==> takeWhile P l = takeWhile Q k"

 by (induct k arbitrary: l) (simp_all)

 lemma dropWhile_cong [fundef_cong]:

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

   ==> dropWhile P l = dropWhile Q k"

 by (induct k arbitrary: l, simp_all)

 lemma takeWhile_idem [simp]:

   "takeWhile P (takeWhile P xs) = takeWhile P xs"

   by (induct xs) auto

 lemma dropWhile_idem [simp]:

   "dropWhile P (dropWhile P xs) = dropWhile P xs"

   by (induct xs) auto

 subsubsection {* @{const zip} *}

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

 by (induct ys) auto

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

 by simp

 declare zip_Cons [simp del]

 lemma [code]:

   "zip [] ys = []"

   "zip xs [] = []"

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

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

 lemma zip_Cons1:

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

 by(auto split:list.split)

 lemma length_zip [simp]:

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

 by (induct xs ys rule:list_induct2') auto

 lemma zip_obtain_same_length:

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

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

   shows "P (zip xs ys)"

 proof -

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

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

     by (rule assms) simp_all

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

   proof (induct xs arbitrary: ys)

     case Nil then show ?case by simp

   next

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

   qed

   ultimately show ?thesis by simp

 qed

 lemma zip_append1:

 "zip (xs @ ys) zs =

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

 by (induct xs zs rule:list_induct2') auto

 lemma zip_append2:

 "zip xs (ys @ zs) =

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

 by (induct xs ys rule:list_induct2') auto

 lemma zip_append [simp]:

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

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

 by (simp add: zip_append1)

 lemma zip_rev:

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

 by (induct rule:list_induct2, simp_all)

 lemma zip_map_map:

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

 proof (induct xs arbitrary: ys)

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

   show ?case

   proof (cases ys)

     case (Cons y ys')

     show ?thesis unfolding Cons using Cons_x_xs by simp

   qed simp

 qed simp

 lemma zip_map1:

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

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

 lemma zip_map2:

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

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

 lemma map_zip_map:

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

 unfolding zip_map1 by auto

 lemma map_zip_map2:

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

 unfolding zip_map2 by auto

 text{* Courtesy of Andreas Lochbihler: *}

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

 by(induct xs) auto

 lemma nth_zip [simp]:

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

 apply (induct ys arbitrary: i xs, simp)

 apply (case_tac xs)

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

 done

 lemma set_zip:

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

 by(simp add: set_conv_nth cong: rev_conj_cong)

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

 by(induct xs) auto

 lemma zip_update:

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

 by(rule sym, simp add: update_zip)

 lemma zip_replicate [simp]:

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

 apply (induct i arbitrary: j, auto)

 apply (case_tac j, auto)

 done

 lemma take_zip:

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

 apply (induct n arbitrary: xs ys)

  apply simp

 apply (case_tac xs, simp)

 apply (case_tac ys, simp_all)

 done

 lemma drop_zip:

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

 apply (induct n arbitrary: xs ys)

  apply simp

 apply (case_tac xs, simp)

 apply (case_tac ys, simp_all)

 done

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

 proof (induct xs arbitrary: ys)

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

 qed simp

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

 proof (induct xs arbitrary: ys)

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

 qed simp

 lemma set_zip_leftD:

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

 by (induct xs ys rule:list_induct2') auto

 lemma set_zip_rightD:

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

 by (induct xs ys rule:list_induct2') auto

 lemma in_set_zipE:

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

 by(blast dest: set_zip_leftD set_zip_rightD)

 lemma zip_map_fst_snd:

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

   by (induct zs) simp_all

 lemma zip_eq_conv:

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

   by (auto simp add: zip_map_fst_snd)

 lemma in_set_zip:

   "p \<in> set (zip xs ys) \<longleftrightarrow> (\<exists>n. xs ! n = fst p \<and> ys ! n = snd p

     \<and> n < length xs \<and> n < length ys)"

   by (cases p) (auto simp add: set_zip)

 lemma pair_list_eqI:

   assumes "map fst xs = map fst ys" and "map snd xs = map snd ys"

   shows "xs = ys"

 proof -

   from assms(1) have "length xs = length ys" by (rule map_eq_imp_length_eq)

   from this assms show ?thesis

     by (induct xs ys rule: list_induct2) (simp_all add: prod_eqI)

 qed

 subsubsection {* @{const list_all2} *}

 lemma list_all2_lengthD [intro?]: 

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

 by (simp add: list_all2_def)

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

 by (simp add: list_all2_def)

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

 by (simp add: list_all2_def)

 lemma list_all2_Cons [iff, code]:

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

 by (auto simp add: list_all2_def)

 lemma list_all2_Cons1:

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

 by (cases ys) auto

 lemma list_all2_Cons2:

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

 by (cases xs) auto

 lemma list_all2_induct

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

   assumes P: "list_all2 P xs ys"

   assumes Nil: "R [] []"

   assumes Cons: "\<And>x xs y ys.

     \<lbrakk>P x y; list_all2 P xs ys; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"

   shows "R xs ys"

 using P

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

 lemma list_all2_rev [iff]:

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

 by (simp add: list_all2_def zip_rev cong: conj_cong)

 lemma list_all2_rev1:

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

 by (subst list_all2_rev [symmetric]) simp

 lemma list_all2_append1:

 "list_all2 P (xs @ ys) zs =

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

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

 apply (simp add: list_all2_def zip_append1)

 apply (rule iffI)

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

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

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

 apply (simp add: ball_Un)

 done

 lemma list_all2_append2:

 "list_all2 P xs (ys @ zs) =

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

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

 apply (simp add: list_all2_def zip_append2)

 apply (rule iffI)

  apply (rule_tac x = "take (length ys) xs" in exI)

  apply (rule_tac x = "drop (length ys) xs" in exI)

  apply (force split: nat_diff_split simp add: min_def, clarify)

 apply (simp add: ball_Un)

 done

 lemma list_all2_append:

   "length xs = length ys \<Longrightarrow>

   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"

 by (induct rule:list_induct2, simp_all)

 lemma list_all2_appendI [intro?, trans]:

   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"

 by (simp add: list_all2_append list_all2_lengthD)

 lemma list_all2_conv_all_nth:

 "list_all2 P xs ys =

 (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"

 by (force simp add: list_all2_def set_zip)

 lemma list_all2_trans:

   assumes tr: "!!a b c. P1 a b ==> P2 b c ==> P3 a c"

   shows "!!bs cs. list_all2 P1 as bs ==> list_all2 P2 bs cs ==> list_all2 P3 as cs"

         (is "!!bs cs. PROP ?Q as bs cs")

 proof (induct as)

   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"

   show "!!cs. PROP ?Q (x # xs) bs cs"

   proof (induct bs)

     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"

     show "PROP ?Q (x # xs) (y # ys) cs"

       by (induct cs) (auto intro: tr I1 I2)

   qed simp

 qed simp

 lemma list_all2_all_nthI [intro?]:

   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"

 by (simp add: list_all2_conv_all_nth)

 lemma list_all2I:

   "\<forall>x \<in> set (zip a b). split P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"

 by (simp add: list_all2_def)

 lemma list_all2_nthD:

   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

 by (simp add: list_all2_conv_all_nth)

 lemma list_all2_nthD2:

   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"

 by (frule list_all2_lengthD) (auto intro: list_all2_nthD)

 lemma list_all2_map1: 

   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"

 by (simp add: list_all2_conv_all_nth)

 lemma list_all2_map2: 

   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"

 by (auto simp add: list_all2_conv_all_nth)

 lemma list_all2_refl [intro?]:

   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"