# Theory List

Up to index of Isabelle/HOL-Proofs

theory List
imports Presburger Code_Numeral
(*  Title:      HOL/List.thy    Author:     Tobias Nipkow*)header {* The datatype of finite lists *}theory Listimports Plain Presburger Code_Numeral Quotient ATPbegindatatype 'a list =    Nil    ("[]")  | Cons 'a  "'a list"    (infixr "#" 65)syntax  -- {* list Enumeration *}  "_list" :: "args => 'a list"    ("[(_)]")translations  "[x, xs]" == "x#[xs]"  "[x]" == "x#[]"subsection {* Basic list processing functions *}primrec hd :: "'a list => 'a" where"hd (x # xs) = x"primrec tl :: "'a list => 'a list" where"tl [] = []" |"tl (x # xs) = xs"primrec last :: "'a list => 'a" where"last (x # xs) = (if xs = [] then x else last xs)"primrec butlast :: "'a list => 'a list" where"butlast []= []" |"butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"primrec set :: "'a list => 'a set" where"set [] = {}" |"set (x # xs) = insert x (set xs)"definition coset :: "'a list => 'a set" where[simp]: "coset xs = - set xs"primrec map :: "('a => 'b) => 'a list => 'b list" where"map f [] = []" |"map f (x # xs) = f x # map f xs"primrec append :: "'a list => 'a list => 'a list" (infixr "@" 65) whereappend_Nil: "[] @ ys = ys" |append_Cons: "(x#xs) @ ys = x # xs @ ys"primrec rev :: "'a list => 'a list" where"rev [] = []" |"rev (x # xs) = rev xs @ [x]"primrec filter:: "('a => bool) => 'a list => '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 => 'b => 'b) => 'a list => 'b => 'b" wherefold_Nil:  "fold f [] = id" |fold_Cons: "fold f (x # xs) = fold f xs o f x"primrec foldr :: "('a => 'b => 'b) => 'a list => 'b => 'b" wherefoldr_Nil:  "foldr f [] = id" |foldr_Cons: "foldr f (x # xs) = f x o foldr f xs"primrec foldl :: "('b => 'a => 'b) => 'b => 'a list => 'b" wherefoldl_Nil:  "foldl f a [] = a" |foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"primrec concat:: "'a list list => 'a list" where"concat [] = []" |"concat (x # xs) = x @ concat xs"definition (in monoid_add) listsum :: "'a list => 'a" where"listsum xs = foldr plus xs 0"primrec drop:: "nat => 'a list => 'a list" wheredrop_Nil: "drop n [] = []" |drop_Cons: "drop n (x # xs) = (case n of 0 => x # xs | Suc m => 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 => 'a list => 'a list" wheretake_Nil:"take n [] = []" |take_Cons: "take n (x # xs) = (case n of 0 => [] | Suc m => 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) wherenth_Cons: "(x # xs) ! n = (case n of 0 => x | Suc k => 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 => nat => 'a => 'a list" where"list_update [] i v = []" |"list_update (x # xs) i v =  (case i of 0 => v # xs | Suc j => x # list_update xs j v)"nonterminal lupdbinds and lupdbindsyntax  "_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 => bool) => 'a list => 'a list" where"takeWhile P [] = []" |"takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"primrec dropWhile :: "('a => bool) => 'a list => 'a list" where"dropWhile P [] = []" |"dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"primrec zip :: "'a list => 'b list => ('a × '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 => 'b list => ('a × 'b) list" where"product [] _ = []" |"product (x#xs) ys = map (Pair x) ys @ product xs ys"hide_const (open) productprimrec upt :: "nat => nat => nat list" ("(1[_..</_'])") whereupt_0: "[i..<0] = []" |upt_Suc: "[i..<(Suc j)] = (if i <= j then [i..<j] @ [j] else [])"definition insert :: "'a => 'a list => 'a list" where"insert x xs = (if x ∈ set xs then xs else x # xs)"hide_const (open) inserthide_fact (open) insert_defprimrec find :: "('a => bool) => 'a list => 'a option" where"find _ [] = None" |"find P (x#xs) = (if P x then Some x else find P xs)"hide_const (open) findprimrec remove1 :: "'a => 'a list => 'a list" where"remove1 x [] = []" |"remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"primrec removeAll :: "'a => 'a list => '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 => bool" where"distinct [] <-> True" |"distinct (x # xs) <-> x ∉ set xs ∧ distinct xs"primrec remdups :: "'a list => 'a list" where"remdups [] = []" |"remdups (x # xs) = (if x ∈ set xs then remdups xs else x # remdups xs)"primrec replicate :: "nat => 'a => 'a list" wherereplicate_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 => nat" where"length ≡ size"primrec rotate1 :: "'a list => 'a list" where"rotate1 [] = []" |"rotate1 (x # xs) = xs @ [x]"definition rotate :: "nat => 'a list => 'a list" where"rotate n = rotate1 ^^ n"definition list_all2 :: "('a => 'b => bool) => 'a list => 'b list => bool" where"list_all2 P xs ys =  (length xs = length ys ∧ (∀(x, y) ∈ set (zip xs ys). P x y))"definition sublist :: "'a list => nat set => 'a list" where"sublist xs A = map fst (filter (λp. snd p ∈ A) (zip xs [0..<size xs]))"primrec sublists :: "'a list => 'a list list" where"sublists [] = [[]]" |"sublists (x#xs) = (let xss = sublists xs in map (Cons x) xss @ xss)"primrec n_lists :: "nat => 'a list => 'a list list" where"n_lists 0 xs = [[]]" |"n_lists (Suc n) xs = concat (map (λys. map (λy. y # ys) xs) (n_lists n xs))"hide_const (open) n_listsfun splice :: "'a list => 'a list => '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 (λ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 "List.product [a,b] [c,d] = [(a, c), (a, d), (b, c), (b, d)]" 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 "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 examplesthat should give an intuitive understanding of the above functions.*}text{* The following simple sort functions are intended for proofs,not for efficient implementations. *}context linorderbegininductive sorted :: "'a list => bool" where  Nil [iff]: "sorted []"| Cons: "∀y∈set xs. x ≤ y ==> sorted xs ==> sorted (x # xs)"lemma sorted_single [iff]:  "sorted [x]"  by (rule sorted.Cons) autolemma sorted_many:  "x ≤ y ==> sorted (y # zs) ==> 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) <-> x ≤ y ∧ sorted (y # zs)"  by (auto intro: sorted_many elim: sorted.cases)lemma [code]:  "sorted [] <-> True"  "sorted [x] <-> True"  by simp_allprimrec insort_key :: "('b => 'a) => 'b => 'b list => 'b list" where"insort_key f x [] = [x]" |"insort_key f x (y#ys) =  (if f x ≤ f y then (x#y#ys) else y#(insort_key f x ys))"definition sort_key :: "('b => 'a) => 'b list => 'b list" where"sort_key f xs = foldr (insort_key f) xs []"definition insort_insert_key :: "('b => 'a) => 'b => 'b list => 'b list" where"insort_insert_key f x xs =  (if f x ∈ f  set xs then xs else insort_key f x xs)"abbreviation "sort ≡ sort_key (λx. x)"abbreviation "insort ≡ insort_key (λx. x)"abbreviation "insort_insert ≡ insort_insert_key (λx. x)"endsubsubsection {* List comprehension *}text{* Input syntax for Haskell-like list comprehension notation.Typical example: @{text"[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x ≠ 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, …]"} 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 avoidmisunderstandings, the translation into desugared form is not reversedupon output. Note that the translation of @{text"[e. x \<leftarrow> xs]"} isoptmized to @{term"map (%x. e) xs"}.It is easy to write short list comprehensions which stand for complexexpressions. During proofs, they may become unreadable (andmangled). In such cases it can be advisable to introduce separatedefinitions for the list comprehensions in question.  *}nonterminal lc_qual and lc_qualssyntax  "_listcompr" :: "'a => lc_qual => lc_quals => 'a list"  ("[_ . __")  "_lc_gen" :: "'a => 'a list => lc_qual"  ("_ <- _")  "_lc_test" :: "bool => lc_qual" ("_")  (*"_lc_let" :: "letbinds => lc_qual"  ("let _")*)  "_lc_end" :: "lc_quals" ("]")  "_lc_quals" :: "lc_qual => lc_quals => 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 => 'a list => lc_qual"  ("_ \<leftarrow> _")syntax (HTML output)  "_lc_gen" :: "'a => 'a list => lc_qual"  ("_ \<leftarrow> _")parse_translation (advanced) {*  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, Datatype_Case.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 {*  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 (λx. (x, y, z)) xs";    check "[e x y. x\<leftarrow>xs, y\<leftarrow>ys]" "concat (map (λx. map (λ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 (λx. if b < x then [(x, y, z)] else []) xs)";    check "[(x,y,z). x<a, x\<leftarrow>xs]" "if x < a then map (λx. (x, y, z)) xs else []";    check "[(x,y). Cons True x \<leftarrow> xs]"      "concat (map (λxa. case xa of [] => [] | True # x => [(x, y)] | False # x => []) xs)";    check "[(x,y,z). Cons x [] \<leftarrow> xs]"      "concat (map (λxa. case xa of [] => [] | [x] => [(x, y, z)] | x # aa # lista => []) 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 (λy. (x, y, z)) ys else [] else []";    check "[(x,y,z). x<a, x\<leftarrow>xs,y>b]"      "if x < a then concat (map (λ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 (λx. map (λy. (x, y, z)) ys) xs) else []";    check "[(x,y,z). x\<leftarrow>xs, x>b, y<a]"      "concat (map (λ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 (λx. if b < x then map (λy. (x, y, z)) ys else []) xs)";    check "[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x]"      "concat (map (λx. concat (map (λ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 (λx. concat (map (λy. map (λz. (x, y, z)) zs) ys)) xs)"  end;*}(*term "[(x,y). x\<leftarrow>xs, let xx = x+x, y\<leftarrow>ys, y ≠ xx]"*)ML {*(* Simproc for rewriting list comprehensions applied to List.set to set   comprehension. *)signature LIST_TO_SET_COMPREHENSION =sig  val simproc : simpset -> cterm -> thm optionendstructure 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 Trueprop_conv cv ct =  (case Thm.term_of ct of    Const (@{const_name Trueprop}, _) $_ => Conv.arg_conv cv ct | _ => raise CTERM ("Trueprop_conv", [ct]))fun eq_conv cv1 cv2 ct = (case Thm.term_of ct of Const (@{const_name HOL.eq}, _)$ _ $_ => Conv.combination_conv (Conv.arg_conv cv1) cv2 ct | _ => raise CTERM ("eq_conv", [ct]))fun conj_conv cv1 cv2 ct = (case Thm.term_of ct of Const (@{const_name HOL.conj}, _)$ _ $_ => Conv.combination_conv (Conv.arg_conv cv1) cv2 ct | _ => raise CTERM ("conj_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 conj_conv Conv.all_conv conjunct_assoc_conv) ctfun right_hand_set_comprehension_conv conv ctxt = Trueprop_conv (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 ss redex = let val ctxt = Simplifier.the_context ss val thy = Proof_Context.theory_of ctxt 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 NONE => SOME i | SOME _ => NONE))      in        fold_index check cases NONE      end    (* returns (case_expr type index chosen_case) 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 Datatype.info_of_case thy c of              SOME _ =>                (case possible_index_of_singleton_case (fst (split_last args)) of                  SOME i =>                    let                      val (Ts, _) = strip_type T                      val T' = List.last Ts                    in SOME (List.last args, T', i, nth args 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 (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 (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 info = Datatype.the_info thy (fst (dest_Type T)) in (* do case distinction *) Splitter.split_tac [#split info] 1 THEN EVERY (map_index (fn (i', _) => (if i' < length (#case_rewrites info) - 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 ((conj_conv (eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq (#inject info))))) Conv.all_conv) then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq)) then_conv conjunct_assoc_conv)) context then_conv (Trueprop_conv (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 (conj_conv ((eq_conv Conv.all_conv (rewr_conv' (List.last prems))) then_conv (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) (#distinct info)))) Conv.all_conv then_conv (rewr_conv' @{lemma "(False & P) = False" by simp}))) context then_conv Trueprop_conv (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_rewrites info)) end fun make_inner_eqs bound_vs Tis eqs t = (case dest_case t of SOME (x, T, i, cont) => let val (vs, body) = strip_abs (Pattern.eta_long (map snd bound_vs) cont) val x' = incr_boundvars (length vs) x val eqs' = map (incr_boundvars (length vs)) eqs val (constr_name, _) = nth (the (Datatype.get_constrs thy (fst (dest_Type T)))) i 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)) endend*}simproc_setup list_to_set_comprehension ("set xs") = {* K List_to_Set_Comprehension.simproc *}code_datatype set cosethide_const (open) cosetsubsubsection {* @{const Nil} and @{const Cons} *}lemma not_Cons_self [simp]: "xs ≠ x # xs"by (induct xs) autolemma not_Cons_self2 [simp]: "x # xs ≠ xs"by (rule not_Cons_self [symmetric])lemma neq_Nil_conv: "(xs ≠ []) = (∃y ys. xs = y # ys)"by (induct xs) autolemma length_induct: "(!!xs. ∀ys. length ys < length xs --> P ys ==> P xs) ==> P xs"by (rule measure_induct [of length]) iproverlemma list_nonempty_induct [consumes 1, case_names single cons]: assumes "xs ≠ []" assumes single: "!!x. P [x]" assumes cons: "!!x xs. xs ≠ [] ==> P xs ==> P (x # xs)" shows "P xs"using xs ≠ [] proof (induct xs) case Nil then show ?case by simpnext case (Cons x xs) show ?case proof (cases xs) case Nil with single show ?thesis by simp next case Cons then have "xs ≠ []" by simp moreover with Cons.hyps have "P xs" . ultimately show ?thesis by (rule cons) qedqedlemma inj_split_Cons: "inj_on (λ(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) autolemma length_map [simp]: "length (map f xs) = length xs"by (induct xs) autolemma length_rev [simp]: "length (rev xs) = length xs"by (induct xs) autolemma length_tl [simp]: "length (tl xs) = length xs - 1"by (cases xs) autolemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"by (induct xs) autolemma length_greater_0_conv [iff]: "(0 < length xs) = (xs ≠ [])"by (induct xs) autolemma length_pos_if_in_set: "x : set xs ==> length xs > 0"by autolemma length_Suc_conv:"(length xs = Suc n) = (∃y ys. xs = y # ys ∧ length ys = n)"by (induct xs) autolemma Suc_length_conv:"(Suc n = length xs) = (∃y ys. xs = y # ys ∧ length ys = n)"apply (induct xs, simp, simp)apply blastdonelemma impossible_Cons: "length xs <= length ys ==> xs = x # ys = False" by (induct xs) autolemma list_induct2 [consumes 1, case_names Nil Cons]: "length xs = length ys ==> P [] [] ==> (!!x xs y ys. length xs = length ys ==> P xs ys ==> P (x#xs) (y#ys)) ==> P xs ys"proof (induct xs arbitrary: ys) case Nil then show ?case by simpnext case (Cons x xs ys) then show ?case by (cases ys) simp_allqedlemma list_induct3 [consumes 2, case_names Nil Cons]: "length xs = length ys ==> length ys = length zs ==> P [] [] [] ==> (!!x xs y ys z zs. length xs = length ys ==> length ys = length zs ==> P xs ys zs ==> P (x#xs) (y#ys) (z#zs)) ==> P xs ys zs"proof (induct xs arbitrary: ys zs) case Nil then show ?case by simpnext case (Cons x xs ys zs) then show ?case by (cases ys, simp_all) (cases zs, simp_all)qedlemma list_induct4 [consumes 3, case_names Nil Cons]: "length xs = length ys ==> length ys = length zs ==> length zs = length ws ==> P [] [] [] [] ==> (!!x xs y ys z zs w ws. length xs = length ys ==> length ys = length zs ==> length zs = length ws ==> P xs ys zs ws ==> P (x#xs) (y#ys) (z#zs) (w#ws)) ==> P xs ys zs ws"proof (induct xs arbitrary: ys zs ws) case Nil then show ?case by simpnext case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)qedlemma list_induct2': "[| P [] []; !!x xs. P (x#xs) []; !!y ys. P [] (y#ys); !!x xs y ys. P xs ys ==> P (x#xs) (y#ys) |] ==> P xs ys"by (induct xs arbitrary: ys) (case_tac x, auto)+lemma neq_if_length_neq: "length xs ≠ length ys ==> (xs = ys) == False"by (rule Eq_FalseI) autosimproc_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 submultisetof those of the other list and there are fewer Cons's in one than the other.*)letfun 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);fun list_neq _ ss 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 (Simplifier.the_context ss) [] [] neq_len (K (simp_tac (Simplifier.inherit_context ss @{simpset}) 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 list_neq end;*}subsubsection {* @{text "@"} -- append *}lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"by (induct xs) autolemma append_Nil2 [simp]: "xs @ [] = xs"by (induct xs) autolemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] ∧ ys = [])"by (induct xs) autolemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] ∧ ys = [])"by (induct xs) autolemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"by (induct xs) autolemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"by (induct xs) autolemma append_eq_append_conv [simp, no_atp]: "length xs = length ys ∨ length us = length vs ==> (xs@us = ys@vs) = (xs=ys ∧ us=vs)"apply (induct xs arbitrary: ys) apply (case_tac ys, simp, force)apply (case_tac ys, force, simp)donelemma 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 fastforceapply(case_tac zs) apply simpapply fastforcedonelemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"by simplemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys ∧ x = y)"by simplemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"by simplemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"using append_same_eq [of _ _ "[]"] by autolemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"using append_same_eq [of "[]"] by autolemma hd_Cons_tl [simp,no_atp]: "xs ≠ [] ==> hd xs # tl xs = xs"by (induct xs) autolemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"by (induct xs) autolemma hd_append2 [simp]: "xs ≠ [] ==> 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 ≠ [] ==> 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) autolemma append_eq_Cons_conv: "(ys@zs = x#xs) = (ys = [] & zs = x#xs | (EX ys'. ys = x#ys' & ys'@zs = xs))"by(cases ys) autotext {* Trivial rules for solving @{text "@"}-equations automatically. *}lemma eq_Nil_appendI: "xs = ys ==> xs = [] @ ys"by simplemma Cons_eq_appendI:"[| x # xs1 = ys; xs = xs1 @ zs |] ==> x # xs = ys @ zs"by (drule sym) simplemma append_eq_appendI:"[| xs @ xs1 = zs; ys = xs1 @ us |] ==> xs @ ys = zs @ us"by (drule sym) simptext {*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 = HOL_basic_ss addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}]; fun list_eq ss (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 (Simplifier.the_context ss) [] [] eq (K (simp_tac (Simplifier.inherit_context ss rearr_ss) 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 ss => fn ct => list_eq ss (term_of ct) end;*}subsubsection {* @{const map} *}lemma hd_map: "xs ≠ [] ==> hd (map f xs) = f (hd xs)" by (cases xs) simp_alllemma map_tl: "map f (tl xs) = tl (map f xs)" by (cases xs) simp_alllemma map_ext: "(!!x. x : set xs --> f x = g x) ==> map f xs = map g xs"by (induct xs) simp_alllemma map_ident [simp]: "map (λx. x) = (λxs. xs)"by (rule ext, induct_tac xs) autolemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"by (induct xs) autolemma map_map [simp]: "map f (map g xs) = map (f o g) xs"by (induct xs) autolemma map_comp_map[simp]: "((map f) o (map g)) = map(f o g)"apply(rule ext)apply(simp)donelemma rev_map: "rev (map f xs) = map f (rev xs)"by (induct xs) autolemma map_eq_conv[simp]: "(map f xs = map g xs) = (!x : set xs. f x = g x)"by (induct xs) autolemma map_cong [fundef_cong]: "xs = ys ==> (!!x. x ∈ set ys ==> f x = g x) ==> map f xs = map g ys" by simplemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"by (cases xs) autolemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"by (cases xs) autolemma map_eq_Cons_conv: "(map f xs = y#ys) = (∃z zs. xs = z#zs ∧ f z = y ∧ map f zs = ys)"by (cases xs) autolemma Cons_eq_map_conv: "(x#xs = map f ys) = (∃z zs. ys = z#zs ∧ x = f z ∧ xs = map f zs)"by (cases ys) autolemmas 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 simpnext 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 moreover with Cons have "length zs = length ys" by blast with xs show ?case by simpqed 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 simpapply(simp)apply (blast intro:sym)donelemma inj_on_map_eq_map: "inj_on f (set xs Un set ys) ==> (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 ==> (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 blastdonelemma 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)) ==> inj_on (map f) A"apply(rule inj_onI)apply(erule map_inj_on)apply(blast intro:inj_onI dest:inj_onD)donelemma map_idI: "(!!x. x ∈ set xs ==> f x = x) ==> map f xs = xs"by (induct xs, auto)lemma map_fun_upd [simp]: "y ∉ set xs ==> map (f(y:=v)) xs = map f xs"by (induct xs) autolemma map_fst_zip[simp]: "length xs = length ys ==> map fst (zip xs ys) = xs"by (induct rule:list_induct2, simp_all)lemma map_snd_zip[simp]: "length xs = length ys ==> map snd (zip xs ys) = ys"by (induct rule:list_induct2, simp_all)enriched_type map: mapby (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) autolemma rev_rev_ident [simp]: "rev (rev xs) = xs"by (induct xs) autolemma rev_swap: "(rev xs = ys) = (xs = rev ys)"by autolemma rev_is_Nil_conv [iff]: "(rev xs = []) = (xs = [])"by (induct xs) autolemma Nil_is_rev_conv [iff]: "([] = rev xs) = (xs = [])"by (induct xs) autolemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"by (cases xs) autolemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"by (cases xs) autolemma rev_is_rev_conv [iff, no_atp]: "(rev xs = rev ys) = (xs = ys)"apply (induct xs arbitrary: ys, force)apply (case_tac ys, simp, force)donelemma 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)donelemma rev_exhaust [case_names Nil snoc]: "(xs = [] ==> P) ==>(!!ys y. xs = ys @ [y] ==> P) ==> P"by (induct xs rule: rev_induct) autolemmas rev_cases = rev_exhaustlemma rev_eq_Cons_iff[iff]: "(rev xs = y#ys) = (xs = rev ys @ [y])"by(rule rev_cases[of xs]) autosubsubsection {* @{const set} *}declare set.simps [code_post] --"pretty output"lemma finite_set [iff]: "finite (set xs)"by (induct xs) autolemma set_append [simp]: "set (xs @ ys) = (set xs ∪ set ys)"by (induct xs) autolemma hd_in_set[simp]: "xs ≠ [] ==> hd xs : set xs"by(cases xs) autolemma set_subset_Cons: "set xs ⊆ set (x # xs)"by autolemma set_ConsD: "y ∈ set (x # xs) ==> y=x ∨ y ∈ set xs" by autolemma set_empty [iff]: "(set xs = {}) = (xs = [])"by (induct xs) autolemma set_empty2[iff]: "({} = set xs) = (xs = [])"by(induct xs) autolemma set_rev [simp]: "set (rev xs) = set xs"by (induct xs) autolemma set_map [simp]: "set (map f xs) = f(set xs)"by (induct xs) autolemma set_filter [simp]: "set (filter P xs) = {x. x : set xs ∧ P x}"by (induct xs) autolemma set_upt [simp]: "set[i..<j] = {i..<j}"by (induct j) autolemma split_list: "x : set xs ==> ∃ys zs. xs = ys @ x # zs"proof (induct xs) case Nil thus ?case by simpnext case Cons thus ?case by (auto intro: Cons_eq_appendI)qedlemma in_set_conv_decomp: "x ∈ set xs <-> (∃ys zs. xs = ys @ x # zs)" by (auto elim: split_list)lemma split_list_first: "x : set xs ==> ∃ys zs. xs = ys @ x # zs ∧ x ∉ set ys"proof (induct xs) case Nil thus ?case by simpnext case (Cons a xs) show ?case proof cases assume "x = a" thus ?case using Cons by fastforce next assume "x ≠ a" thus ?case using Cons by(fastforce intro!: Cons_eq_appendI) qedqedlemma in_set_conv_decomp_first: "(x : set xs) = (∃ys zs. xs = ys @ x # zs ∧ x ∉ set ys)" by (auto dest!: split_list_first)lemma split_list_last: "x ∈ set xs ==> ∃ys zs. xs = ys @ x # zs ∧ x ∉ set zs"proof (induct xs rule: rev_induct) case Nil thus ?case by simpnext 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 ≠ a" thus ?case using snoc by fastforce qedqedlemma in_set_conv_decomp_last: "(x : set xs) = (∃ys zs. xs = ys @ x # zs ∧ x ∉ set zs)" by (auto dest!: split_list_last)lemma split_list_prop: "∃x ∈ set xs. P x ==> ∃ys x zs. xs = ys @ x # zs & P x"proof (induct xs) case Nil thus ?case by simpnext case Cons thus ?case by(simp add:Bex_def)(metis append_Cons append.simps(1))qedlemma split_list_propE: assumes "∃x ∈ set xs. P x" obtains ys x zs where "xs = ys @ x # zs" and "P x"using split_list_prop [OF assms] by blastlemma split_list_first_prop: "∃x ∈ set xs. P x ==> ∃ys x zs. xs = ys@x#zs ∧ P x ∧ (∀y ∈ set ys. ¬ P y)"proof (induct xs) case Nil thus ?case by simpnext 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 "¬ P x" hence "∃x∈set xs. P x" using Cons(2) by simp thus ?thesis using ¬ P x Cons(1) by (metis append_Cons set_ConsD) qedqedlemma split_list_first_propE: assumes "∃x ∈ set xs. P x" obtains ys x zs where "xs = ys @ x # zs" and "P x" and "∀y ∈ set ys. ¬ P y"using split_list_first_prop [OF assms] by blastlemma split_list_first_prop_iff: "(∃x ∈ set xs. P x) <-> (∃ys x zs. xs = ys@x#zs ∧ P x ∧ (∀y ∈ set ys. ¬ P y))"by (rule, erule split_list_first_prop) autolemma split_list_last_prop: "∃x ∈ set xs. P x ==> ∃ys x zs. xs = ys@x#zs ∧ P x ∧ (∀z ∈ set zs. ¬ P z)"proof(induct xs rule:rev_induct) case Nil thus ?case by simpnext case (snoc x xs) show ?case proof cases assume "P x" thus ?thesis by (metis emptyE set_empty) next assume "¬ P x" hence "∃x∈set xs. P x" using snoc(2) by simp thus ?thesis using ¬ P x snoc(1) by fastforce qedqedlemma split_list_last_propE: assumes "∃x ∈ set xs. P x" obtains ys x zs where "xs = ys @ x # zs" and "P x" and "∀z ∈ set zs. ¬ P z"using split_list_last_prop [OF assms] by blastlemma split_list_last_prop_iff: "(∃x ∈ set xs. P x) <-> (∃ys x zs. xs = ys@x#zs ∧ P x ∧ (∀z ∈ set zs. ¬ 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) ≤ length xs"by (induct xs) (auto simp add: card_insert_if)lemma set_minus_filter_out: "set xs - {y} = set (filter (λx. ¬ (x = y)) xs)" by (induct xs) autosubsubsection {* @{const filter} *}lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"by (induct xs) autolemma rev_filter: "rev (filter P xs) = filter P (rev xs)"by (induct xs) simp_alllemma filter_filter [simp]: "filter P (filter Q xs) = filter (λx. Q x ∧ P x) xs"by (induct xs) autolemma length_filter_le [simp]: "length (filter P xs) ≤ 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_alllemma filter_True [simp]: "∀x ∈ set xs. P x ==> filter P xs = xs"by (induct xs) autolemma filter_False [simp]: "∀x ∈ set xs. ¬ P x ==> filter P xs = []"by (induct xs) autolemma filter_empty_conv: "(filter P xs = []) = (∀x∈set xs. ¬ P x)" by (induct xs) simp_alllemma filter_id_conv: "(filter P xs = xs) = (∀x∈set xs. P x)"apply (induct xs) apply autoapply(cut_tac P=P and xs=xs in length_filter_le)apply simpdonelemma filter_map: "filter P (map f xs) = map f (filter (P o f) xs)"by (induct xs) simp_alllemma 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) ≤ set xs"by autolemma length_filter_less: "[| x : set xs; ~ P x |] ==> length(filter P xs) < length xs"proof (induct xs) case Nil thus ?case by simpnext case (Cons x xs) thus ?case apply (auto split:split_if_asm) using length_filter_le[of P xs] apply arith doneqedlemma length_filter_conv_card: "length(filter p xs) = card{i. i < length xs & p(xs!i)}"proof (induct xs) case Nil thus ?case by simpnext 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 "… = Suc(card(Suc  ?S))" using fin by (simp add: card_image) also have "… = card ?S'" using eq fin by (simp add:card_insert_if) (simp add:image_def) finally show ?thesis . next assume "¬ 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 ¬ p x by simp also have "… = card(Suc  ?S)" using fin by (simp add: card_image) also have "… = card ?S'" using eq fin by (simp add:card_insert_if) finally show ?thesis . qedqedlemma Cons_eq_filterD: "x#xs = filter P ys ==> ∃us vs. ys = us @ x # vs ∧ (∀u∈set us. ¬ P u) ∧ P x ∧ xs = filter P vs" (is "_ ==> ∃us vs. ?P ys us vs")proof(induct ys) case Nil thus ?case by simpnext case (Cons y ys) show ?case (is "∃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 ≠ y" with Py Cons.prems show ?thesis by simp qed next assume "¬ 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 .. qedqedlemma filter_eq_ConsD: "filter P ys = x#xs ==> ∃us vs. ys = us @ x # vs ∧ (∀u∈set us. ¬ P u) ∧ P x ∧ xs = filter P vs"by(rule Cons_eq_filterD) simplemma filter_eq_Cons_iff: "(filter P ys = x#xs) = (∃us vs. ys = us @ x # vs ∧ (∀u∈set us. ¬ P u) ∧ P x ∧ xs = filter P vs)"by(auto dest:filter_eq_ConsD)lemma Cons_eq_filter_iff: "(x#xs = filter P ys) = (∃us vs. ys = us @ x # vs ∧ (∀u∈set us. ¬ P u) ∧ P x ∧ xs = filter P vs)"by(auto dest:Cons_eq_filterD)lemma filter_cong[fundef_cong]: "xs = ys ==> (!!x. x ∈ set ys ==> P x = Q x) ==> filter P xs = filter Q ys"apply simpapply(erule thin_rl)by (induct ys) simp_allsubsubsection {* List partitioning *}primrec partition :: "('a => bool) =>'a list => 'a list × '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 "(∀p ∈ set yes. P p) ∧ (∀p ∈ set no. ¬ 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)qedlemma partition_set: assumes "partition P xs = (yes, no)" shows "set yes ∪ 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) qedlemma partition_filter_conv[simp]: "partition f xs = (filter f xs,filter (Not o f) xs)"unfolding partition_filter2[symmetric]unfolding partition_filter1[symmetric] by simpdeclare partition.simps[simp del]subsubsection {* @{const concat} *}lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"by (induct xs) autolemma concat_eq_Nil_conv [simp]: "(concat xss = []) = (∀xs ∈ set xss. xs = [])"by (induct xss) autolemma Nil_eq_concat_conv [simp]: "([] = concat xss) = (∀xs ∈ set xss. xs = [])"by (induct xss) autolemma set_concat [simp]: "set (concat xs) = (UN x:set xs. set x)"by (induct xs) autolemma concat_map_singleton[simp]: "concat(map (%x. [f x]) xs) = map f xs"by (induct xs) autolemma map_concat: "map f (concat xs) = concat (map (map f) xs)"by (induct xs) autolemma filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"by (induct xs) autolemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"by (induct xs) autolemma concat_eq_concat_iff: "∀(x, y) ∈ 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) autoqed (auto)lemma concat_injective: "concat xs = concat ys ==> length xs = length ys ==> ∀(x, y) ∈ 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 autolemma nth_Cons_Suc [simp, code]: "(x # xs)!(Suc n) = xs!n"by autodeclare nth.simps [simp del]lemma nth_Cons_pos[simp]: "0 < n ==> (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)donelemma nth_append_length [simp]: "(xs @ x # ys) ! length xs = x"by (induct xs) autolemma nth_append_length_plus[simp]: "(xs @ ys) ! (length xs + n) = ys ! n"by (induct xs) autolemma nth_map [simp]: "n < length xs ==> (map f xs)!n = f(xs!n)"apply (induct xs arbitrary: n, simp)apply (case_tac n, auto)donelemma nth_tl: assumes "n < length (tl x)" shows "tl x ! n = x ! Suc n"using assms by (induct x) autolemma hd_conv_nth: "xs ≠ [] ==> hd xs = xs!0"by(cases xs) simp_alllemma list_eq_iff_nth_eq: "(xs = ys) = (length xs = length ys ∧ (ALL i<length xs. xs!i = ys!i))"apply(induct xs arbitrary: ys) apply forceapply(case_tac ys) apply simpapply(simp add:nth_Cons split:nat.split)apply blastdonelemma set_conv_nth: "set xs = {xs!i | i. i < length xs}"apply (induct xs, simp, simp)apply safeapply (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)donelemma in_set_conv_nth: "(x ∈ set xs) = (∃i < length xs. xs!i = x)"by(auto simp:set_conv_nth)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:"(∀x ∈ set xs. P x) = (∀i. i < length xs --> P (xs ! i))"by (auto simp add: set_conv_nth)lemma rev_nth: "n < size xs ==> rev xs ! n = xs ! (length xs - Suc n)"proof (induct xs arbitrary: n) case Nil thus ?case by simpnext case (Cons x xs) hence n: "n < Suc (length xs)" by simp moreover { assume "n < length xs" with n obtain n' where "length xs - n = Suc n'" by (cases "length xs - n", auto) moreover then 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)qedlemma 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 simpnext 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" .. qedqedsubsubsection {* @{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 ≠ 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 ≤ i ==> xs[i:=x] = xs"apply (induct xs arbitrary: i) apply simpapply (case_tac i)apply simp_alldonelemma list_update_nonempty[simp]: "xs[k:=x] = [] <-> 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 ==> (xs @ ys)[i:=x] = xs[i:=x] @ ys"apply (induct xs arbitrary: i, simp)apply(simp split:nat.split)donelemma 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 ==> 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 ==> x ∈ 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 simpapply (case_tac i, simp_all)donelemma list_update_swap: "i ≠ i' ==> xs [i := x, i' := x'] = xs [i' := x', i := x]"apply (induct xs arbitrary: i i')apply simpapply (case_tac i, case_tac i')apply autoapply (case_tac i')apply autodonelemma list_update_code [code]: "[][i := y] = []" "(x # xs)[0 := y] = y # xs" "(x # xs)[Suc i := y] = x # xs[i := y]" by simp_allsubsubsection {* @{const last} and @{const butlast} *}lemma last_snoc [simp]: "last (xs @ [x]) = x"by (induct xs) autolemma butlast_snoc [simp]: "butlast (xs @ [x]) = xs"by (induct xs) autolemma last_ConsL: "xs = [] ==> last(x#xs) = x" by simplemma last_ConsR: "xs ≠ [] ==> last(x#xs) = last xs" by simplemma last_append: "last(xs @ ys) = (if ys = [] then last xs else last ys)"by (induct xs) (auto)lemma last_appendL[simp]: "ys = [] ==> last(xs @ ys) = last xs"by(simp add:last_append)lemma last_appendR[simp]: "ys ≠ [] ==> last(xs @ ys) = last ys"by(simp add:last_append)lemma last_tl: "xs = [] ∨ tl xs ≠ [] ==>last (tl xs) = last xs"by (induct xs) simp_alllemma butlast_tl: "butlast (tl xs) = tl (butlast xs)"by (induct xs) simp_alllemma hd_rev: "xs ≠ [] ==> hd(rev xs) = last xs"by(rule rev_exhaust[of xs]) simp_alllemma last_rev: "xs ≠ [] ==> last(rev xs) = hd xs"by(cases xs) simp_alllemma last_in_set[simp]: "as ≠ [] ==> last as ∈ set as"by (induct as) autolemma length_butlast [simp]: "length (butlast xs) = length xs - 1"by (induct xs rule: rev_induct) autolemma butlast_append: "butlast (xs @ ys) = (if ys = [] then butlast xs else xs @ butlast ys)"by (induct xs arbitrary: ys) autolemma append_butlast_last_id [simp]:"xs ≠ [] ==> butlast xs @ [last xs] = xs"by (induct xs) autolemma 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 ==> last (drop n xs) = last xs"apply (induct xs arbitrary: n) apply simpapply (auto split:nat.split)donelemma 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 simpqed simplemma last_conv_nth: "xs≠[] ==> 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 ≠ [] ==> 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 simpapply(simp add:list_update_append split:nat.splits)donelemma last_map: "xs ≠ [] ==> last (map f xs) = f (last xs)" by (cases xs rule: rev_cases) simp_alllemma map_butlast: "map f (butlast xs) = butlast (map f xs)" by (induct xs) simp_alllemma snoc_eq_iff_butlast: "xs @ [x] = ys <-> (ys ≠ [] & 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) autolemma drop_0 [simp]: "drop 0 xs = xs"by (induct xs) autolemma take_Suc_Cons [simp]: "take (Suc n) (x # xs) = x # take n xs"by simplemma drop_Suc_Cons [simp]: "drop (Suc n) (x # xs) = drop n xs"by simpdeclare take_Cons [simp del] and drop_Cons [simp del]lemma take_1_Cons [simp]: "take 1 (x # xs) = [x]" unfolding One_nat_def by simplemma drop_1_Cons [simp]: "drop 1 (x # xs) = xs" unfolding One_nat_def by simplemma 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_alllemma 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 ==> xs!n = y"apply (induct xs arbitrary: n, simp)apply(simp add:drop_Cons nth_Cons split:nat.splits)donelemma take_Suc_conv_app_nth: "i < length xs ==> take (Suc i) xs = take i xs @ [xs!i]"apply (induct xs arbitrary: i, simp)apply (case_tac i, auto)donelemma drop_Suc_conv_tl: "i < length xs ==> (xs!i) # (drop (Suc i) xs) = drop i xs"apply (induct xs arbitrary: i, simp)apply (case_tac i, auto)donelemma 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)donelemma drop_drop [simp]: "drop n (drop m xs) = drop (n + m) xs"apply (induct m arbitrary: xs, auto)apply (case_tac xs, auto)donelemma 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)donelemma drop_take: "drop n (take m xs) = take (m-n) (drop n xs)"apply(induct xs arbitrary: m n) apply simpapply(simp add: take_Cons drop_Cons split:nat.split)donelemma append_take_drop_id [simp]: "take n xs @ drop n xs = xs"apply (induct n arbitrary: xs, auto)apply (case_tac xs, auto)donelemma take_eq_Nil[simp]: "(take n xs = []) = (n = 0 ∨ xs = [])"apply(induct xs arbitrary: n) apply simpapply(simp add:take_Cons split:nat.split)donelemma drop_eq_Nil[simp]: "(drop n xs = []) = (length xs <= n)"apply(induct xs arbitrary: n)apply simpapply(simp add:drop_Cons split:nat.split)donelemma take_map: "take n (map f xs) = map f (take n xs)"apply (induct n arbitrary: xs, auto)apply (case_tac xs, auto)donelemma drop_map: "drop n (map f xs) = map f (drop n xs)"apply (induct n arbitrary: xs, auto)apply (case_tac xs, auto)donelemma rev_take: "rev (take i xs) = drop (length xs - i) (rev xs)"apply (induct xs arbitrary: i, auto)apply (case_tac i, auto)donelemma rev_drop: "rev (drop i xs) = take (length xs - i) (rev xs)"apply (induct xs arbitrary: i, auto)apply (case_tac i, auto)donelemma 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)donelemma 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)donelemma butlast_take: "n <= length xs ==> butlast (take n xs) = take (n - 1) xs"by (simp add: butlast_conv_take min_max.inf_absorb1 min_max.inf_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_max.inf_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 ==> hd(drop n xs) = xs!n"by(simp add: hd_conv_nth)lemma set_take_subset_set_take: "m <= n ==> set(take m xs) <= set(take n xs)"apply (induct xs arbitrary: m n)apply simpapply (case_tac n)apply (auto simp: take_Cons)donelemma set_take_subset: "set(take n xs) ⊆ set xs"by(induct xs arbitrary: n)(auto simp:take_Cons split:nat.split)lemma set_drop_subset: "set(drop n xs) ⊆ set xs"by(induct xs arbitrary: n)(auto simp:drop_Cons split:nat.split)lemma set_drop_subset_set_drop: "m >= n ==> 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)donelemma in_set_takeD: "x : set(take n xs) ==> x : set xs"using set_take_subset by fastlemma in_set_dropD: "x : set(drop n xs) ==> x : set xs"using set_drop_subset by fastlemma append_eq_conv_conj: "(xs @ ys = zs) = (xs = take (length xs) zs ∧ ys = drop (length xs) zs)"apply (induct xs arbitrary: zs, simp, clarsimp)apply (case_tac zs, auto)donelemma 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)donelemma append_eq_append_conv_if: "(xs⇣1 @ xs⇣2 = ys⇣1 @ ys⇣2) = (if size xs⇣1 ≤ size ys⇣1 then xs⇣1 = take (size xs⇣1) ys⇣1 ∧ xs⇣2 = drop (size xs⇣1) ys⇣1 @ ys⇣2 else take (size ys⇣1) xs⇣1 = ys⇣1 ∧ drop (size ys⇣1) xs⇣1 @ xs⇣2 = ys⇣2)"apply(induct xs⇣1 arbitrary: ys⇣1) apply simpapply(case_tac ys⇣1)apply simp_alldonelemma take_hd_drop: "n < length xs ==> take n xs @ [hd (drop n xs)] = take (Suc n) xs"apply(induct xs arbitrary: n)apply simpapply(simp add:drop_Cons split:nat.split)donelemma id_take_nth_drop: "i < length xs ==> 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 autoqed lemma upd_conv_take_nth_drop: "i < length xs ==> 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 "… = take i xs @ a # drop (Suc i) xs" using i by (simp add: list_update_append) finally show ?thesis .qedlemma nth_drop': "i < length xs ==> xs ! i # drop (Suc i) xs = drop i xs"apply (induct i arbitrary: xs)apply (simp add: neq_Nil_conv)apply (erule exE)+apply simpapply (case_tac xs)apply simp_alldonesubsubsection {* @{const takeWhile} and @{const dropWhile} *}lemma length_takeWhile_le: "length (takeWhile P xs) ≤ length xs" by (induct xs) autolemma takeWhile_dropWhile_id [simp]: "takeWhile P xs @ dropWhile P xs = xs"by (induct xs) autolemma takeWhile_append1 [simp]:"[| x:set xs; ~P(x)|] ==> takeWhile P (xs @ ys) = takeWhile P xs"by (induct xs) autolemma takeWhile_append2 [simp]:"(!!x. x : set xs ==> P x) ==> takeWhile P (xs @ ys) = xs @ takeWhile P ys"by (induct xs) autolemma takeWhile_tail: "¬ P x ==> takeWhile P (xs @ (x#l)) = takeWhile P xs"by (induct xs) autolemma takeWhile_nth: "j < length (takeWhile P xs) ==> takeWhile P xs ! j = xs ! j"apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by autolemma dropWhile_nth: "j < length (dropWhile P xs) ==> dropWhile P xs ! j = xs ! (j + length (takeWhile P xs))"apply (subst (3) takeWhile_dropWhile_id[symmetric]) unfolding nth_append by autolemma length_dropWhile_le: "length (dropWhile P xs) ≤ length xs"by (induct xs) autolemma dropWhile_append1 [simp]:"[| x : set xs; ~P(x)|] ==> dropWhile P (xs @ ys) = (dropWhile P xs)@ys"by (induct xs) autolemma dropWhile_append2 [simp]:"(!!x. x:set xs ==> P(x)) ==> dropWhile P (xs @ ys) = dropWhile P ys"by (induct xs) autolemma dropWhile_append3: "¬ P y ==>dropWhile P (xs @ y # ys) = dropWhile P xs @ y # ys"by (induct xs) autolemma dropWhile_last: "x ∈ set xs ==> ¬ P x ==> last (dropWhile P xs) = last xs"by (auto simp add: dropWhile_append3 in_set_conv_decomp)lemma set_dropWhileD: "x ∈ set (dropWhile P xs) ==> x ∈ set xs"by (induct xs) (auto split: split_if_asm)lemma set_takeWhileD: "x : set (takeWhile P xs) ==> x : set xs ∧ P x"by (induct xs) (auto split: split_if_asm)lemma takeWhile_eq_all_conv[simp]: "(takeWhile P xs = xs) = (∀x ∈ set xs. P x)"by(induct xs, auto)lemma dropWhile_eq_Nil_conv[simp]: "(dropWhile P xs = []) = (∀x ∈ set xs. P x)"by(induct xs, auto)lemma dropWhile_eq_Cons_conv: "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys & ¬ 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) autolemma takeWhile_map: "takeWhile P (map f xs) = map f (takeWhile (P o f) xs)"by (induct xs) autolemma dropWhile_map: "dropWhile P (map f xs) = map f (dropWhile (P o f) xs)"by (induct xs) autolemma takeWhile_eq_take: "takeWhile P xs = take (length (takeWhile P xs)) xs"by (induct xs) autolemma dropWhile_eq_drop: "dropWhile P xs = drop (length (takeWhile P xs)) xs"by (induct xs) autolemma hd_dropWhile: "dropWhile P xs ≠ [] ==> ¬ P (hd (dropWhile P xs))"using assms by (induct xs) autolemma takeWhile_eq_filter: assumes "!! x. x ∈ set (dropWhile P xs) ==> ¬ 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 ..qedlemma takeWhile_eq_take_P_nth: "[| !! i. [| i < n ; i < length xs |] ==> P (xs ! i) ; n < length xs ==> ¬ P (xs ! n) |] ==> 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 simpqed simplemma nth_length_takeWhile: "length (takeWhile P xs) < length xs ==> ¬ P (xs ! length (takeWhile P xs))"by (induct xs) autolemma length_takeWhile_less_P_nth: assumes all: "!! i. i < j ==> P (xs ! i)" and "j ≤ length xs" shows "j ≤ length (takeWhile P xs)"proof (rule classical) assume "¬ ?thesis" hence "length (takeWhile P xs) < length xs" using assms by simp thus ?thesis using all ¬ ?thesis nth_length_takeWhile[of P xs] by autoqedtext{* The following two lemmmas could be generalized to an arbitraryproperty. *}lemma takeWhile_neq_rev: "[|distinct xs; x ∈ set xs|] ==> takeWhile (λy. y ≠ x) (rev xs) = rev (tl (dropWhile (λy. y ≠ x) xs))"by(induct xs) (auto simp: takeWhile_tail[where l="[]"])lemma dropWhile_neq_rev: "[|distinct xs; x ∈ set xs|] ==> dropWhile (λy. y ≠ x) (rev xs) = x # rev (takeWhile (λy. y ≠ x) xs)"apply(induct xs) apply simpapply autoapply(subst dropWhile_append2)apply autodonelemma takeWhile_not_last: "distinct xs ==> takeWhile (λy. y ≠ last xs) xs = butlast xs"apply(induct xs) apply simpapply(case_tac xs)apply(auto)donelemma 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)subsubsection {* @{const zip} *}lemma zip_Nil [simp]: "zip [] ys = []"by (induct ys) autolemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"by simpdeclare 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 [] => [] | y#ys => (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') autolemma zip_obtain_same_length: assumes "!!zs ws n. length zs = length ws ==> n = min (length xs) (length ys) ==> zs = take n xs ==> ws = take n ys ==> 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 simpqedlemma 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') autolemma 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') autolemma 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 (λ (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 simpqed simplemma zip_map1: "zip (map f xs) ys = map (λ(x, y). (f x, y)) (zip xs ys)"using zip_map_map[of f xs "λx. x" ys] by simplemma zip_map2: "zip xs (map f ys) = map (λ(x, y). (x, f y)) (zip xs ys)"using zip_map_map[of "λx. x" xs f ys] by simplemma map_zip_map: "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"unfolding zip_map1 by autolemma map_zip_map2: "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"unfolding zip_map2 by autotext{* Courtesy of Andreas Lochbihler: *}lemma zip_same_conv_map: "zip xs xs = map (λx. (x, x)) xs"by(induct xs) autolemma 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)donelemma 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) ∈ set (zip xs xs)) = (a ∈ set xs ∧ a = b)"by(induct xs) autolemma 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)donelemma take_zip: "take n (zip xs ys) = zip (take n xs) (take n ys)"apply (induct n arbitrary: xs ys) apply simpapply (case_tac xs, simp)apply (case_tac ys, simp_all)donelemma drop_zip: "drop n (zip xs ys) = zip (drop n xs) (drop n ys)"apply (induct n arbitrary: xs ys) apply simpapply (case_tac xs, simp)apply (case_tac ys, simp_all)donelemma zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P o fst) (zip xs ys)"proof (induct xs arbitrary: ys) case (Cons x xs) thus ?case by (cases ys) autoqed simplemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P o snd) (zip xs ys)"proof (induct xs arbitrary: ys) case (Cons x xs) thus ?case by (cases ys) autoqed simplemma set_zip_leftD: "(x,y)∈ set (zip xs ys) ==> x ∈ set xs"by (induct xs ys rule:list_induct2') autolemma set_zip_rightD: "(x,y)∈ set (zip xs ys) ==> y ∈ set ys"by (induct xs ys rule:list_induct2') autolemma in_set_zipE: "(x,y) : set(zip xs ys) ==> ([| x : set xs; y : set ys |] ==> R) ==> 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_alllemma zip_eq_conv: "length xs = length ys ==> zip xs ys = zs <-> map fst zs = xs ∧ map snd zs = ys" by (auto simp add: zip_map_fst_snd)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 ∧ list_all2 P xs ys)"by (auto simp add: list_all2_def)lemma list_all2_Cons1:"list_all2 P (x # xs) ys = (∃z zs. ys = z # zs ∧ P x z ∧ list_all2 P xs zs)"by (cases ys) autolemma list_all2_Cons2:"list_all2 P xs (y # ys) = (∃z zs. xs = z # zs ∧ P z y ∧ list_all2 P zs ys)"by (cases xs) autolemma 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: "!!x xs y ys. [|P x y; list_all2 P xs ys; R xs ys|] ==> R (x # xs) (y # ys)" shows "R xs ys"using Pby (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]) simplemma list_all2_append1:"list_all2 P (xs @ ys) zs =(EX us vs. zs = us @ vs ∧ length us = length xs ∧ length vs = length ys ∧list_all2 P xs us ∧ 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)donelemma list_all2_append2:"list_all2 P xs (ys @ zs) =(EX us vs. xs = us @ vs ∧ length us = length ys ∧ length vs = length zs ∧list_all2 P us ys ∧ 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)donelemma list_all2_append: "length xs = length ys ==> list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys ∧ list_all2 P us vs)"by (induct rule:list_induct2, simp_all)lemma list_all2_appendI [intro?, trans]: "[| list_all2 P a b; list_all2 P c d |] ==> 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 ∧ (∀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 simpqed simplemma list_all2_all_nthI [intro?]: "length a = length b ==> (!!n. n < length a ==> P (a!n) (b!n)) ==> list_all2 P a b"by (simp add: list_all2_conv_all_nth)lemma list_all2I: "∀x ∈ set (zip a b). split P x ==> length a = length b ==> list_all2 P a b"by (simp add: list_all2_def)lemma list_all2_nthD: "[| list_all2 P xs ys; p < size xs |] ==> P (xs!p) (ys!p)"by (simp add: list_all2_conv_all_nth)lemma list_all2_nthD2: "[|list_all2 P xs ys; p < size ys|] ==> 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 (λ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 (λx y. P x (f y)) as bs"by (auto simp add: list_all2_conv_all_nth)lemma list_all2_refl [intro?]: "(!!x. P x x) ==> list_all2 P xs xs"by (simp add: list_all2_conv_all_nth)lemma list_all2_update_cong: "[| list_all2 P xs ys; P x y |] ==> list_all2 P (xs[i:=x]) (ys[i:=y])"by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)lemma list_all2_takeI [simp,intro?]: "list_all2 P xs ys ==> list_all2 P (take n xs) (take n ys)"apply (induct xs arbitrary: n ys) apply simpapply (clarsimp simp add: list_all2_Cons1)apply (case_tac n)apply autodonelemma list_all2_dropI [simp,intro?]: "list_all2 P as bs ==> list_all2 P (drop n as) (drop n bs)"apply (induct as arbitrary: n bs, simp)apply (clarsimp simp add: list_all2_Cons1)apply (case_tac n, simp, simp)donelemma list_all2_mono [intro?]: "list_all2 P xs ys ==> (!!xs ys. P xs ys ==> Q xs ys) ==> list_all2 Q xs ys"apply (induct xs arbitrary: ys, simp)apply (case_tac ys, auto)donelemma list_all2_eq: "xs = ys <-> list_all2 (op =) xs ys"by (induct xs ys rule: list_induct2') autolemma list_eq_iff_zip_eq: "xs = ys <-> length xs = length ys ∧ (∀(x,y) ∈ set (zip xs ys). x = y)"by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)subsubsection {* @{const List.product} *}lemma product_list_set: "set (List.product xs ys) = set xs × set ys" by (induct xs) autosubsubsection {* @{const fold} with natural argument order *}lemma fold_simps [code]: -- {* eta-expanded variant for generated code -- enables tail-recursion optimisation in Scala *} "fold f [] s = s" "fold f (x # xs) s = fold f xs (f x s)" by simp_alllemma fold_remove1_split: assumes f: "!!x y. x ∈ set xs ==> y ∈ set xs ==> f x o f y = f y o f x" and x: "x ∈ set xs" shows "fold f xs = fold f (remove1 x xs) o f x" using assms by (induct xs) (auto simp add: comp_assoc)lemma fold_cong [fundef_cong]: "a = b ==> xs = ys ==> (!!x. x ∈ set xs ==> f x = g x) ==> fold f xs a = fold g ys b" by (induct ys arbitrary: a b xs) simp_alllemma fold_id: assumes "!!x. x ∈ set xs ==> f x = id" shows "fold f xs = id" using assms by (induct xs) simp_alllemma fold_commute: assumes "!!x. x ∈ set xs ==> h o g x = f x o h" shows "h o fold g xs = fold f xs o h" using assms by (induct xs) (simp_all add: fun_eq_iff)lemma fold_commute_apply: assumes "!!x. x ∈ set xs ==> h o g x = f x o h" shows "h (fold g xs s) = fold f xs (h s)"proof - from assms have "h o fold g xs = fold f xs o h" by (rule fold_commute) then show ?thesis by (simp add: fun_eq_iff)qedlemma fold_invariant: assumes "!!x. x ∈ set xs ==> Q x" and "P s" and "!!x s. Q x ==> P s ==> P (f x s)" shows "P (fold f xs s)" using assms by (induct xs arbitrary: s) simp_alllemma fold_append [simp]: "fold f (xs @ ys) = fold f ys o fold f xs" by (induct xs) simp_alllemma fold_map [code_unfold]: "fold g (map f xs) = fold (g o f) xs" by (induct xs) simp_alllemma fold_rev: assumes "!!x y. x ∈ set xs ==> y ∈ set xs ==> f y o f x = f x o f y" shows "fold f (rev xs) = fold f xs"using assms by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)lemma fold_Cons_rev: "fold Cons xs = append (rev xs)" by (induct xs) simp_alllemma rev_conv_fold [code]: "rev xs = fold Cons xs []" by (simp add: fold_Cons_rev)lemma fold_append_concat_rev: "fold append xss = append (concat (rev xss))" by (induct xss) simp_alltext {* @{const Finite_Set.fold} and @{const fold} *}lemma (in comp_fun_commute) fold_set_fold_remdups: "Finite_Set.fold f y (set xs) = fold f (remdups xs) y" by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm insert_absorb)lemma (in ab_semigroup_mult) fold1_distinct_set_fold: assumes "xs ≠ []" assumes d: "distinct xs" shows "Finite_Set.fold1 times (set xs) = List.fold times (tl xs) (hd xs)"proof - interpret comp_fun_commute times by (fact comp_fun_commute) from assms obtain y ys where xs: "xs = y # ys" by (cases xs) auto then have *: "y ∉ set ys" using assms by simp from xs d have **: "remdups ys = ys" by safe (induct ys, auto) show ?thesis proof (cases "set ys = {}") case True with xs show ?thesis by simp next case False then have "fold1 times (Set.insert y (set ys)) = Finite_Set.fold times y (set ys)" by (simp_all add: fold1_eq_fold *) with xs show ?thesis by (simp add: fold_set_fold_remdups **) qedqedlemma (in comp_fun_idem) fold_set_fold: "Finite_Set.fold f y (set xs) = fold f xs y" by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_comm)lemma (in ab_semigroup_idem_mult) fold1_set_fold: assumes "xs ≠ []" shows "Finite_Set.fold1 times (set xs) = fold times (tl xs) (hd xs)"proof - interpret comp_fun_idem times by (fact comp_fun_idem) from assms obtain y ys where xs: "xs = y # ys" by (cases xs) auto show ?thesis proof (cases "set ys = {}") case True with xs show ?thesis by simp next case False then have "fold1 times (insert y (set ys)) = Finite_Set.fold times y (set ys)" by (simp only: finite_set fold1_eq_fold_idem) with xs show ?thesis by (simp add: fold_set_fold mult_commute) qedqedlemma union_set_fold [code]: "set xs ∪ A = fold Set.insert xs A"proof - interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert) show ?thesis by (simp add: union_fold_insert fold_set_fold)qedlemma union_coset_filter [code]: "List.coset xs ∪ A = List.coset (List.filter (λx. x ∉ A) xs)" by autolemma minus_set_fold [code]: "A - set xs = fold Set.remove xs A"proof - interpret comp_fun_idem Set.remove by (fact comp_fun_idem_remove) show ?thesis by (simp add: minus_fold_remove [of _ A] fold_set_fold)qedlemma minus_coset_filter [code]: "A - List.coset xs = set (List.filter (λx. x ∈ A) xs)" by autolemma inter_set_filter [code]: "A ∩ set xs = set (List.filter (λx. x ∈ A) xs)" by autolemma inter_coset_fold [code]: "A ∩ List.coset xs = fold Set.remove xs A" by (simp add: Diff_eq [symmetric] minus_set_fold)lemma (in lattice) Inf_fin_set_fold: "Inf_fin (set (x # xs)) = fold inf xs x"proof - interpret ab_semigroup_idem_mult "inf :: 'a => 'a => 'a" by (fact ab_semigroup_idem_mult_inf) show ?thesis by (simp add: Inf_fin_def fold1_set_fold del: set.simps)qeddeclare Inf_fin_set_fold [code]lemma (in lattice) Sup_fin_set_fold: "Sup_fin (set (x # xs)) = fold sup xs x"proof - interpret ab_semigroup_idem_mult "sup :: 'a => 'a => 'a" by (fact ab_semigroup_idem_mult_sup) show ?thesis by (simp add: Sup_fin_def fold1_set_fold del: set.simps)qeddeclare Sup_fin_set_fold [code]lemma (in linorder) Min_fin_set_fold: "Min (set (x # xs)) = fold min xs x"proof - interpret ab_semigroup_idem_mult "min :: 'a => 'a => 'a" by (fact ab_semigroup_idem_mult_min) show ?thesis by (simp add: Min_def fold1_set_fold del: set.simps)qeddeclare Min_fin_set_fold [code]lemma (in linorder) Max_fin_set_fold: "Max (set (x # xs)) = fold max xs x"proof - interpret ab_semigroup_idem_mult "max :: 'a => 'a => 'a" by (fact ab_semigroup_idem_mult_max) show ?thesis by (simp add: Max_def fold1_set_fold del: set.simps)qeddeclare Max_fin_set_fold [code]lemma (in complete_lattice) Inf_set_fold: "Inf (set xs) = fold inf xs top"proof - interpret comp_fun_idem "inf :: 'a => 'a => 'a" by (fact comp_fun_idem_inf) show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)qeddeclare Inf_set_fold [where 'a = "'a set", code]lemma (in complete_lattice) Sup_set_fold: "Sup (set xs) = fold sup xs bot"proof - interpret comp_fun_idem "sup :: 'a => 'a => 'a" by (fact comp_fun_idem_sup) show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)qeddeclare Sup_set_fold [where 'a = "'a set", code]lemma (in complete_lattice) INF_set_fold: "INFI (set xs) f = fold (inf o f) xs top" unfolding INF_def set_map [symmetric] Inf_set_fold fold_map ..declare INF_set_fold [code]lemma (in complete_lattice) SUP_set_fold: "SUPR (set xs) f = fold (sup o f) xs bot" unfolding SUP_def set_map [symmetric] Sup_set_fold fold_map ..declare SUP_set_fold [code]subsubsection {* Fold variants: @{const foldr} and @{const foldl} *}text {* Correspondence *}lemma foldr_conv_fold [code_abbrev]: "foldr f xs = fold f (rev xs)" by (induct xs) simp_alllemma foldl_conv_fold: "foldl f s xs = fold (λx s. f s x) xs s" by (induct xs arbitrary: s) simp_alllemma foldr_conv_foldl: -- {* The Third Duality Theorem'' in Bird \& Wadler: *} "foldr f xs a = foldl (λx y. f y x) a (rev xs)" by (simp add: foldr_conv_fold foldl_conv_fold)lemma foldl_conv_foldr: "foldl f a xs = foldr (λx y. f y x) (rev xs) a" by (simp add: foldr_conv_fold foldl_conv_fold)lemma foldr_fold: assumes "!!x y. x ∈ set xs ==> y ∈ set xs ==> f y o f x = f x o f y" shows "foldr f xs = fold f xs" using assms unfolding foldr_conv_fold by (rule fold_rev)lemma foldr_cong [fundef_cong]: "a = b ==> l = k ==> (!!a x. x ∈ set l ==> f x a = g x a) ==> foldr f l a = foldr g k b" by (auto simp add: foldr_conv_fold intro!: fold_cong)lemma foldl_cong [fundef_cong]: "a = b ==> l = k ==> (!!a x. x ∈ set l ==> f a x = g a x) ==> foldl f a l = foldl g b k" by (auto simp add: foldl_conv_fold intro!: fold_cong)lemma foldr_append [simp]: "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)" by (simp add: foldr_conv_fold)lemma foldl_append [simp]: "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys" by (simp add: foldl_conv_fold)lemma foldr_map [code_unfold]: "foldr g (map f xs) a = foldr (g o f) xs a" by (simp add: foldr_conv_fold fold_map rev_map)lemma foldl_map [code_unfold]: "foldl g a (map f xs) = foldl (λa x. g a (f x)) a xs" by (simp add: foldl_conv_fold fold_map comp_def)lemma concat_conv_foldr [code]: "concat xss = foldr append xss []" by (simp add: fold_append_concat_rev foldr_conv_fold)subsubsection {* @{const upt} *}lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"-- {* simp does not terminate! *}by (induct j) autolemmas upt_rec_numeral[simp] = upt_rec[of "numeral m" "numeral n"] for m nlemma upt_conv_Nil [simp]: "j <= i ==> [i..<j] = []"by (subst upt_rec) simplemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 ∨ j <= i)"by(induct j)simp_alllemma upt_eq_Cons_conv: "([i..<j] = x#xs) = (i < j & i = x & [i+1..<j] = xs)"apply(induct j arbitrary: x xs) apply simpapply(clarsimp simp add: append_eq_Cons_conv)apply arithdonelemma upt_Suc_append: "i <= j ==> [i..<(Suc j)] = [i..<j]@[j]"-- {* Only needed if @{text upt_Suc} is deleted from the simpset. *}by simplemma upt_conv_Cons: "i < j ==> [i..<j] = i # [Suc i..<j]" by (simp add: upt_rec)lemma upt_add_eq_append: "i<=j ==> [i..<j+k] = [i..<j]@[j..<j+k]"-- {* LOOPS as a simprule, since @{text "j <= j"}. *}by (induct k) autolemma length_upt [simp]: "length [i..<j] = j - i"by (induct j) (auto simp add: Suc_diff_le)lemma nth_upt [simp]: "i + k < j ==> [i..<j] ! k = i + k"apply (induct j)apply (auto simp add: less_Suc_eq nth_append split: nat_diff_split)donelemma hd_upt[simp]: "i < j ==> hd[i..<j] = i"by(simp add:upt_conv_Cons)lemma last_upt[simp]: "i < j ==> last[i..<j] = j - 1"apply(cases j) apply simpby(simp add:upt_Suc_append)lemma take_upt [simp]: "i+m <= n ==> take m [i..<n] = [i..<i+m]"apply (induct m arbitrary: i, simp)apply (subst upt_rec)apply (rule sym)apply (subst upt_rec)apply (simp del: upt.simps)donelemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"apply(induct j)apply autodonelemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"by (induct n) autolemma nth_map_upt: "i < n-m ==> (map f [m..<n]) ! i = f(m+i)"apply (induct n m arbitrary: i rule: diff_induct)prefer 3 apply (subst map_Suc_upt[symmetric])apply (auto simp add: less_diff_conv)donelemma nth_take_lemma: "k <= length xs ==> k <= length ys ==> (!!i. i < k --> xs!i = ys!i) ==> take k xs = take k ys"apply (atomize, induct k arbitrary: xs ys)apply (simp_all add: less_Suc_eq_0_disj all_conj_distrib, clarify)txt {* Both lists must be non-empty *}apply (case_tac xs, simp)apply (case_tac ys, clarify) apply (simp (no_asm_use))apply clarifytxt {* prenexing's needed, not miniscoping *}apply (simp (no_asm_use) add: all_simps [symmetric] del: all_simps)apply blastdonelemma nth_equalityI: "[| length xs = length ys; ALL i < length xs. xs!i = ys!i |] ==> xs = ys" by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_alllemma map_nth: "map (λi. xs ! i) [0..<length xs] = xs" by (rule nth_equalityI, auto)(* needs nth_equalityI *)lemma list_all2_antisym: "[| (!!x y. [|P x y; Q y x|] ==> x = y); list_all2 P xs ys; list_all2 Q ys xs |] ==> xs = ys" apply (simp add: list_all2_conv_all_nth) apply (rule nth_equalityI, blast, simp) donelemma take_equalityI: "(∀i. take i xs = take i ys) ==> xs = ys"-- {* The famous take-lemma. *}apply (drule_tac x = "max (length xs) (length ys)" in spec)apply (simp add: le_max_iff_disj)donelemma take_Cons': "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"by (cases n) simp_alllemma drop_Cons': "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"by (cases n) simp_alllemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"by (cases n) simp_alllemma take_Cons_numeral [simp]: "take (numeral v) (x # xs) = x # take (numeral v - 1) xs"by (simp add: take_Cons')lemma drop_Cons_numeral [simp]: "drop (numeral v) (x # xs) = drop (numeral v - 1) xs"by (simp add: drop_Cons')lemma nth_Cons_numeral [simp]: "(x # xs) ! numeral v = xs ! (numeral v - 1)"by (simp add: nth_Cons')subsubsection {* @{text upto}: interval-list on @{typ int} *}(* FIXME make upto tail recursive? *)function upto :: "int => int => int list" ("(1[_../_])") where"upto i j = (if i ≤ j then i # [i+1..j] else [])"by autoterminationby(relation "measure(%(i::int,j). nat(j - i + 1))") autodeclare upto.simps[code, simp del]lemmas upto_rec_numeral [simp] = upto.simps[of "numeral m" "numeral n"] upto.simps[of "numeral m" "neg_numeral n"] upto.simps[of "neg_numeral m" "numeral n"] upto.simps[of "neg_numeral m" "neg_numeral n"] for m nlemma upto_empty[simp]: "j < i ==> [i..j] = []"by(simp add: upto.simps)lemma set_upto[simp]: "set[i..j] = {i..j}"proof(induct i j rule:upto.induct) case (1 i j) from this show ?case unfolding upto.simps[of i j] simp_from_to[of i j] by autoqedsubsubsection {* @{const distinct} and @{const remdups} *}lemma distinct_tl: "distinct xs ==> distinct (tl xs)" by (cases xs) simp_alllemma distinct_append [simp]:"distinct (xs @ ys) = (distinct xs ∧ distinct ys ∧ set xs ∩ set ys = {})"by (induct xs) autolemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"by(induct xs) autolemma set_remdups [simp]: "set (remdups xs) = set xs"by (induct xs) (auto simp add: insert_absorb)lemma distinct_remdups [iff]: "distinct (remdups xs)"by (induct xs) autolemma distinct_remdups_id: "distinct xs ==> remdups xs = xs"by (induct xs, auto)lemma remdups_id_iff_distinct [simp]: "remdups xs = xs <-> distinct xs"by (metis distinct_remdups distinct_remdups_id)lemma finite_distinct_list: "finite A ==> EX xs. set xs = A & distinct xs"by (metis distinct_remdups finite_list set_remdups)lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"by (induct x, auto)lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"by (induct x, auto)lemma length_remdups_leq[iff]: "length(remdups xs) <= length xs"by (induct xs) autolemma length_remdups_eq[iff]: "(length (remdups xs) = length xs) = (remdups xs = xs)"apply(induct xs) apply autoapply(subgoal_tac "length (remdups xs) <= length xs") apply arithapply(rule length_remdups_leq)donelemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"apply(induct xs)apply autodonelemma distinct_map: "distinct(map f xs) = (distinct xs & inj_on f (set xs))"by (induct xs) autolemma distinct_filter [simp]: "distinct xs ==> distinct (filter P xs)"by (induct xs) autolemma distinct_upt[simp]: "distinct[i..<j]"by (induct j) autolemma distinct_upto[simp]: "distinct[i..j]"apply(induct i j rule:upto.induct)apply(subst upto.simps)apply(simp)donelemma distinct_take[simp]: "distinct xs ==> distinct (take i xs)"apply(induct xs arbitrary: i) apply simpapply (case_tac i) apply simp_allapply(blast dest:in_set_takeD)donelemma distinct_drop[simp]: "distinct xs ==> distinct (drop i xs)"apply(induct xs arbitrary: i) apply simpapply (case_tac i) apply simp_alldonelemma distinct_list_update:assumes d: "distinct xs" and a: "a ∉ set xs - {xs!i}"shows "distinct (xs[i:=a])"proof (cases "i < length xs") case True with a have "a ∉ set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}" apply (drule_tac id_take_nth_drop) by simp with d True show ?thesis apply (simp add: upd_conv_take_nth_drop) apply (drule subst [OF id_take_nth_drop]) apply assumption apply simp apply (cases "a = xs!i") apply simp by blastnext case False with d show ?thesis by autoqedlemma distinct_concat: assumes "distinct xs" and "!! ys. ys ∈ set xs ==> distinct ys" and "!! ys zs. [| ys ∈ set xs ; zs ∈ set xs ; ys ≠ zs |] ==> set ys ∩ set zs = {}" shows "distinct (concat xs)" using assms by (induct xs) autotext {* It is best to avoid this indexed version of distinct, butsometimes it is useful. *}lemma distinct_conv_nth:"distinct xs = (∀i < size xs. ∀j < size xs. i ≠ j --> xs!i ≠ xs!j)"apply (induct xs, simp, simp)apply (rule iffI, clarsimp) apply (case_tac i)apply (case_tac j, simp)apply (simp add: set_conv_nth) apply (case_tac j)apply (clarsimp simp add: set_conv_nth, simp)apply (rule conjI)(*TOO SLOWapply (metis Zero_neq_Suc gr0_conv_Suc in_set_conv_nth lessI less_trans_Suc nth_Cons' nth_Cons_Suc)*) apply (clarsimp simp add: set_conv_nth) apply (erule_tac x = 0 in allE, simp) apply (erule_tac x = "Suc i" in allE, simp, clarsimp)(*TOO SLOWapply (metis Suc_Suc_eq lessI less_trans_Suc nth_Cons_Suc)*)apply (erule_tac x = "Suc i" in allE, simp)apply (erule_tac x = "Suc j" in allE, simp)donelemma nth_eq_iff_index_eq: "[| distinct xs; i < length xs; j < length xs |] ==> (xs!i = xs!j) = (i = j)"by(auto simp: distinct_conv_nth)lemma distinct_card: "distinct xs ==> card (set xs) = size xs"by (induct xs) autolemma card_distinct: "card (set xs) = size xs ==> distinct xs"proof (induct xs) case Nil thus ?case by simpnext case (Cons x xs) show ?case proof (cases "x ∈ set xs") case False with Cons show ?thesis by simp next case True with Cons.prems have "card (set xs) = Suc (length xs)" by (simp add: card_insert_if split: split_if_asm) moreover have "card (set xs) ≤ length xs" by (rule card_length) ultimately have False by simp thus ?thesis .. qedqedlemma distinct_length_filter: "distinct xs ==> length (filter P xs) = card ({x. P x} Int set xs)"by (induct xs) (auto)lemma not_distinct_decomp: "~ distinct ws ==> EX xs ys zs y. ws = xs@[y]@ys@[y]@zs"apply (induct n == "length ws" arbitrary:ws) apply simpapply(case_tac ws) apply simpapply (simp split:split_if_asm)apply (metis Cons_eq_appendI eq_Nil_appendI split_list)donelemma not_distinct_conv_prefix: defines "dec as xs y ys ≡ y ∈ set xs ∧ distinct xs ∧ as = xs @ y # ys" shows "¬distinct as <-> (∃xs y ys. dec as xs y ys)" (is "?L = ?R")proof assume "?L" then show "?R" proof (induct "length as" arbitrary: as rule: less_induct) case less obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs" using not_distinct_decomp[OF less.prems] by auto show ?case proof (cases "distinct (xs @ y # ys)") case True with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def) then show ?thesis by blast next case False with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'" by atomize_elim auto with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def) then show ?thesis by blast qed qedqed (auto simp: dec_def)lemma distinct_product: assumes "distinct xs" and "distinct ys" shows "distinct (List.product xs ys)" using assms by (induct xs) (auto intro: inj_onI simp add: product_list_set distinct_map)lemma length_remdups_concat: "length (remdups (concat xss)) = card (\<Union>xs∈set xss. set xs)" by (simp add: distinct_card [symmetric])lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"proof - have xs: "concat[xs] = xs" by simp from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simpqedlemma remdups_remdups: "remdups (remdups xs) = remdups xs" by (induct xs) simp_alllemma distinct_butlast: assumes "distinct xs" shows "distinct (butlast xs)"proof (cases "xs = []") case False from xs ≠ [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto with distinct xs show ?thesis by simpqed (auto)lemma remdups_map_remdups: "remdups (map f (remdups xs)) = remdups (map f xs)" by (induct xs) simp_alllemma distinct_zipI1: assumes "distinct xs" shows "distinct (zip xs ys)"proof (rule zip_obtain_same_length) fix xs' :: "'a list" and ys' :: "'b list" and n assume "length xs' = length ys'" assume "xs' = take n xs" with assms have "distinct xs'" by simp with length xs' = length ys' show "distinct (zip xs' ys')" by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)qedlemma distinct_zipI2: assumes "distinct ys" shows "distinct (zip xs ys)"proof (rule zip_obtain_same_length) fix xs' :: "'b list" and ys' :: "'a list" and n assume "length xs' = length ys'" assume "ys' = take n ys" with assms have "distinct ys'" by simp with length xs' = length ys' show "distinct (zip xs' ys')" by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)qedlemma set_take_disj_set_drop_if_distinct: "distinct vs ==> i ≤ j ==> set (take i vs) ∩ set (drop j vs) = {}"by (auto simp: in_set_conv_nth distinct_conv_nth)(* The next two lemmas help Sledgehammer. *)lemma distinct_singleton: "distinct [x]" by simplemma distinct_length_2_or_more:"distinct (a # b # xs) <-> (a ≠ b ∧ distinct (a # xs) ∧ distinct (b # xs))"by (metis distinct.simps(2) hd.simps hd_in_set list.simps(2) set_ConsD set_rev_mp set_subset_Cons)subsubsection {* List summation: @{const listsum} and @{text"∑"}*}lemma (in monoid_add) listsum_simps [simp]: "listsum [] = 0" "listsum (x # xs) = x + listsum xs" by (simp_all add: listsum_def)lemma (in monoid_add) listsum_append [simp]: "listsum (xs @ ys) = listsum xs + listsum ys" by (induct xs) (simp_all add: add.assoc)lemma (in comm_monoid_add) listsum_rev [simp]: "listsum (rev xs) = listsum xs" by (simp add: listsum_def foldr_fold fold_rev fun_eq_iff add_ac)lemma (in monoid_add) fold_plus_listsum_rev: "fold plus xs = plus (listsum (rev xs))"proof fix x have "fold plus xs x = fold plus xs (x + 0)" by simp also have "… = fold plus (x # xs) 0" by simp also have "… = foldr plus (rev xs @ [x]) 0" by (simp add: foldr_conv_fold) also have "… = listsum (rev xs @ [x])" by (simp add: listsum_def) also have "… = listsum (rev xs) + listsum [x]" by simp finally show "fold plus xs x = listsum (rev xs) + x" by simpqedtext{* Some syntactic sugar for summing a function over a list: *}syntax "_listsum" :: "pttrn => 'a list => 'b => 'b" ("(3SUM _<-_. _)" [0, 51, 10] 10)syntax (xsymbols) "_listsum" :: "pttrn => 'a list => 'b => 'b" ("(3∑_\<leftarrow>_. _)" [0, 51, 10] 10)syntax (HTML output) "_listsum" :: "pttrn => 'a list => 'b => 'b" ("(3∑_\<leftarrow>_. _)" [0, 51, 10] 10)translations -- {* Beware of argument permutation! *} "SUM x<-xs. b" == "CONST listsum (CONST map (%x. b) xs)" "∑x\<leftarrow>xs. b" == "CONST listsum (CONST map (%x. b) xs)"lemma (in comm_monoid_add) listsum_map_remove1: "x ∈ set xs ==> listsum (map f xs) = f x + listsum (map f (remove1 x xs))" by (induct xs) (auto simp add: ac_simps)lemma (in monoid_add) list_size_conv_listsum: "list_size f xs = listsum (map f xs) + size xs" by (induct xs) autolemma (in monoid_add) length_concat: "length (concat xss) = listsum (map length xss)" by (induct xss) simp_alllemma (in monoid_add) listsum_map_filter: assumes "!!x. x ∈ set xs ==> ¬ P x ==> f x = 0" shows "listsum (map f (filter P xs)) = listsum (map f xs)" using assms by (induct xs) autolemma (in monoid_add) distinct_listsum_conv_Setsum: "distinct xs ==> listsum xs = Setsum (set xs)" by (induct xs) simp_alllemma listsum_eq_0_nat_iff_nat [simp]: "listsum ns = (0::nat) <-> (∀n ∈ set ns. n = 0)" by (induct ns) simp_alllemma member_le_listsum_nat: "(n :: nat) ∈ set ns ==> n ≤ listsum ns" by (induct ns) autolemma elem_le_listsum_nat: "k < size ns ==> ns ! k ≤ listsum (ns::nat list)" by (rule member_le_listsum_nat) simplemma listsum_update_nat: "k < size ns ==> listsum (ns[k := (n::nat)]) = listsum ns + n - ns ! k"apply(induct ns arbitrary:k) apply (auto split:nat.split)apply(drule elem_le_listsum_nat)apply arithdonelemma (in monoid_add) listsum_triv: "(∑x\<leftarrow>xs. r) = of_nat (length xs) * r" by (induct xs) (simp_all add: distrib_right)lemma (in monoid_add) listsum_0 [simp]: "(∑x\<leftarrow>xs. 0) = 0" by (induct xs) (simp_all add: distrib_right)text{* For non-Abelian groups @{text xs} needs to be reversed on one side: *}lemma (in ab_group_add) uminus_listsum_map: "- listsum (map f xs) = listsum (map (uminus o f) xs)" by (induct xs) simp_alllemma (in comm_monoid_add) listsum_addf: "(∑x\<leftarrow>xs. f x + g x) = listsum (map f xs) + listsum (map g xs)" by (induct xs) (simp_all add: algebra_simps)lemma (in ab_group_add) listsum_subtractf: "(∑x\<leftarrow>xs. f x - g x) = listsum (map f xs) - listsum (map g xs)" by (induct xs) (simp_all add: algebra_simps)lemma (in semiring_0) listsum_const_mult: "(∑x\<leftarrow>xs. c * f x) = c * (∑x\<leftarrow>xs. f x)" by (induct xs) (simp_all add: algebra_simps)lemma (in semiring_0) listsum_mult_const: "(∑x\<leftarrow>xs. f x * c) = (∑x\<leftarrow>xs. f x) * c" by (induct xs) (simp_all add: algebra_simps)lemma (in ordered_ab_group_add_abs) listsum_abs: "¦listsum xs¦ ≤ listsum (map abs xs)" by (induct xs) (simp_all add: order_trans [OF abs_triangle_ineq])lemma listsum_mono: fixes f g :: "'a => 'b::{monoid_add, ordered_ab_semigroup_add}" shows "(!!x. x ∈ set xs ==> f x ≤ g x) ==> (∑x\<leftarrow>xs. f x) ≤ (∑x\<leftarrow>xs. g x)" by (induct xs) (simp, simp add: add_mono)lemma (in monoid_add) listsum_distinct_conv_setsum_set: "distinct xs ==> listsum (map f xs) = setsum f (set xs)" by (induct xs) simp_alllemma (in monoid_add) interv_listsum_conv_setsum_set_nat: "listsum (map f [m..<n]) = setsum f (set [m..<n])" by (simp add: listsum_distinct_conv_setsum_set)lemma (in monoid_add) interv_listsum_conv_setsum_set_int: "listsum (map f [k..l]) = setsum f (set [k..l])" by (simp add: listsum_distinct_conv_setsum_set)text {* General equivalence between @{const listsum} and @{const setsum} *}lemma (in monoid_add) listsum_setsum_nth: "listsum xs = (∑ i = 0 ..< length xs. xs ! i)" using interv_listsum_conv_setsum_set_nat [of "op ! xs" 0 "length xs"] by (simp add: map_nth)subsubsection {* @{const insert} *}lemma in_set_insert [simp]: "x ∈ set xs ==> List.insert x xs = xs" by (simp add: List.insert_def)lemma not_in_set_insert [simp]: "x ∉ set xs ==> List.insert x xs = x # xs" by (simp add: List.insert_def)lemma insert_Nil [simp]: "List.insert x [] = [x]" by simplemma set_insert [simp]: "set (List.insert x xs) = insert x (set xs)" by (auto simp add: List.insert_def)lemma distinct_insert [simp]: "distinct xs ==> distinct (List.insert x xs)" by (simp add: List.insert_def)lemma insert_remdups: "List.insert x (remdups xs) = remdups (List.insert x xs)" by (simp add: List.insert_def)subsubsection {* @{const List.find} *}lemma find_None_iff: "List.find P xs = None <-> ¬ (∃x. x ∈ set xs ∧ P x)"proof (induction xs) case Nil thus ?case by simpnext case (Cons x xs) thus ?case by (fastforce split: if_splits)qedlemma find_Some_iff: "List.find P xs = Some x <-> (∃i<length xs. P (xs!i) ∧ x = xs!i ∧ (∀j<i. ¬ P (xs!j)))"proof (induction xs) case Nil thus ?case by simpnext case (Cons x xs) thus ?case by(auto simp: nth_Cons' split: if_splits) (metis One_nat_def diff_Suc_1 less_Suc_eq_0_disj)qedlemma find_cong[fundef_cong]: assumes "xs = ys" and "!!x. x ∈ set ys ==> P x = Q x" shows "List.find P xs = List.find Q ys"proof (cases "List.find P xs") case None thus ?thesis by (metis find_None_iff assms)next case (Some x) hence "List.find Q ys = Some x" using assms by (auto simp add: find_Some_iff) thus ?thesis using Some by autoqedsubsubsection {* @{const remove1} *}lemma remove1_append: "remove1 x (xs @ ys) = (if x ∈ set xs then remove1 x xs @ ys else xs @ remove1 x ys)"by (induct xs) autolemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"by (induct zs) autolemma in_set_remove1[simp]: "a ≠ b ==> a : set(remove1 b xs) = (a : set xs)"apply (induct xs)apply autodonelemma set_remove1_subset: "set(remove1 x xs) <= set xs"apply(induct xs) apply simpapply simpapply blastdonelemma set_remove1_eq [simp]: "distinct xs ==> set(remove1 x xs) = set xs - {x}"apply(induct xs) apply simpapply simpapply blastdonelemma length_remove1: "length(remove1 x xs) = (if x : set xs then length xs - 1 else length xs)"apply (induct xs) apply (auto dest!:length_pos_if_in_set)donelemma remove1_filter_not[simp]: "¬ P x ==> remove1 x (filter P xs) = filter P xs"by(induct xs) autolemma filter_remove1: "filter Q (remove1 x xs) = remove1 x (filter Q xs)"by (induct xs) autolemma notin_set_remove1[simp]: "x ~: set xs ==> x ~: set(remove1 y xs)"apply(insert set_remove1_subset)apply fastdonelemma distinct_remove1[simp]: "distinct xs ==> distinct(remove1 x xs)"by (induct xs) simp_alllemma remove1_remdups: "distinct xs ==> remove1 x (remdups xs) = remdups (remove1 x xs)" by (induct xs) simp_alllemma remove1_idem: assumes "x ∉ set xs" shows "remove1 x xs = xs" using assms by (induct xs) simp_allsubsubsection {* @{const removeAll} *}lemma removeAll_filter_not_eq: "removeAll x = filter (λy. x ≠ y)"proof fix xs show "removeAll x xs = filter (λy. x ≠ y) xs" by (induct xs) autoqedlemma removeAll_append[simp]: "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"by (induct xs) autolemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"by (induct xs) autolemma removeAll_id[simp]: "x ∉ set xs ==> removeAll x xs = xs"by (induct xs) auto(* Needs count:: 'a => 'a list => natlemma length_removeAll: "length(removeAll x xs) = length xs - count x xs"*)lemma removeAll_filter_not[simp]: "¬ P x ==> removeAll x (filter P xs) = filter P xs"by(induct xs) autolemma distinct_removeAll: "distinct xs ==> distinct (removeAll x xs)" by (simp add: removeAll_filter_not_eq)lemma distinct_remove1_removeAll: "distinct xs ==> remove1 x xs = removeAll x xs"by (induct xs) simp_alllemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) ==> map f (removeAll x xs) = removeAll (f x) (map f xs)"by (induct xs) (simp_all add:inj_on_def)lemma map_removeAll_inj: "inj f ==> map f (removeAll x xs) = removeAll (f x) (map f xs)"by(metis map_removeAll_inj_on subset_inj_on subset_UNIV)subsubsection {* @{const replicate} *}lemma length_replicate [simp]: "length (replicate n x) = n"by (induct n) autolemma Ex_list_of_length: "∃xs. length xs = n"by (rule exI[of _ "replicate n undefined"]) simplemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"by (induct n) autolemma map_replicate_const: "map (λ x. k) lst = replicate (length lst) k" by (induct lst) autolemma replicate_app_Cons_same:"(replicate n x) @ (x # xs) = x # replicate n x @ xs"by (induct n) autolemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"apply (induct n, simp)apply (simp add: replicate_app_Cons_same)donelemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"by (induct n) autotext{* Courtesy of Matthias Daum: *}lemma append_replicate_commute: "replicate n x @ replicate k x = replicate k x @ replicate n x"apply (simp add: replicate_add [THEN sym])apply (simp add: add_commute)donetext{* Courtesy of Andreas Lochbihler: *}lemma filter_replicate: "filter P (replicate n x) = (if P x then replicate n x else [])"by(induct n) autolemma hd_replicate [simp]: "n ≠ 0 ==> hd (replicate n x) = x"by (induct n) autolemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"by (induct n) autolemma last_replicate [simp]: "n ≠ 0 ==> last (replicate n x) = x"by (atomize (full), induct n) autolemma nth_replicate[simp]: "i < n ==> (replicate n x)!i = x"apply (induct n arbitrary: i, simp)apply (simp add: nth_Cons split: nat.split)donetext{* Courtesy of Matthias Daum (2 lemmas): *}lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"apply (case_tac "k ≤ i") apply (simp add: min_def)apply (drule not_leE)apply (simp add: min_def)apply (subgoal_tac "replicate k x = replicate i x @ replicate (k - i) x") apply simpapply (simp add: replicate_add [symmetric])donelemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"apply (induct k arbitrary: i) apply simpapply clarsimpapply (case_tac i) apply simpapply clarsimpdonelemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"by (induct n) autolemma set_replicate [simp]: "n ≠ 0 ==> set (replicate n x) = {x}"by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"by autolemma in_set_replicate[simp]: "(x : set (replicate n y)) = (x = y & n ≠ 0)"by (simp add: set_replicate_conv_if)lemma Ball_set_replicate[simp]: "(ALL x : set(replicate n a). P x) = (P a | n=0)"by(simp add: set_replicate_conv_if)lemma Bex_set_replicate[simp]: "(EX x : set(replicate n a). P x) = (P a & n≠0)"by(simp add: set_replicate_conv_if)lemma replicate_append_same: "replicate i x @ [x] = x # replicate i x" by (induct i) simp_alllemma map_replicate_trivial: "map (λi. x) [0..<i] = replicate i x" by (induct i) (simp_all add: replicate_append_same)lemma concat_replicate_trivial[simp]: "concat (replicate i []) = []" by (induct i) (auto simp add: map_replicate_const)lemma replicate_empty[simp]: "(replicate n x = []) <-> n=0"by (induct n) autolemma empty_replicate[simp]: "([] = replicate n x) <-> n=0"by (induct n) autolemma replicate_eq_replicate[simp]: "(replicate m x = replicate n y) <-> (m=n & (m≠0 --> x=y))"apply(induct m arbitrary: n) apply simpapply(induct_tac n)apply autodonelemma replicate_length_filter: "replicate (length (filter (λy. x = y) xs)) x = filter (λy. x = y) xs" by (induct xs) autolemma comm_append_are_replicate: fixes xs ys :: "'a list" assumes "xs ≠ []" "ys ≠ []" assumes "xs @ ys = ys @ xs" shows "∃m n zs. concat (replicate m zs) = xs ∧ concat (replicate n zs) = ys" using assmsproof (induct "length (xs @ ys)" arbitrary: xs ys rule: less_induct) case less def xs' ≡ "if (length xs ≤ length ys) then xs else ys" and ys' ≡ "if (length xs ≤ length ys) then ys else xs" then have prems': "length xs' ≤ length ys'" "xs' @ ys' = ys' @ xs'" and "xs' ≠ []" and len: "length (xs @ ys) = length (xs' @ ys')" using less by (auto intro: less.hyps) from prems' obtain ws where "ys' = xs' @ ws" by (auto simp: append_eq_append_conv2) have "∃m n zs. concat (replicate m zs) = xs' ∧ concat (replicate n zs) = ys'" proof (cases "ws = []") case True then have "concat (replicate 1 xs') = xs'" and "concat (replicate 1 xs') = ys'" using ys' = xs' @ ws by auto then show ?thesis by blast next case False from ys' = xs' @ ws and xs' @ ys' = ys' @ xs' have "xs' @ ws = ws @ xs'" by simp then have "∃m n zs. concat (replicate m zs) = xs' ∧ concat (replicate n zs) = ws" using False and xs' ≠ [] and ys' = xs' @ ws and len by (intro less.hyps) auto then obtain m n zs where "concat (replicate m zs) = xs'" and "concat (replicate n zs) = ws" by blast moreover then have "concat (replicate (m + n) zs) = ys'" using ys' = xs' @ ws by (simp add: replicate_add) ultimately show ?thesis by blast qed then show ?case using xs'_def ys'_def by metisqedlemma comm_append_is_replicate: fixes xs ys :: "'a list" assumes "xs ≠ []" "ys ≠ []" assumes "xs @ ys = ys @ xs" shows "∃n zs. n > 1 ∧ concat (replicate n zs) = xs @ ys"proof - obtain m n zs where "concat (replicate m zs) = xs" and "concat (replicate n zs) = ys" using assms by (metis comm_append_are_replicate) then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys" using xs ≠ [] and ys ≠ [] by (auto simp: replicate_add) then show ?thesis by blastqedsubsubsection {* @{const rotate1} and @{const rotate} *}lemma rotate0[simp]: "rotate 0 = id"by(simp add:rotate_def)lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"by(simp add:rotate_def)lemma rotate_add: "rotate (m+n) = rotate m o rotate n"by(simp add:rotate_def funpow_add)lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"by(simp add:rotate_add)lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"by(simp add:rotate_def funpow_swap1)lemma rotate1_length01[simp]: "length xs <= 1 ==> rotate1 xs = xs"by(cases xs) simp_alllemma rotate_length01[simp]: "length xs <= 1 ==> rotate n xs = xs"apply(induct n) apply simpapply (simp add:rotate_def)donelemma rotate1_hd_tl: "xs ≠ [] ==> rotate1 xs = tl xs @ [hd xs]"by (cases xs) simp_alllemma rotate_drop_take: "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"apply(induct n) apply simpapply(simp add:rotate_def)apply(cases "xs = []") apply (simp)apply(case_tac "n mod length xs = 0") apply(simp add:mod_Suc) apply(simp add: rotate1_hd_tl drop_Suc take_Suc)apply(simp add:mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric] take_hd_drop linorder_not_le)donelemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"by(simp add:rotate_drop_take)lemma rotate_id[simp]: "n mod length xs = 0 ==> rotate n xs = xs"by(simp add:rotate_drop_take)lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"by (cases xs) simp_alllemma length_rotate[simp]: "length(rotate n xs) = length xs"by (induct n arbitrary: xs) (simp_all add:rotate_def)lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"by (cases xs) autolemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"by (induct n) (simp_all add:rotate_def)lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"by(simp add:rotate_drop_take take_map drop_map)lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"by (cases xs) autolemma set_rotate[simp]: "set(rotate n xs) = set xs"by (induct n) (simp_all add:rotate_def)lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"by (cases xs) autolemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"by (induct n) (simp_all add:rotate_def)lemma rotate_rev: "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"apply(simp add:rotate_drop_take rev_drop rev_take)apply(cases "length xs = 0") apply simpapply(cases "n mod length xs = 0") apply simpapply(simp add:rotate_drop_take rev_drop rev_take)donelemma hd_rotate_conv_nth: "xs ≠ [] ==> hd(rotate n xs) = xs!(n mod length xs)"apply(simp add:rotate_drop_take hd_append hd_drop_conv_nth hd_conv_nth)apply(subgoal_tac "length xs ≠ 0") prefer 2 apply simpusing mod_less_divisor[of "length xs" n] by arithsubsubsection {* @{const sublist} --- a generalization of @{const nth} to sets *}lemma sublist_empty [simp]: "sublist xs {} = []"by (auto simp add: sublist_def)lemma sublist_nil [simp]: "sublist [] A = []"by (auto simp add: sublist_def)lemma length_sublist: "length(sublist xs I) = card{i. i < length xs ∧ i : I}"by(simp add: sublist_def length_filter_conv_card cong:conj_cong)lemma sublist_shift_lemma_Suc: "map fst (filter (%p. P(Suc(snd p))) (zip xs is)) = map fst (filter (%p. P(snd p)) (zip xs (map Suc is)))"apply(induct xs arbitrary: "is") apply simpapply (case_tac "is") apply simpapply simpdonelemma sublist_shift_lemma: "map fst [p<-zip xs [i..<i + length xs] . snd p : A] = map fst [p<-zip xs [0..<length xs] . snd p + i : A]"by (induct xs rule: rev_induct) (simp_all add: add_commute)lemma sublist_append: "sublist (l @ l') A = sublist l A @ sublist l' {j. j + length l : A}"apply (unfold sublist_def)apply (induct l' rule: rev_induct, simp)apply (simp add: upt_add_eq_append[of 0] sublist_shift_lemma)apply (simp add: add_commute)donelemma sublist_Cons:"sublist (x # l) A = (if 0:A then [x] else []) @ sublist l {j. Suc j : A}"apply (induct l rule: rev_induct) apply (simp add: sublist_def)apply (simp del: append_Cons add: append_Cons[symmetric] sublist_append)donelemma set_sublist: "set(sublist xs I) = {xs!i|i. i<size xs ∧ i ∈ I}"apply(induct xs arbitrary: I)apply(auto simp: sublist_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)donelemma set_sublist_subset: "set(sublist xs I) ⊆ set xs"by(auto simp add:set_sublist)lemma notin_set_sublistI[simp]: "x ∉ set xs ==> x ∉ set(sublist xs I)"by(auto simp add:set_sublist)lemma in_set_sublistD: "x ∈ set(sublist xs I) ==> x ∈ set xs"by(auto simp add:set_sublist)lemma sublist_singleton [simp]: "sublist [x] A = (if 0 : A then [x] else [])"by (simp add: sublist_Cons)lemma distinct_sublistI[simp]: "distinct xs ==> distinct(sublist xs I)"apply(induct xs arbitrary: I) apply simpapply(auto simp add:sublist_Cons)donelemma sublist_upt_eq_take [simp]: "sublist l {..<n} = take n l"apply (induct l rule: rev_induct, simp)apply (simp split: nat_diff_split add: sublist_append)donelemma filter_in_sublist: "distinct xs ==> filter (%x. x ∈ set(sublist xs s)) xs = sublist xs s"proof (induct xs arbitrary: s) case Nil thus ?case by simpnext case (Cons a xs) moreover hence "!x. x: set xs --> x ≠ a" by auto ultimately show ?case by(simp add: sublist_Cons cong:filter_cong)qedsubsubsection {* @{const sublists} and @{const List.n_lists} *}lemma length_sublists: "length (sublists xs) = 2 ^ length xs" by (induct xs) (simp_all add: Let_def)lemma sublists_powset: "set  set (sublists xs) = Pow (set xs)"proof - have aux: "!!x A. set  Cons x  A = insert x  set  A" by (auto simp add: image_def) have "set (map set (sublists xs)) = Pow (set xs)" by (induct xs) (simp_all add: aux Let_def Pow_insert Un_commute comp_def del: map_map) then show ?thesis by simpqedlemma distinct_set_sublists: assumes "distinct xs" shows "distinct (map set (sublists xs))"proof (rule card_distinct) have "finite (set xs)" by rule then have "card (Pow (set xs)) = 2 ^ card (set xs)" by (rule card_Pow) with assms distinct_card [of xs] have "card (Pow (set xs)) = 2 ^ length xs" by simp then show "card (set (map set (sublists xs))) = length (map set (sublists xs))" by (simp add: sublists_powset length_sublists)qedlemma n_lists_Nil [simp]: "List.n_lists n [] = (if n = 0 then [[]] else [])" by (induct n) simp_alllemma length_n_lists: "length (List.n_lists n xs) = length xs ^ n" by (induct n) (auto simp add: length_concat o_def listsum_triv)lemma length_n_lists_elem: "ys ∈ set (List.n_lists n xs) ==> length ys = n" by (induct n arbitrary: ys) autolemma set_n_lists: "set (List.n_lists n xs) = {ys. length ys = n ∧ set ys ⊆ set xs}"proof (rule set_eqI) fix ys :: "'a list" show "ys ∈ set (List.n_lists n xs) <-> ys ∈ {ys. length ys = n ∧ set ys ⊆ set xs}" proof - have "ys ∈ set (List.n_lists n xs) ==> length ys = n" by (induct n arbitrary: ys) auto moreover have "!!x. ys ∈ set (List.n_lists n xs) ==> x ∈ set ys ==> x ∈ set xs" by (induct n arbitrary: ys) auto moreover have "set ys ⊆ set xs ==> ys ∈ set (List.n_lists (length ys) xs)" by (induct ys) auto ultimately show ?thesis by auto qedqedlemma distinct_n_lists: assumes "distinct xs" shows "distinct (List.n_lists n xs)"proof (rule card_distinct) from assms have card_length: "card (set xs) = length xs" by (rule distinct_card) have "card (set (List.n_lists n xs)) = card (set xs) ^ n" proof (induct n) case 0 then show ?case by simp next case (Suc n) moreover have "card (\<Union>ys∈set (List.n_lists n xs). (λy. y # ys)  set xs) = (∑ys∈set (List.n_lists n xs). card ((λy. y # ys)  set xs))" by (rule card_UN_disjoint) auto moreover have "!!ys. card ((λy. y # ys)  set xs) = card (set xs)" by (rule card_image) (simp add: inj_on_def) ultimately show ?case by auto qed also have "… = length xs ^ n" by (simp add: card_length) finally show "card (set (List.n_lists n xs)) = length (List.n_lists n xs)" by (simp add: length_n_lists)qedsubsubsection {* @{const splice} *}lemma splice_Nil2 [simp, code]: "splice xs [] = xs"by (cases xs) simp_alldeclare splice.simps(1,3)[code]declare splice.simps(2)[simp del]lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"by (induct xs ys rule: splice.induct) autosubsubsection {* Transpose *}function transpose where"transpose [] = []" |"transpose ([] # xss) = transpose xss" |"transpose ((x#xs) # xss) = (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"by pat_completeness autolemma transpose_aux_filter_head: "concat (map (list_case [] (λh t. [h])) xss) = map (λxs. hd xs) [ys\<leftarrow>xss . ys ≠ []]" by (induct xss) (auto split: list.split)lemma transpose_aux_filter_tail: "concat (map (list_case [] (λh t. [t])) xss) = map (λxs. tl xs) [ys\<leftarrow>xss . ys ≠ []]" by (induct xss) (auto split: list.split)lemma transpose_aux_max: "max (Suc (length xs)) (foldr (λxs. max (length xs)) xss 0) = Suc (max (length xs) (foldr (λx. max (length x - Suc 0)) [ys\<leftarrow>xss . ys≠[]] 0))" (is "max _ ?foldB = Suc (max _ ?foldA)")proof (cases "[ys\<leftarrow>xss . ys≠[]] = []") case True hence "foldr (λxs. max (length xs)) xss 0 = 0" proof (induct xss) case (Cons x xs) moreover hence "x = []" by (cases x) auto ultimately show ?case by auto qed simp thus ?thesis using True by simpnext case False have foldA: "?foldA = foldr (λx. max (length x)) [ys\<leftarrow>xss . ys ≠ []] 0 - 1" by (induct xss) auto have foldB: "?foldB = foldr (λx. max (length x)) [ys\<leftarrow>xss . ys ≠ []] 0" by (induct xss) auto have "0 < ?foldB" proof - from False obtain z zs where zs: "[ys\<leftarrow>xss . ys ≠ []] = z#zs" by (auto simp: neq_Nil_conv) hence "z ∈ set ([ys\<leftarrow>xss . ys ≠ []])" by auto hence "z ≠ []" by auto thus ?thesis unfolding foldB zs by (auto simp: max_def intro: less_le_trans) qed thus ?thesis unfolding foldA foldB max_Suc_Suc[symmetric] by simpqedtermination transpose by (relation "measure (λxs. foldr (λxs. max (length xs)) xs 0 + length xs)") (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)lemma transpose_empty: "(transpose xs = []) <-> (∀x ∈ set xs. x = [])" by (induct rule: transpose.induct) simp_alllemma length_transpose: fixes xs :: "'a list list" shows "length (transpose xs) = foldr (λxs. max (length xs)) xs 0" by (induct rule: transpose.induct) (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max max_Suc_Suc[symmetric] simp del: max_Suc_Suc)lemma nth_transpose: fixes xs :: "'a list list" assumes "i < length (transpose xs)" shows "transpose xs ! i = map (λxs. xs ! i) [ys \<leftarrow> xs. i < length ys]"using assms proof (induct arbitrary: i rule: transpose.induct) case (3 x xs xss) def XS == "(x # xs) # xss" hence [simp]: "XS ≠ []" by auto thus ?case proof (cases i) case 0 thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth) next case (Suc j) have *: "!!xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp have **: "!!xss. (x#xs) # filter (λys. ys ≠ []) xss = filter (λys. ys ≠ []) ((x#xs)#xss)" by simp { fix x have "Suc j < length x <-> x ≠ [] ∧ j < length x - Suc 0" by (cases x) simp_all } note *** = this have j_less: "j < length (transpose (xs # concat (map (list_case [] (λh t. [t])) xss)))" using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc) show ?thesis unfolding transpose.simps i = Suc j nth_Cons_Suc "3.hyps"[OF j_less] apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric]) apply (rule_tac y=x in list.exhaust) by auto qedqed simp_alllemma transpose_map_map: "transpose (map (map f) xs) = map (map f) (transpose xs)"proof (rule nth_equalityI, safe) have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)" by (simp add: length_transpose foldr_map comp_def) show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp fix i assume "i < length (transpose (map (map f) xs))" thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i" by (simp add: nth_transpose filter_map comp_def)qedsubsubsection {* (In)finiteness *}lemma finite_maxlen: "finite (M::'a list set) ==> EX n. ALL s:M. size s < n"proof (induct rule: finite.induct) case emptyI show ?case by simpnext case (insertI M xs) then obtain n where "∀s∈M. length s < n" by blast hence "ALL s:insert xs M. size s < max n (size xs) + 1" by auto thus ?case ..qedlemma lists_length_Suc_eq: "{xs. set xs ⊆ A ∧ length xs = Suc n} = (λ(xs, n). n#xs)  ({xs. set xs ⊆ A ∧ length xs = n} × A)" by (auto simp: length_Suc_conv)lemma assumes "finite A" shows finite_lists_length_eq: "finite {xs. set xs ⊆ A ∧ length xs = n}" and card_lists_length_eq: "card {xs. set xs ⊆ A ∧ length xs = n} = (card A)^n" using finite A by (induct n) (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)lemma finite_lists_length_le: assumes "finite A" shows "finite {xs. set xs ⊆ A ∧ length xs ≤ n}" (is "finite ?S")proof- have "?S = (\<Union>n∈{0..n}. {xs. set xs ⊆ A ∧ length xs = n})" by auto thus ?thesis by (auto intro!: finite_lists_length_eq[OF finite A] simp only:)qedlemma card_lists_length_le: assumes "finite A" shows "card {xs. set xs ⊆ A ∧ length xs ≤ n} = (∑i≤n. card A^i)"proof - have "(∑i≤n. card A^i) = card (\<Union>i≤n. {xs. set xs ⊆ A ∧ length xs = i})" using finite A by (subst card_UN_disjoint) (auto simp add: card_lists_length_eq finite_lists_length_eq) also have "(\<Union>i≤n. {xs. set xs ⊆ A ∧ length xs = i}) = {xs. set xs ⊆ A ∧ length xs ≤ n}" by auto finally show ?thesis by simpqedlemma card_lists_distinct_length_eq: assumes "k < card A" shows "card {xs. length xs = k ∧ distinct xs ∧ set xs ⊆ A} = ∏{card A - k + 1 .. card A}"using assmsproof (induct k) case 0 then have "{xs. length xs = 0 ∧ distinct xs ∧ set xs ⊆ A} = {[]}" by auto then show ?case by simpnext case (Suc k) let "?k_list" = "λk xs. length xs = k ∧ distinct xs ∧ set xs ⊆ A" have inj_Cons: "!!A. inj_on (λ(xs, n). n # xs) A" by (rule inj_onI) auto from Suc have "k < card A" by simp moreover have "finite A" using assms by (simp add: card_ge_0_finite) moreover have "finite {xs. ?k_list k xs}" using finite_lists_length_eq[OF finite A, of k] by - (rule finite_subset, auto) moreover have "!!i j. i ≠ j --> {i} × (A - set i) ∩ {j} × (A - set j) = {}" by auto moreover have "!!i. i ∈Collect (?k_list k) ==> card (A - set i) = card A - k" by (simp add: card_Diff_subset distinct_card) moreover have "{xs. ?k_list (Suc k) xs} = (λ(xs, n). n#xs)  \<Union>(λxs. {xs} × (A - set xs))  {xs. ?k_list k xs}" by (auto simp: length_Suc_conv) moreover have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp then have "(card A - k) * ∏{Suc (card A - k)..card A} = ∏{Suc (card A - Suc k)..card A}" by (subst setprod_insert[symmetric]) (simp add: atLeastAtMost_insertL)+ ultimately show ?case by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)qedlemma infinite_UNIV_listI: "~ finite(UNIV::'a list set)"apply(rule notI)apply(drule finite_maxlen)apply (metis UNIV_I length_replicate less_not_refl)donesubsection {* Sorting *}text{* Currently it is not shown that @{const sort} returns apermutation of its input because the nicest proof is via multisets,which are not yet available. Alternatively one could define a functionthat counts the number of occurrences of an element in a list and usethat instead of multisets to state the correctness property. *}context linorderbeginlemma length_insort [simp]: "length (insort_key f x xs) = Suc (length xs)" by (induct xs) simp_alllemma insort_key_left_comm: assumes "f x ≠ f y" shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)" by (induct xs) (auto simp add: assms dest: antisym)lemma insort_left_comm: "insort x (insort y xs) = insort y (insort x xs)" by (cases "x = y") (auto intro: insort_key_left_comm)lemma comp_fun_commute_insort: "comp_fun_commute insort"proofqed (simp add: insort_left_comm fun_eq_iff)lemma sort_key_simps [simp]: "sort_key f [] = []" "sort_key f (x#xs) = insort_key f x (sort_key f xs)" by (simp_all add: sort_key_def)lemma (in linorder) sort_key_conv_fold: assumes "inj_on f (set xs)" shows "sort_key f xs = fold (insort_key f) xs []"proof - have "fold (insort_key f) (rev xs) = fold (insort_key f) xs" proof (rule fold_rev, rule ext) fix zs fix x y assume "x ∈ set xs" "y ∈ set xs" with assms have *: "f y = f x ==> y = x" by (auto dest: inj_onD) have **: "x = y <-> y = x" by auto show "(insort_key f y o insort_key f x) zs = (insort_key f x o insort_key f y) zs" by (induct zs) (auto intro: * simp add: **) qed then show ?thesis by (simp add: sort_key_def foldr_conv_fold)qedlemma (in linorder) sort_conv_fold: "sort xs = fold insort xs []" by (rule sort_key_conv_fold) simplemma length_sort[simp]: "length (sort_key f xs) = length xs"by (induct xs, auto)lemma sorted_Cons: "sorted (x#xs) = (sorted xs & (ALL y:set xs. x <= y))"apply(induct xs arbitrary: x) apply simpby simp (blast intro: order_trans)lemma sorted_tl: "sorted xs ==> sorted (tl xs)" by (cases xs) (simp_all add: sorted_Cons)lemma sorted_append: "sorted (xs@ys) = (sorted xs & sorted ys & (∀x ∈ set xs. ∀y ∈ set ys. x≤y))"by (induct xs) (auto simp add:sorted_Cons)lemma sorted_nth_mono: "sorted xs ==> i ≤ j ==> j < length xs ==> xs!i ≤ xs!j"by (induct xs arbitrary: i j) (auto simp:nth_Cons' sorted_Cons)lemma sorted_rev_nth_mono: "sorted (rev xs) ==> i ≤ j ==> j < length xs ==> xs!j ≤ xs!i"using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"] rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]by autolemma sorted_nth_monoI: "(!! i j. [| i ≤ j ; j < length xs |] ==> xs ! i ≤ xs ! j) ==> sorted xs"proof (induct xs) case (Cons x xs) have "sorted xs" proof (rule Cons.hyps) fix i j assume "i ≤ j" and "j < length xs" with Cons.prems[of "Suc i" "Suc j"] show "xs ! i ≤ xs ! j" by auto qed moreover { fix y assume "y ∈ set xs" then obtain j where "j < length xs" and "xs ! j = y" unfolding in_set_conv_nth by blast with Cons.prems[of 0 "Suc j"] have "x ≤ y" by auto } ultimately show ?case unfolding sorted_Cons by autoqed simplemma sorted_equals_nth_mono: "sorted xs = (∀j < length xs. ∀i ≤ j. xs ! i ≤ xs ! j)"by (auto intro: sorted_nth_monoI sorted_nth_mono)lemma set_insort: "set(insort_key f x xs) = insert x (set xs)"by (induct xs) autolemma set_sort[simp]: "set(sort_key f xs) = set xs"by (induct xs) (simp_all add:set_insort)lemma distinct_insort: "distinct (insort_key f x xs) = (x ∉ set xs ∧ distinct xs)"by(induct xs)(auto simp:set_insort)lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs" by (induct xs) (simp_all add: distinct_insort)lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)" by (induct xs) (auto simp:sorted_Cons set_insort)lemma sorted_insort: "sorted (insort x xs) = sorted xs" using sorted_insort_key [where f="λx. x"] by simptheorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))" by (induct xs) (auto simp:sorted_insort_key)theorem sorted_sort [simp]: "sorted (sort xs)" using sorted_sort_key [where f="λx. x"] by simplemma sorted_butlast: assumes "xs ≠ []" and "sorted xs" shows "sorted (butlast xs)"proof - from xs ≠ [] obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto with sorted xs show ?thesis by (simp add: sorted_append)qed lemma insort_not_Nil [simp]: "insort_key f a xs ≠ []" by (induct xs) simp_alllemma insort_is_Cons: "∀x∈set xs. f a ≤ f x ==> insort_key f a xs = a # xs"by (cases xs) autolemma sorted_sort_id: "sorted xs ==> sort xs = xs" by (induct xs) (auto simp add: sorted_Cons insort_is_Cons)lemma sorted_map_remove1: "sorted (map f xs) ==> sorted (map f (remove1 x xs))" by (induct xs) (auto simp add: sorted_Cons)lemma sorted_remove1: "sorted xs ==> sorted (remove1 a xs)" using sorted_map_remove1 [of "λx. x"] by simplemma insort_key_remove1: assumes "a ∈ set xs" and "sorted (map f xs)" and "hd (filter (λx. f a = f x) xs) = a" shows "insort_key f a (remove1 a xs) = xs"using assms proof (induct xs) case (Cons x xs) then show ?case proof (cases "x = a") case False then have "f x ≠ f a" using Cons.prems by auto then have "f x < f a" using Cons.prems by (auto simp: sorted_Cons) with f x ≠ f a show ?thesis using Cons by (auto simp: sorted_Cons insort_is_Cons) qed (auto simp: sorted_Cons insort_is_Cons)qed simplemma insort_remove1: assumes "a ∈ set xs" and "sorted xs" shows "insort a (remove1 a xs) = xs"proof (rule insort_key_remove1) from a ∈ set xs show "a ∈ set xs" . from sorted xs show "sorted (map (λx. x) xs)" by simp from a ∈ set xs have "a ∈ set (filter (op = a) xs)" by auto then have "set (filter (op = a) xs) ≠ {}" by auto then have "filter (op = a) xs ≠ []" by (auto simp only: set_empty) then have "length (filter (op = a) xs) > 0" by simp then obtain n where n: "Suc n = length (filter (op = a) xs)" by (cases "length (filter (op = a) xs)") simp_all moreover have "replicate (Suc n) a = a # replicate n a" by simp ultimately show "hd (filter (op = a) xs) = a" by (simp add: replicate_length_filter)qedlemma sorted_remdups[simp]: "sorted l ==> sorted (remdups l)"by (induct l) (auto simp: sorted_Cons)lemma sorted_distinct_set_unique:assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"shows "xs = ys"proof - from assms have 1: "length xs = length ys" by (auto dest!: distinct_card) from assms show ?thesis proof(induct rule:list_induct2[OF 1]) case 1 show ?case by simp next case 2 thus ?case by (simp add:sorted_Cons) (metis Diff_insert_absorb antisym insertE insert_iff) qedqedlemma map_sorted_distinct_set_unique: assumes "inj_on f (set xs ∪ set ys)" assumes "sorted (map f xs)" "distinct (map f xs)" "sorted (map f ys)" "distinct (map f ys)" assumes "set xs = set ys" shows "xs = ys"proof - from assms have "map f xs = map f ys" by (simp add: sorted_distinct_set_unique) moreover with inj_on f (set xs ∪ set ys) show "xs = ys" by (blast intro: map_inj_on)qedlemma finite_sorted_distinct_unique:shows "finite A ==> EX! xs. set xs = A & sorted xs & distinct xs"apply(drule finite_distinct_list)apply clarifyapply(rule_tac a="sort xs" in ex1I)apply (auto simp: sorted_distinct_set_unique)donelemma assumes "sorted xs" shows sorted_take: "sorted (take n xs)" and sorted_drop: "sorted (drop n xs)"proof - from assms have "sorted (take n xs @ drop n xs)" by simp then show "sorted (take n xs)" and "sorted (drop n xs)" unfolding sorted_append by simp_allqedlemma sorted_dropWhile: "sorted xs ==> sorted (dropWhile P xs)" by (auto dest: sorted_drop simp add: dropWhile_eq_drop)lemma sorted_takeWhile: "sorted xs ==> sorted (takeWhile P xs)" by (subst takeWhile_eq_take) (auto dest: sorted_take)lemma sorted_filter: "sorted (map f xs) ==> sorted (map f (filter P xs))" by (induct xs) (simp_all add: sorted_Cons)lemma foldr_max_sorted: assumes "sorted (rev xs)" shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"using assms proof (induct xs) case (Cons x xs) moreover hence "sorted (rev xs)" using sorted_append by auto ultimately show ?case by (cases xs, auto simp add: sorted_append max_def)qed simplemma filter_equals_takeWhile_sorted_rev: assumes sorted: "sorted (rev (map f xs))" shows "[x \<leftarrow> xs. t < f x] = takeWhile (λ x. t < f x) xs" (is "filter ?P xs = ?tW")proof (rule takeWhile_eq_filter[symmetric]) let "?dW" = "dropWhile ?P xs" fix x assume "x ∈ set ?dW" then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i" unfolding in_set_conv_nth by auto hence "length ?tW + i < length (?tW @ ?dW)" unfolding length_append by simp hence i': "length (map f ?tW) + i < length (map f xs)" by simp have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) ≤ (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)" using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"] unfolding map_append[symmetric] by simp hence "f x ≤ f (?dW ! 0)" unfolding nth_append_length_plus nth_i using i preorder_class.le_less_trans[OF le0 i] by simp also have "... ≤ t" using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i] using hd_conv_nth[of "?dW"] by simp finally show "¬ t < f x" by simpqedlemma insort_insert_key_triv: "f x ∈ f  set xs ==> insort_insert_key f x xs = xs" by (simp add: insort_insert_key_def)lemma insort_insert_triv: "x ∈ set xs ==> insort_insert x xs = xs" using insort_insert_key_triv [of "λx. x"] by simplemma insort_insert_insort_key: "f x ∉ f  set xs ==> insort_insert_key f x xs = insort_key f x xs" by (simp add: insort_insert_key_def)lemma insort_insert_insort: "x ∉ set xs ==> insort_insert x xs = insort x xs" using insort_insert_insort_key [of "λx. x"] by simplemma set_insort_insert: "set (insort_insert x xs) = insert x (set xs)" by (auto simp add: insort_insert_key_def set_insort)lemma distinct_insort_insert: assumes "distinct xs" shows "distinct (insort_insert_key f x xs)" using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort)lemma sorted_insort_insert_key: assumes "sorted (map f xs)" shows "sorted (map f (insort_insert_key f x xs))" using assms by (simp add: insort_insert_key_def sorted_insort_key)lemma sorted_insort_insert: assumes "sorted xs" shows "sorted (insort_insert x xs)" using assms sorted_insort_insert_key [of "λx. x"] by simplemma filter_insort_triv: "¬ P x ==> filter P (insort_key f x xs) = filter P xs" by (induct xs) simp_alllemma filter_insort: "sorted (map f xs) ==> P x ==> filter P (insort_key f x xs) = insort_key f x (filter P xs)" using assms by (induct xs) (auto simp add: sorted_Cons, subst insort_is_Cons, auto)lemma filter_sort: "filter P (sort_key f xs) = sort_key f (filter P xs)" by (induct xs) (simp_all add: filter_insort_triv filter_insort)lemma sorted_map_same: "sorted (map f [x\<leftarrow>xs. f x = g xs])"proof (induct xs arbitrary: g) case Nil then show ?case by simpnext case (Cons x xs) then have "sorted (map f [y\<leftarrow>xs . f y = (λxs. f x) xs])" . moreover from Cons have "sorted (map f [y\<leftarrow>xs . f y = (g o Cons x) xs])" . ultimately show ?case by (simp_all add: sorted_Cons)qedlemma sorted_same: "sorted [x\<leftarrow>xs. x = g xs]" using sorted_map_same [of "λx. x"] by simplemma remove1_insort [simp]: "remove1 x (insort x xs) = xs" by (induct xs) simp_allendlemma sorted_upt[simp]: "sorted[i..<j]"by (induct j) (simp_all add:sorted_append)lemma sorted_upto[simp]: "sorted[i..j]"apply(induct i j rule:upto.induct)apply(subst upto.simps)apply(simp add:sorted_Cons)donesubsubsection {* @{const transpose} on sorted lists *}lemma sorted_transpose[simp]: shows "sorted (rev (map length (transpose xs)))" by (auto simp: sorted_equals_nth_mono rev_nth nth_transpose length_filter_conv_card intro: card_mono)lemma transpose_max_length: "foldr (λxs. max (length xs)) (transpose xs) 0 = length [x \<leftarrow> xs. x ≠ []]" (is "?L = ?R")proof (cases "transpose xs = []") case False have "?L = foldr max (map length (transpose xs)) 0" by (simp add: foldr_map comp_def) also have "... = length (transpose xs ! 0)" using False sorted_transpose by (simp add: foldr_max_sorted) finally show ?thesis using False by (simp add: nth_transpose)next case True hence "[x \<leftarrow> xs. x ≠ []] = []" by (auto intro!: filter_False simp: transpose_empty) thus ?thesis by (simp add: transpose_empty True)qedlemma length_transpose_sorted: fixes xs :: "'a list list" assumes sorted: "sorted (rev (map length xs))" shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"proof (cases "xs = []") case False thus ?thesis using foldr_max_sorted[OF sorted] False unfolding length_transpose foldr_map comp_def by simpqed simplemma nth_nth_transpose_sorted[simp]: fixes xs :: "'a list list" assumes sorted: "sorted (rev (map length xs))" and i: "i < length (transpose xs)" and j: "j < length [ys \<leftarrow> xs. i < length ys]" shows "transpose xs ! i ! j = xs ! j ! i" using j filter_equals_takeWhile_sorted_rev[OF sorted, of i] nth_transpose[OF i] nth_map[OF j] by (simp add: takeWhile_nth)lemma transpose_column_length: fixes xs :: "'a list list" assumes sorted: "sorted (rev (map length xs))" and "i < length xs" shows "length (filter (λys. i < length ys) (transpose xs)) = length (xs ! i)"proof - have "xs ≠ []" using i < length xs by auto note filter_equals_takeWhile_sorted_rev[OF sorted, simp] { fix j assume "j ≤ i" note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this i < length xs] } note sortedE = this[consumes 1] have "{j. j < length (transpose xs) ∧ i < length (transpose xs ! j)} = {..< length (xs ! i)}" proof safe fix j assume "j < length (transpose xs)" and "i < length (transpose xs ! j)" with this(2) nth_transpose[OF this(1)] have "i < length (takeWhile (λys. j < length ys) xs)" by simp from nth_mem[OF this] takeWhile_nth[OF this] show "j < length (xs ! i)" by (auto dest: set_takeWhileD) next fix j assume "j < length (xs ! i)" thus "j < length (transpose xs)" using foldr_max_sorted[OF sorted] xs ≠ [] sortedE[OF le0] by (auto simp: length_transpose comp_def foldr_map) have "Suc i ≤ length (takeWhile (λys. j < length ys) xs)" using i < length xs j < length (xs ! i) less_Suc_eq_le by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE) with nth_transpose[OF j < length (transpose xs)] show "i < length (transpose xs ! j)" by simp qed thus ?thesis by (simp add: length_filter_conv_card)qedlemma transpose_column: fixes xs :: "'a list list" assumes sorted: "sorted (rev (map length xs))" and "i < length xs" shows "map (λys. ys ! i) (filter (λys. i < length ys) (transpose xs)) = xs ! i" (is "?R = _")proof (rule nth_equalityI, safe) show length: "length ?R = length (xs ! i)" using transpose_column_length[OF assms] by simp fix j assume j: "j < length ?R" note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le] from j have j_less: "j < length (xs ! i)" using length by simp have i_less_tW: "Suc i ≤ length (takeWhile (λys. Suc j ≤ length ys) xs)" proof (rule length_takeWhile_less_P_nth) show "Suc i ≤ length xs" using i < length xs by simp fix k assume "k < Suc i" hence "k ≤ i" by auto with sorted_rev_nth_mono[OF sorted this] i < length xs have "length (xs ! i) ≤ length (xs ! k)" by simp thus "Suc j ≤ length (xs ! k)" using j_less by simp qed have i_less_filter: "i < length [ys\<leftarrow>xs . j < length ys]" unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j] using i_less_tW by (simp_all add: Suc_le_eq) from j show "?R ! j = xs ! i ! j" unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i] by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])qedlemma transpose_transpose: fixes xs :: "'a list list" assumes sorted: "sorted (rev (map length xs))" shows "transpose (transpose xs) = takeWhile (λx. x ≠ []) xs" (is "?L = ?R")proof - have len: "length ?L = length ?R" unfolding length_transpose transpose_max_length using filter_equals_takeWhile_sorted_rev[OF sorted, of 0] by simp { fix i assume "i < length ?R" with less_le_trans[OF _ length_takeWhile_le[of _ xs]] have "i < length xs" by simp } note * = this show ?thesis by (rule nth_equalityI) (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)qedtheorem transpose_rectangle: assumes "xs = [] ==> n = 0" assumes rect: "!! i. i < length xs ==> length (xs ! i) = n" shows "transpose xs = map (λ i. map (λ j. xs ! j ! i) [0..<length xs]) [0..<n]" (is "?trans = ?map")proof (rule nth_equalityI) have "sorted (rev (map length xs))" by (auto simp: rev_nth rect intro!: sorted_nth_monoI) from foldr_max_sorted[OF this] assms show len: "length ?trans = length ?map" by (simp_all add: length_transpose foldr_map comp_def) moreover { fix i assume "i < n" hence "[ys\<leftarrow>xs . i < length ys] = xs" using rect by (auto simp: in_set_conv_nth intro!: filter_True) } ultimately show "∀i < length ?trans. ?trans ! i = ?map ! i" by (auto simp: nth_transpose intro: nth_equalityI)qedsubsubsection {* @{text sorted_list_of_set} *}text{* This function maps (finite) linearly ordered sets to sortedlists. Warning: in most cases it is not a good idea to convert fromsets to lists but one should convert in the other direction (via@{const set}). *}context linorderbegindefinition sorted_list_of_set :: "'a set => 'a list" where"sorted_list_of_set = Finite_Set.fold insort []"lemma sorted_list_of_set_empty [simp]: "sorted_list_of_set {} = []" by (simp add: sorted_list_of_set_def)lemma sorted_list_of_set_insert [simp]: assumes "finite A" shows "sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"proof - interpret comp_fun_commute insort by (fact comp_fun_commute_insort) from assms show ?thesis by (simp add: sorted_list_of_set_def fold_insert_remove)qedlemma sorted_list_of_set [simp]: "finite A ==> set (sorted_list_of_set A) = A ∧ sorted (sorted_list_of_set A) ∧ distinct (sorted_list_of_set A)" by (induct A rule: finite_induct) (simp_all add: set_insort sorted_insort distinct_insort)lemma sorted_list_of_set_sort_remdups [code]: "sorted_list_of_set (set xs) = sort (remdups xs)"proof - interpret comp_fun_commute insort by (fact comp_fun_commute_insort) show ?thesis by (simp add: sorted_list_of_set_def sort_conv_fold fold_set_fold_remdups)qedlemma sorted_list_of_set_remove: assumes "finite A" shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"proof (cases "x ∈ A") case False with assms have "x ∉ set (sorted_list_of_set A)" by simp with False show ?thesis by (simp add: remove1_idem)next case True then obtain B where A: "A = insert x B" by (rule Set.set_insert) with assms show ?thesis by simpqedendlemma sorted_list_of_set_range [simp]: "sorted_list_of_set {m..<n} = [m..<n]" by (rule sorted_distinct_set_unique) simp_allsubsubsection {* @{text lists}: the list-forming operator over sets *}inductive_set lists :: "'a set => 'a list set" for A :: "'a set"where Nil [intro!, simp]: "[]: lists A" | Cons [intro!, simp, no_atp]: "[| a: A; l: lists A|] ==> a#l : lists A"inductive_cases listsE [elim!,no_atp]: "x#l : lists A"inductive_cases listspE [elim!,no_atp]: "listsp A (x # l)"inductive_simps listsp_simps[code]: "listsp A []" "listsp A (x # xs)"lemma listsp_mono [mono]: "A ≤ B ==> listsp A ≤ listsp B"by (rule predicate1I, erule listsp.induct, blast+)lemmas lists_mono = listsp_mono [to_set]lemma listsp_infI: assumes l: "listsp A l" shows "listsp B l ==> listsp (inf A B) l" using lby induct blast+lemmas lists_IntI = listsp_infI [to_set]lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"proof (rule mono_inf [where f=listsp, THEN order_antisym]) show "mono listsp" by (simp add: mono_def listsp_mono) show "inf (listsp A) (listsp B) ≤ listsp (inf A B)" by (blast intro!: listsp_infI)qedlemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]lemma Cons_in_lists_iff[simp]: "x#xs : lists A <-> x:A ∧ xs : lists A"by autolemma append_in_listsp_conv [iff]: "(listsp A (xs @ ys)) = (listsp A xs ∧ listsp A ys)"by (induct xs) autolemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]lemma in_listsp_conv_set: "(listsp A xs) = (∀x ∈ set xs. A x)"-- {* eliminate @{text listsp} in favour of @{text set} *}by (induct xs) autolemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]lemma in_listspD [dest!,no_atp]: "listsp A xs ==> ∀x∈set xs. A x"by (rule in_listsp_conv_set [THEN iffD1])lemmas in_listsD [dest!,no_atp] = in_listspD [to_set]lemma in_listspI [intro!,no_atp]: "∀x∈set xs. A x ==> listsp A xs"by (rule in_listsp_conv_set [THEN iffD2])lemmas in_listsI [intro!,no_atp] = in_listspI [to_set]lemma lists_eq_set: "lists A = {xs. set xs <= A}"by autolemma lists_empty [simp]: "lists {} = {[]}"by autolemma lists_UNIV [simp]: "lists UNIV = UNIV"by autolemma lists_image: "lists (fA) = map f  lists A"proof - { fix xs have "∀x∈set xs. x ∈ f  A ==> xs ∈ map f  lists A" by (induct xs) (auto simp del: map.simps simp add: map.simps[symmetric] intro!: imageI) } then show ?thesis by autoqedsubsubsection {* Inductive definition for membership *}inductive ListMem :: "'a => 'a list => bool"where elem: "ListMem x (x # xs)" | insert: "ListMem x xs ==> ListMem x (y # xs)"lemma ListMem_iff: "(ListMem x xs) = (x ∈ set xs)"apply (rule iffI) apply (induct set: ListMem) apply autoapply (induct xs) apply (auto intro: ListMem.intros)donesubsubsection {* Lists as Cartesian products *}text{*@{text"set_Cons A Xs"}: the set of lists with head drawn from@{term A} and tail drawn from @{term Xs}.*}definition set_Cons :: "'a set => 'a list set => 'a list set" where"set_Cons A XS = {z. ∃x xs. z = x # xs ∧ x ∈ A ∧ xs ∈ XS}"lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])A"by (auto simp add: set_Cons_def)text{*Yields the set of lists, all of the same length as the argument andwith elements drawn from the corresponding element of the argument.*}primrec listset :: "'a set list => 'a list set" where"listset [] = {[]}" |"listset (A # As) = set_Cons A (listset As)"subsection {* Relations on Lists *}subsubsection {* Length Lexicographic Ordering *}text{*These orderings preserve well-foundedness: shorter lists precede longer lists. These ordering are not used in dictionaries.*} primrec -- {*The lexicographic ordering for lists of the specified length*} lexn :: "('a × 'a) set => nat => ('a list × 'a list) set" where"lexn r 0 = {}" |"lexn r (Suc n) = (map_pair (%(x, xs). x#xs) (%(x, xs). x#xs)  (r <*lex*> lexn r n)) Int {(xs, ys). length xs = Suc n ∧ length ys = Suc n}"definition lex :: "('a × 'a) set => ('a list × 'a list) set" where"lex r = (\<Union>n. lexn r n)" -- {*Holds only between lists of the same length*}definition lenlex :: "('a × 'a) set => ('a list × 'a list) set" where"lenlex r = inv_image (less_than <*lex*> lex r) (λxs. (length xs, xs))" -- {*Compares lists by their length and then lexicographically*}lemma wf_lexn: "wf r ==> wf (lexn r n)"apply (induct n, simp, simp)apply(rule wf_subset) prefer 2 apply (rule Int_lower1)apply(rule wf_map_pair_image) prefer 2 apply (rule inj_onI, auto)donelemma lexn_length: "(xs, ys) : lexn r n ==> length xs = n ∧ length ys = n"by (induct n arbitrary: xs ys) autolemma wf_lex [intro!]: "wf r ==> wf (lex r)"apply (unfold lex_def)apply (rule wf_UN)apply (blast intro: wf_lexn, clarify)apply (rename_tac m n)apply (subgoal_tac "m ≠ n") prefer 2 apply blastapply (blast dest: lexn_length not_sym)donelemma lexn_conv: "lexn r n = {(xs,ys). length xs = n ∧ length ys = n ∧ (∃xys x y xs' ys'. xs= xys @ x#xs' ∧ ys= xys @ y # ys' ∧ (x, y):r)}"apply (induct n, simp)apply (simp add: image_Collect lex_prod_def, safe, blast) apply (rule_tac x = "ab # xys" in exI, simp)apply (case_tac xys, simp_all, blast)donelemma lex_conv: "lex r = {(xs,ys). length xs = length ys ∧ (∃xys x y xs' ys'. xs = xys @ x # xs' ∧ ys = xys @ y # ys' ∧ (x, y):r)}"by (force simp add: lex_def lexn_conv)lemma wf_lenlex [intro!]: "wf r ==> wf (lenlex r)"by (unfold lenlex_def) blastlemma lenlex_conv: "lenlex r = {(xs,ys). length xs < length ys | length xs = length ys ∧ (xs, ys) : lex r}"by (simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)lemma Nil_notin_lex [iff]: "([], ys) ∉ lex r"by (simp add: lex_conv)lemma Nil2_notin_lex [iff]: "(xs, []) ∉ lex r"by (simp add:lex_conv)lemma Cons_in_lex [simp]: "((x # xs, y # ys) : lex r) = ((x, y) : r ∧ length xs = length ys | x = y ∧ (xs, ys) : lex r)"apply (simp add: lex_conv)apply (rule iffI) prefer 2 apply (blast intro: Cons_eq_appendI, clarify)apply (case_tac xys, simp, simp)apply blastdonesubsubsection {* Lexicographic Ordering *}text {* Classical lexicographic ordering on lists, ie. "a" < "ab" < "b". This ordering does \emph{not} preserve well-foundedness. Author: N. Voelker, March 2005. *} definition lexord :: "('a × 'a) set => ('a list × 'a list) set" where"lexord r = {(x,y). ∃ a v. y = x @ a # v ∨ (∃ u a b v w. (a,b) ∈ r ∧ x = u @ (a # v) ∧ y = u @ (b # w))}"lemma lexord_Nil_left[simp]: "([],y) ∈ lexord r = (∃ a x. y = a # x)"by (unfold lexord_def, induct_tac y, auto) lemma lexord_Nil_right[simp]: "(x,[]) ∉ lexord r"by (unfold lexord_def, induct_tac x, auto)lemma lexord_cons_cons[simp]: "((a # x, b # y) ∈ lexord r) = ((a,b)∈ r | (a = b & (x,y)∈ lexord r))" apply (unfold lexord_def, safe, simp_all) apply (case_tac u, simp, simp) apply (case_tac u, simp, clarsimp, blast, blast, clarsimp) apply (erule_tac x="b # u" in allE) by forcelemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_conslemma lexord_append_rightI: "∃ b z. y = b # z ==> (x, x @ y) ∈ lexord r"by (induct_tac x, auto) lemma lexord_append_left_rightI: "(a,b) ∈ r ==> (u @ a # x, u @ b # y) ∈ lexord r"by (induct_tac u, auto)lemma lexord_append_leftI: " (u,v) ∈ lexord r ==> (x @ u, x @ v) ∈ lexord r"by (induct x, auto)lemma lexord_append_leftD: "[| (x @ u, x @ v) ∈ lexord r; (! a. (a,a) ∉ r) |] ==> (u,v) ∈ lexord r"by (erule rev_mp, induct_tac x, auto)lemma lexord_take_index_conv: "((x,y) : lexord r) = ((length x < length y ∧ take (length x) y = x) ∨ (∃i. i < min(length x)(length y) & take i x = take i y & (x!i,y!i) ∈ r))" apply (unfold lexord_def Let_def, clarsimp) apply (rule_tac f = "(% a b. a ∨ b)" in arg_cong2) apply auto apply (rule_tac x="hd (drop (length x) y)" in exI) apply (rule_tac x="tl (drop (length x) y)" in exI) apply (erule subst, simp add: min_def) apply (rule_tac x ="length u" in exI, simp) apply (rule_tac x ="take i x" in exI) apply (rule_tac x ="x ! i" in exI) apply (rule_tac x ="y ! i" in exI, safe) apply (rule_tac x="drop (Suc i) x" in exI) apply (drule sym, simp add: drop_Suc_conv_tl) apply (rule_tac x="drop (Suc i) y" in exI) by (simp add: drop_Suc_conv_tl) -- {* lexord is extension of partial ordering List.lex *} lemma lexord_lex: "(x,y) ∈ lex r = ((x,y) ∈ lexord r ∧ length x = length y)" apply (rule_tac x = y in spec) apply (induct_tac x, clarsimp) by (clarify, case_tac x, simp, force)lemma lexord_irreflexive: "ALL x. (x,x) ∉ r ==> (xs,xs) ∉ lexord r"by (induct xs) autotext{* By Ren\'e Thiemann: *}lemma lexord_partial_trans: "(!!x y z. x ∈ set xs ==> (x,y) ∈ r ==> (y,z) ∈ r ==> (x,z) ∈ r) ==> (xs,ys) ∈ lexord r ==> (ys,zs) ∈ lexord r ==> (xs,zs) ∈ lexord r"proof (induct xs arbitrary: ys zs) case Nil from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)next case (Cons x xs yys zzs) from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def by (cases yys, auto) note Cons = Cons[unfolded yys] from Cons(3) have one: "(x,y) ∈ r ∨ x = y ∧ (xs,ys) ∈ lexord r" by auto from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def by (cases zzs, auto) note Cons = Cons[unfolded zzs] from Cons(4) have two: "(y,z) ∈ r ∨ y = z ∧ (ys,zs) ∈ lexord r" by auto { assume "(xs,ys) ∈ lexord r" and "(ys,zs) ∈ lexord r" from Cons(1)[OF _ this] Cons(2) have "(xs,zs) ∈ lexord r" by auto } note ind1 = this { assume "(x,y) ∈ r" and "(y,z) ∈ r" from Cons(2)[OF _ this] have "(x,z) ∈ r" by auto } note ind2 = this from one two ind1 ind2 have "(x,z) ∈ r ∨ x = z ∧ (xs,zs) ∈ lexord r" by blast thus ?case unfolding zzs by autoqedlemma lexord_trans: "[| (x, y) ∈ lexord r; (y, z) ∈ lexord r; trans r |] ==> (x, z) ∈ lexord r"by(auto simp: trans_def intro:lexord_partial_trans)lemma lexord_transI: "trans r ==> trans (lexord r)"by (rule transI, drule lexord_trans, blast) lemma lexord_linear: "(! a b. (a,b)∈ r | a = b | (b,a) ∈ r) ==> (x,y) : lexord r | x = y | (y,x) : lexord r" apply (rule_tac x = y in spec) apply (induct_tac x, rule allI) apply (case_tac x, simp, simp) apply (rule allI, case_tac x, simp, simp) by blastsubsubsection {* Lexicographic combination of measure functions *}text {* These are useful for termination proofs *}definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"lemma wf_measures[simp]: "wf (measures fs)"unfolding measures_defby blastlemma in_measures[simp]: "(x, y) ∈ measures [] = False" "(x, y) ∈ measures (f # fs) = (f x < f y ∨ (f x = f y ∧ (x, y) ∈ measures fs))" unfolding measures_defby autolemma measures_less: "f x < f y ==> (x, y) ∈ measures (f#fs)"by simplemma measures_lesseq: "f x <= f y ==> (x, y) ∈ measures fs ==> (x, y) ∈ measures (f#fs)"by autosubsubsection {* Lifting Relations to Lists: one element *}definition listrel1 :: "('a × 'a) set => ('a list × 'a list) set" where"listrel1 r = {(xs,ys). ∃us z z' vs. xs = us @ z # vs ∧ (z,z') ∈ r ∧ ys = us @ z' # vs}"lemma listrel1I: "[| (x, y) ∈ r; xs = us @ x # vs; ys = us @ y # vs |] ==> (xs, ys) ∈ listrel1 r"unfolding listrel1_def by autolemma listrel1E: "[| (xs, ys) ∈ listrel1 r; !!x y us vs. [| (x, y) ∈ r; xs = us @ x # vs; ys = us @ y # vs |] ==> P |] ==> P"unfolding listrel1_def by autolemma not_Nil_listrel1 [iff]: "([], xs) ∉ listrel1 r"unfolding listrel1_def by blastlemma not_listrel1_Nil [iff]: "(xs, []) ∉ listrel1 r"unfolding listrel1_def by blastlemma Cons_listrel1_Cons [iff]: "(x # xs, y # ys) ∈ listrel1 r <-> (x,y) ∈ r ∧ xs = ys ∨ x = y ∧ (xs, ys) ∈ listrel1 r"by (simp add: listrel1_def Cons_eq_append_conv) (blast)lemma listrel1I1: "(x,y) ∈ r ==> (x # xs, y # xs) ∈ listrel1 r"by (metis Cons_listrel1_Cons)lemma listrel1I2: "(xs, ys) ∈ listrel1 r ==> (x # xs, x # ys) ∈ listrel1 r"by (metis Cons_listrel1_Cons)lemma append_listrel1I: "(xs, ys) ∈ listrel1 r ∧ us = vs ∨ xs = ys ∧ (us, vs) ∈ listrel1 r ==> (xs @ us, ys @ vs) ∈ listrel1 r"unfolding listrel1_defby auto (blast intro: append_eq_appendI)+lemma Cons_listrel1E1[elim!]: assumes "(x # xs, ys) ∈ listrel1 r" and "!!y. ys = y # xs ==> (x, y) ∈ r ==> R" and "!!zs. ys = x # zs ==> (xs, zs) ∈ listrel1 r ==> R" shows Rusing assms by (cases ys) blast+lemma Cons_listrel1E2[elim!]: assumes "(xs, y # ys) ∈ listrel1 r" and "!!x. xs = x # ys ==> (x, y) ∈ r ==> R" and "!!zs. xs = y # zs ==> (zs, ys) ∈ listrel1 r ==> R" shows Rusing assms by (cases xs) blast+lemma snoc_listrel1_snoc_iff: "(xs @ [x], ys @ [y]) ∈ listrel1 r <-> (xs, ys) ∈ listrel1 r ∧ x = y ∨ xs = ys ∧ (x,y) ∈ r" (is "?L <-> ?R")proof assume ?L thus ?R by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)next assume ?R then show ?L unfolding listrel1_def by forceqedlemma listrel1_eq_len: "(xs,ys) ∈ listrel1 r ==> length xs = length ys"unfolding listrel1_def by autolemma listrel1_mono: "r ⊆ s ==> listrel1 r ⊆ listrel1 s"unfolding listrel1_def by blastlemma listrel1_converse: "listrel1 (r^-1) = (listrel1 r)^-1"unfolding listrel1_def by blastlemma in_listrel1_converse: "(x,y) : listrel1 (r^-1) <-> (x,y) : (listrel1 r)^-1"unfolding listrel1_def by blastlemma listrel1_iff_update: "(xs,ys) ∈ (listrel1 r) <-> (∃y n. (xs ! n, y) ∈ r ∧ n < length xs ∧ ys = xs[n:=y])" (is "?L <-> ?R")proof assume "?L" then obtain x y u v where "xs = u @ x # v" "ys = u @ y # v" "(x,y) ∈ r" unfolding listrel1_def by auto then have "ys = xs[length u := y]" and "length u < length xs" and "(xs ! length u, y) ∈ r" by auto then show "?R" by autonext assume "?R" then obtain x y n where "(xs!n, y) ∈ r" "n < size xs" "ys = xs[n:=y]" "x = xs!n" by auto then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) ∈ r" by (auto intro: upd_conv_take_nth_drop id_take_nth_drop) then show "?L" by (auto simp: listrel1_def)qedtext{* Accessible part and wellfoundedness: *}lemma Cons_acc_listrel1I [intro!]: "x ∈ acc r ==> xs ∈ acc (listrel1 r) ==> (x # xs) ∈ acc (listrel1 r)"apply (induct arbitrary: xs set: acc)apply (erule thin_rl)apply (erule acc_induct)apply (rule accI)apply (blast)donelemma lists_accD: "xs ∈ lists (acc r) ==> xs ∈ acc (listrel1 r)"apply (induct set: lists) apply (rule accI) apply simpapply (rule accI)apply (fast dest: acc_downward)donelemma lists_accI: "xs ∈ acc (listrel1 r) ==> xs ∈ lists (acc r)"apply (induct set: acc)apply clarifyapply (rule accI)apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)donelemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"by(metis wf_acc_iff in_lists_conv_set lists_accI lists_accD Cons_in_lists_iff)subsubsection {* Lifting Relations to Lists: all elements *}inductive_set listrel :: "('a × 'b) set => ('a list × 'b list) set" for r :: "('a × 'b) set"where Nil: "([],[]) ∈ listrel r" | Cons: "[| (x,y) ∈ r; (xs,ys) ∈ listrel r |] ==> (x#xs, y#ys) ∈ listrel r"inductive_cases listrel_Nil1 [elim!]: "([],xs) ∈ listrel r"inductive_cases listrel_Nil2 [elim!]: "(xs,[]) ∈ listrel r"inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) ∈ listrel r"inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) ∈ listrel r"lemma listrel_eq_len: "(xs, ys) ∈ listrel r ==> length xs = length ys"by(induct rule: listrel.induct) autolemma listrel_iff_zip [code_unfold]: "(xs,ys) : listrel r <-> length xs = length ys & (∀(x,y) ∈ set(zip xs ys). (x,y) ∈ r)" (is "?L <-> ?R")proof assume ?L thus ?R by induct (auto intro: listrel_eq_len)next assume ?R thus ?L apply (clarify) by (induct rule: list_induct2) (auto intro: listrel.intros)qedlemma listrel_iff_nth: "(xs,ys) : listrel r <-> length xs = length ys & (∀n < length xs. (xs!n, ys!n) ∈ r)" (is "?L <-> ?R")by (auto simp add: all_set_conv_all_nth listrel_iff_zip)lemma listrel_mono: "r ⊆ s ==> listrel r ⊆ listrel s"apply clarify apply (erule listrel.induct)apply (blast intro: listrel.intros)+donelemma listrel_subset: "r ⊆ A × A ==> listrel r ⊆ lists A × lists A"apply clarify apply (erule listrel.induct, auto) donelemma listrel_refl_on: "refl_on A r ==> refl_on (lists A) (listrel r)" apply (simp add: refl_on_def listrel_subset Ball_def)apply (rule allI) apply (induct_tac x) apply (auto intro: listrel.intros)donelemma listrel_sym: "sym r ==> sym (listrel r)" apply (auto simp add: sym_def)apply (erule listrel.induct) apply (blast intro: listrel.intros)+donelemma listrel_trans: "trans r ==> trans (listrel r)" apply (simp add: trans_def)apply (intro allI) apply (rule impI) apply (erule listrel.induct) apply (blast intro: listrel.intros)+donetheorem equiv_listrel: "equiv A r ==> equiv (lists A) (listrel r)"by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans) lemma listrel_rtrancl_refl[iff]: "(xs,xs) : listrel(r^*)"using listrel_refl_on[of UNIV, OF refl_rtrancl]by(auto simp: refl_on_def)lemma listrel_rtrancl_trans: "[| (xs,ys) : listrel(r^*); (ys,zs) : listrel(r^*) |] ==> (xs,zs) : listrel(r^*)"by (metis listrel_trans trans_def trans_rtrancl)lemma listrel_Nil [simp]: "listrel r  {[]} = {[]}"by (blast intro: listrel.intros)lemma listrel_Cons: "listrel r  {x#xs} = set_Cons (r{x}) (listrel r  {xs})"by (auto simp add: set_Cons_def intro: listrel.intros)text {* Relating @{term listrel1}, @{term listrel} and closures: *}lemma listrel1_rtrancl_subset_rtrancl_listrel1: "listrel1 (r^*) ⊆ (listrel1 r)^*"proof (rule subrelI) fix xs ys assume 1: "(xs,ys) ∈ listrel1 (r^*)" { fix x y us vs have "(x,y) : r^* ==> (us @ x # vs, us @ y # vs) : (listrel1 r)^*" proof(induct rule: rtrancl.induct) case rtrancl_refl show ?case by simp next case rtrancl_into_rtrancl thus ?case by (metis listrel1I rtrancl.rtrancl_into_rtrancl) qed } thus "(xs,ys) ∈ (listrel1 r)^*" using 1 by(blast elim: listrel1E)qedlemma rtrancl_listrel1_eq_len: "(x,y) ∈ (listrel1 r)^* ==> length x = length y"by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)lemma rtrancl_listrel1_ConsI1: "(xs,ys) : (listrel1 r)^* ==> (x#xs,x#ys) : (listrel1 r)^*"apply(induct rule: rtrancl.induct) apply simpby (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)lemma rtrancl_listrel1_ConsI2: "(x,y) ∈ r^* ==> (xs, ys) ∈ (listrel1 r)^* ==> (x # xs, y # ys) ∈ (listrel1 r)^*" by (blast intro: rtrancl_trans rtrancl_listrel1_ConsI1 subsetD[OF listrel1_rtrancl_subset_rtrancl_listrel1 listrel1I1])lemma listrel1_subset_listrel: "r ⊆ r' ==> refl r' ==> listrel1 r ⊆ listrel(r')"by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)lemma listrel_reflcl_if_listrel1: "(xs,ys) : listrel1 r ==> (xs,ys) : listrel(r^*)"by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r^*) = (listrel1 r)^*"proof { fix x y assume "(x,y) ∈ listrel (r^*)" then have "(x,y) ∈ (listrel1 r)^*" by induct (auto intro: rtrancl_listrel1_ConsI2) } then show "listrel (r^*) ⊆ (listrel1 r)^*" by (rule subrelI)next show "listrel (r^*) ⊇ (listrel1 r)^*" proof(rule subrelI) fix xs ys assume "(xs,ys) ∈ (listrel1 r)^*" then show "(xs,ys) ∈ listrel (r^*)" proof induct case base show ?case by(auto simp add: listrel_iff_zip set_zip) next case (step ys zs) thus ?case by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans) qed qedqedlemma rtrancl_listrel1_if_listrel: "(xs,ys) : listrel r ==> (xs,ys) : (listrel1 r)^*"by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)lemma listrel_subset_rtrancl_listrel1: "listrel r ⊆ (listrel1 r)^*"by(fast intro:rtrancl_listrel1_if_listrel)subsection {* Size function *}lemma [measure_function]: "is_measure f ==> is_measure (list_size f)"by (rule is_measure_trivial)lemma [measure_function]: "is_measure f ==> is_measure (option_size f)"by (rule is_measure_trivial)lemma list_size_estimation[termination_simp]: "x ∈ set xs ==> y < f x ==> y < list_size f xs"by (induct xs) autolemma list_size_estimation'[termination_simp]: "x ∈ set xs ==> y ≤ f x ==> y ≤ list_size f xs"by (induct xs) autolemma list_size_map[simp]: "list_size f (map g xs) = list_size (f o g) xs"by (induct xs) autolemma list_size_append[simp]: "list_size f (xs @ ys) = list_size f xs + list_size f ys"by (induct xs, auto)lemma list_size_pointwise[termination_simp]: "(!!x. x ∈ set xs ==> f x ≤ g x) ==> list_size f xs ≤ list_size g xs"by (induct xs) force+subsection {* Monad operation *}definition bind :: "'a list => ('a => 'b list) => 'b list" where"bind xs f = concat (map f xs)"hide_const (open) bindlemma bind_simps [simp]: "List.bind [] f = []" "List.bind (x # xs) f = f x @ List.bind xs f" by (simp_all add: bind_def)subsection {* Transfer *}definition embed_list :: "nat list => int list" where"embed_list l = map int l"definition nat_list :: "int list => bool" where"nat_list l = nat_set (set l)"definition return_list :: "int list => nat list" where"return_list l = map nat l"lemma transfer_nat_int_list_return_embed: "nat_list l --> embed_list (return_list l) = l" unfolding embed_list_def return_list_def nat_list_def nat_set_def apply (induct l) apply autodonelemma transfer_nat_int_list_functions: "l @ m = return_list (embed_list l @ embed_list m)" "[] = return_list []" unfolding return_list_def embed_list_def apply auto apply (induct l, auto) apply (induct m, auto)done(*lemma transfer_nat_int_fold1: "fold f l x = fold (%x. f (nat x)) (embed_list l) x";*)subsection {* Code generation *}subsubsection {* Counterparts for set-related operations *}definition member :: "'a list => 'a => bool" where[code_abbrev]: "member xs x <-> x ∈ set xs"text {* Use @{text member} only for generating executable code. Otherwise use @{prop "x ∈ set xs"} instead --- it is much easier to reason about.*}lemma member_rec [code]: "member (x # xs) y <-> x = y ∨ member xs y" "member [] y <-> False" by (auto simp add: member_def)lemma in_set_member (* FIXME delete candidate *): "x ∈ set xs <-> member xs x" by (simp add: member_def)definition list_all :: "('a => bool) => 'a list => bool" wherelist_all_iff [code_abbrev]: "list_all P xs <-> Ball (set xs) P"definition list_ex :: "('a => bool) => 'a list => bool" wherelist_ex_iff [code_abbrev]: "list_ex P xs <-> Bex (set xs) P"definition list_ex1 :: "('a => bool) => 'a list => bool" wherelist_ex1_iff [code_abbrev]: "list_ex1 P xs <-> (∃! x. x ∈ set xs ∧ P x)"text {* Usually you should prefer @{text "∀x∈set xs"}, @{text "∃x∈set xs"} and @{text "∃!x. x∈set xs ∧ _"} over @{const list_all}, @{const list_ex} and @{const list_ex1} in specifications.*}lemma list_all_simps [simp, code]: "list_all P (x # xs) <-> P x ∧ list_all P xs" "list_all P [] <-> True" by (simp_all add: list_all_iff)lemma list_ex_simps [simp, code]: "list_ex P (x # xs) <-> P x ∨ list_ex P xs" "list_ex P [] <-> False" by (simp_all add: list_ex_iff)lemma list_ex1_simps [simp, code]: "list_ex1 P [] = False" "list_ex1 P (x # xs) = (if P x then list_all (λy. ¬ P y ∨ x = y) xs else list_ex1 P xs)" by (auto simp add: list_ex1_iff list_all_iff)lemma Ball_set_list_all: (* FIXME delete candidate *) "Ball (set xs) P <-> list_all P xs" by (simp add: list_all_iff)lemma Bex_set_list_ex: (* FIXME delete candidate *) "Bex (set xs) P <-> list_ex P xs" by (simp add: list_ex_iff)lemma list_all_append [simp]: "list_all P (xs @ ys) <-> list_all P xs ∧ list_all P ys" by (auto simp add: list_all_iff)lemma list_ex_append [simp]: "list_ex P (xs @ ys) <-> list_ex P xs ∨ list_ex P ys" by (auto simp add: list_ex_iff)lemma list_all_rev [simp]: "list_all P (rev xs) <-> list_all P xs" by (simp add: list_all_iff)lemma list_ex_rev [simp]: "list_ex P (rev xs) <-> list_ex P xs" by (simp add: list_ex_iff)lemma list_all_length: "list_all P xs <-> (∀n < length xs. P (xs ! n))" by (auto simp add: list_all_iff set_conv_nth)lemma list_ex_length: "list_ex P xs <-> (∃n < length xs. P (xs ! n))" by (auto simp add: list_ex_iff set_conv_nth)lemma list_all_cong [fundef_cong]: "xs = ys ==> (!!x. x ∈ set ys ==> f x = g x) ==> list_all f xs = list_all g ys" by (simp add: list_all_iff)lemma list_ex_cong [fundef_cong]: "xs = ys ==> (!!x. x ∈ set ys ==> f x = g x) ==> list_ex f xs = list_ex g ys"by (simp add: list_ex_iff)definition can_select :: "('a => bool) => 'a set => bool" where[code_abbrev]: "can_select P A = (∃!x∈A. P x)"lemma can_select_set_list_ex1 [code]: "can_select P (set A) = list_ex1 P A" by (simp add: list_ex1_iff can_select_def)text {* Executable checks for relations on sets *}definition listrel1p :: "('a => 'a => bool) => 'a list => 'a list => bool" where"listrel1p r xs ys = ((xs, ys) ∈ listrel1 {(x, y). r x y})"lemma [code_unfold]: "(xs, ys) ∈ listrel1 r = listrel1p (λx y. (x, y) ∈ r) xs ys"unfolding listrel1p_def by autolemma [code]: "listrel1p r [] xs = False" "listrel1p r xs [] = False" "listrel1p r (x # xs) (y # ys) <-> r x y ∧ xs = ys ∨ x = y ∧ listrel1p r xs ys"by (simp add: listrel1p_def)+definition lexordp :: "('a => 'a => bool) => 'a list => 'a list => bool" where "lexordp r xs ys = ((xs, ys) ∈ lexord {(x, y). r x y})"lemma [code_unfold]: "(xs, ys) ∈ lexord r = lexordp (λx y. (x, y) ∈ r) xs ys"unfolding lexordp_def by autolemma [code]: "lexordp r xs [] = False" "lexordp r [] (y#ys) = True" "lexordp r (x # xs) (y # ys) = (r x y | (x = y & lexordp r xs ys))"unfolding lexordp_def by autotext {* Bounded quantification and summation over nats. *}lemma atMost_upto [code_unfold]: "{..n} = set [0..<Suc n]" by autolemma atLeast_upt [code_unfold]: "{..<n} = set [0..<n]" by autolemma greaterThanLessThan_upt [code_unfold]: "{n<..<m} = set [Suc n..<m]" by autolemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]lemma greaterThanAtMost_upt [code_unfold]: "{n<..m} = set [Suc n..<Suc m]" by autolemma atLeastAtMost_upt [code_unfold]: "{n..m} = set [n..<Suc m]" by autolemma all_nat_less_eq [code_unfold]: "(∀m<n::nat. P m) <-> (∀m ∈ {0..<n}. P m)" by autolemma ex_nat_less_eq [code_unfold]: "(∃m<n::nat. P m) <-> (∃m ∈ {0..<n}. P m)" by autolemma all_nat_less [code_unfold]: "(∀m≤n::nat. P m) <-> (∀m ∈ {0..n}. P m)" by autolemma ex_nat_less [code_unfold]: "(∃m≤n::nat. P m) <-> (∃m ∈ {0..n}. P m)" by autolemma setsum_set_upt_conv_listsum_nat [code_unfold]: "setsum f (set [m..<n]) = listsum (map f [m..<n])" by (simp add: interv_listsum_conv_setsum_set_nat)text {* Summation over ints. *}lemma greaterThanLessThan_upto [code_unfold]: "{i<..<j::int} = set [i+1..j - 1]"by autolemma atLeastLessThan_upto [code_unfold]: "{i..<j::int} = set [i..j - 1]"by autolemma greaterThanAtMost_upto [code_unfold]: "{i<..j::int} = set [i+1..j]"by autolemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]lemma setsum_set_upto_conv_listsum_int [code_unfold]: "setsum f (set [i..j::int]) = listsum (map f [i..j])" by (simp add: interv_listsum_conv_setsum_set_int)subsubsection {* Optimizing by rewriting *}definition null :: "'a list => bool" where [code_abbrev]: "null xs <-> xs = []"text {* Efficient emptyness check is implemented by @{const null}.*}lemma null_rec [code]: "null (x # xs) <-> False" "null [] <-> True" by (simp_all add: null_def)lemma eq_Nil_null: (* FIXME delete candidate *) "xs = [] <-> null xs" by (simp add: null_def)lemma equal_Nil_null [code_unfold]: "HOL.equal xs [] <-> null xs" by (simp add: equal eq_Nil_null)definition maps :: "('a => 'b list) => 'a list => 'b list" where [code_abbrev]: "maps f xs = concat (map f xs)"definition map_filter :: "('a => 'b option) => 'a list => 'b list" where [code_post]: "map_filter f xs = map (the o f) (filter (λx. f x ≠ None) xs)"text {* Operations @{const maps} and @{const map_filter} avoid intermediate lists on execution -- do not use for proving.*}lemma maps_simps [code]: "maps f (x # xs) = f x @ maps f xs" "maps f [] = []" by (simp_all add: maps_def)lemma map_filter_simps [code]: "map_filter f (x # xs) = (case f x of None => map_filter f xs | Some y => y # map_filter f xs)" "map_filter f [] = []" by (simp_all add: map_filter_def split: option.split)lemma concat_map_maps: (* FIXME delete candidate *) "concat (map f xs) = maps f xs" by (simp add: maps_def)lemma map_filter_map_filter [code_unfold]: "map f (filter P xs) = map_filter (λx. if P x then Some (f x) else None) xs" by (simp add: map_filter_def)text {* Optimized code for @{text"∀i∈{a..b::int}"} and @{text"∀n:{a..<b::nat}"}and similiarly for @{text"∃"}. *}definition all_interval_nat :: "(nat => bool) => nat => nat => bool" where "all_interval_nat P i j <-> (∀n ∈ {i..<j}. P n)"lemma [code]: "all_interval_nat P i j <-> i ≥ j ∨ P i ∧ all_interval_nat P (Suc i) j"proof - have *: "!!n. P i ==> ∀n∈{Suc i..<j}. P n ==> i ≤ n ==> n < j ==> P n" proof - fix n assume "P i" "∀n∈{Suc i..<j}. P n" "i ≤ n" "n < j" then show "P n" by (cases "n = i") simp_all qed show ?thesis by (auto simp add: all_interval_nat_def intro: *)qedlemma list_all_iff_all_interval_nat [code_unfold]: "list_all P [i..<j] <-> all_interval_nat P i j" by (simp add: list_all_iff all_interval_nat_def)lemma list_ex_iff_not_all_inverval_nat [code_unfold]: "list_ex P [i..<j] <-> ¬ (all_interval_nat (Not o P) i j)" by (simp add: list_ex_iff all_interval_nat_def)definition all_interval_int :: "(int => bool) => int => int => bool" where "all_interval_int P i j <-> (∀k ∈ {i..j}. P k)"lemma [code]: "all_interval_int P i j <-> i > j ∨ P i ∧ all_interval_int P (i + 1) j"proof - have *: "!!k. P i ==> ∀k∈{i+1..j}. P k ==> i ≤ k ==> k ≤ j ==> P k" proof - fix k assume "P i" "∀k∈{i+1..j}. P k" "i ≤ k" "k ≤ j" then show "P k" by (cases "k = i") simp_all qed show ?thesis by (auto simp add: all_interval_int_def intro: *)qedlemma list_all_iff_all_interval_int [code_unfold]: "list_all P [i..j] <-> all_interval_int P i j" by (simp add: list_all_iff all_interval_int_def)lemma list_ex_iff_not_all_inverval_int [code_unfold]: "list_ex P [i..j] <-> ¬ (all_interval_int (Not o P) i j)" by (simp add: list_ex_iff all_interval_int_def)text {* optimized code (tail-recursive) for @{term length} *}definition gen_length :: "nat => 'a list => nat"where "gen_length n xs = n + length xs"lemma gen_length_code [code]: "gen_length n [] = n" "gen_length n (x # xs) = gen_length (Suc n) xs"by(simp_all add: gen_length_def)declare list.size(3-4)[code del]lemma length_code [code]: "length = gen_length 0"by(simp add: gen_length_def fun_eq_iff)hide_const (open) member null maps map_filter all_interval_nat all_interval_int gen_lengthsubsubsection {* Pretty lists *}ML {*(* Code generation for list literals. *)signature LIST_CODE =sig val implode_list: string -> string -> Code_Thingol.iterm -> Code_Thingol.iterm list option val default_list: int * string -> (Code_Printer.fixity -> Code_Thingol.iterm -> Pretty.T) -> Code_Printer.fixity -> Code_Thingol.iterm -> Code_Thingol.iterm -> Pretty.T val add_literal_list: string -> theory -> theoryend;structure List_Code : LIST_CODE =structopen Basic_Code_Thingol;fun implode_list nil' cons' t = let fun dest_cons (IConst { name = c, ... } $ t1 \$ t2) =          if c = cons'          then SOME (t1, t2)          else NONE      | dest_cons _ = NONE;    val (ts, t') = Code_Thingol.unfoldr dest_cons t;  in case t'   of IConst { name = c, ... } => if c = nil' then SOME ts else NONE    | _ => NONE  end;fun default_list (target_fxy, target_cons) pr fxy t1 t2 =  Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (    pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,    Code_Printer.str target_cons,    pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2  );fun add_literal_list target =  let    fun pretty literals [nil', cons'] pr thm vars fxy [(t1, _), (t2, _)] =      case Option.map (cons t1) (implode_list nil' cons' t2)       of SOME ts =>            Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)        | NONE =>            default_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;  in Code_Target.add_const_syntax target @{const_name Cons}    (SOME (Code_Printer.complex_const_syntax (2, ([@{const_name Nil}, @{const_name Cons}], pretty))))  endend;*}code_type list  (SML "_ list")  (OCaml "_ list")  (Haskell "![(_)]")  (Scala "List[(_)]")code_const Nil  (SML "[]")  (OCaml "[]")  (Haskell "[]")  (Scala "!Nil")code_instance list :: equal  (Haskell -)code_const "HOL.equal :: 'a list => 'a list => bool"  (Haskell infix 4 "==")code_reserved SML  listcode_reserved OCaml  listsetup {* fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"] *}subsubsection {* Use convenient predefined operations *}code_const "op @"  (SML infixr 7 "@")  (OCaml infixr 6 "@")  (Haskell infixr 5 "++")  (Scala infixl 7 "++")code_const map  (Haskell "map")code_const filter  (Haskell "filter")code_const concat  (Haskell "concat")code_const List.maps  (Haskell "concatMap")code_const rev  (Haskell "reverse")code_const zip  (Haskell "zip")code_const List.null  (Haskell "null")code_const takeWhile  (Haskell "takeWhile")code_const dropWhile  (Haskell "dropWhile")code_const list_all  (Haskell "all")code_const list_ex  (Haskell "any")subsubsection {* Implementation of sets by lists *}lemma is_empty_set [code]:  "Set.is_empty (set xs) <-> List.null xs"  by (simp add: Set.is_empty_def null_def)lemma empty_set [code]:  "{} = set []"  by simplemma UNIV_coset [code]:  "UNIV = List.coset []"  by simplemma compl_set [code]:  "- set xs = List.coset xs"  by simplemma compl_coset [code]:  "- List.coset xs = set xs"  by simplemma [code]:  "x ∈ set xs <-> List.member xs x"  "x ∈ List.coset xs <-> ¬ List.member xs x"  by (simp_all add: member_def)lemma insert_code [code]:  "insert x (set xs) = set (List.insert x xs)"  "insert x (List.coset xs) = List.coset (removeAll x xs)"  by simp_alllemma remove_code [code]:  "Set.remove x (set xs) = set (removeAll x xs)"  "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"  by (simp_all add: remove_def Compl_insert)lemma filter_set [code]:  "Set.filter P (set xs) = set (filter P xs)"  by autolemma image_set [code]:  "image f (set xs) = set (map f xs)"  by simplemma subset_code [code]:  "set xs ≤ B <-> (∀x∈set xs. x ∈ B)"  "A ≤ List.coset ys <-> (∀y∈set ys. y ∉ A)"  "List.coset [] ≤ set [] <-> False"  by autotext {* A frequent case – avoid intermediate sets *}lemma [code_unfold]:  "set xs ⊆ set ys <-> list_all (λx. x ∈ set ys) xs"  by (auto simp: list_all_iff)lemma Ball_set [code]:  "Ball (set xs) P <-> list_all P xs"  by (simp add: list_all_iff)lemma Bex_set [code]:  "Bex (set xs) P <-> list_ex P xs"  by (simp add: list_ex_iff)lemma card_set [code]:  "card (set xs) = length (remdups xs)"proof -  have "card (set (remdups xs)) = length (remdups xs)"    by (rule distinct_card) simp  then show ?thesis by simpqedlemma the_elem_set [code]:  "the_elem (set [x]) = x"  by simplemma Pow_set [code]:  "Pow (set []) = {{}}"  "Pow (set (x # xs)) = (let A = Pow (set xs) in A ∪ insert x  A)"  by (simp_all add: Pow_insert Let_def)lemma setsum_code [code]:  "setsum f (set xs) = listsum (map f (remdups xs))"by (simp add: listsum_distinct_conv_setsum_set)definition map_project :: "('a => 'b option) => 'a set => 'b set" where  "map_project f A = {b. ∃ a ∈ A. f a = Some b}"lemma [code]:  "map_project f (set xs) = set (List.map_filter f xs)"  by (auto simp add: map_project_def map_filter_def image_def)hide_const (open) map_projecttext {* Operations on relations *}lemma product_code [code]:  "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"  by (auto simp add: Product_Type.product_def)lemma Id_on_set [code]:  "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"  by (auto simp add: Id_on_def)lemma [code]:  "R  S = List.map_project (%(x, y). if x : S then Some y else None) R"unfolding map_project_def by (auto split: prod.split split_if_asm)lemma trancl_set_ntrancl [code]:  "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"  by (simp add: finite_trancl_ntranl)lemma set_relcomp [code]:  "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"  by (auto simp add: Bex_def)lemma wf_set [code]:  "wf (set xs) = acyclic (set xs)"  by (simp add: wf_iff_acyclic_if_finite)end`