theory Ex2_5
  imports Main
begin

datatype form = T | Var nat | And form form | Xor form form

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor x y= ((x \<and> \<not>y) \<or> (\<not>x \<and> y))"

notation
  xor (infixr "<**>" 50)

declare xor_def [simp]

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
  "evalf _ T = True"|
  "evalf p (Var n) = p n"|
  "evalf p (And f1 f2) = (evalf p f1 \<and> evalf p f2)"|
  "evalf p (Xor f1 f2) = (evalf p f1 <**>  evalf p f2)"

primrec evalm :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> bool" where
  "evalm P [] = True"|
  "evalm P (x#xs) = (P x \<and> evalm P xs)"

primrec evalp :: "(nat \<Rightarrow> bool) \<Rightarrow> nat list list \<Rightarrow> bool" where
  "evalp P [] = False"|
  "evalp P (x#xs) = (evalm P x <**> evalp P xs)"

lemma "((a <**> b)  \<and> (c <**> d)) = ((a \<and> c) <**> (a \<and> d) <**> (b \<and> c) <**> (b \<and> d))" by auto

primrec mulpp :: "nat list list \<Rightarrow> nat list list \<Rightarrow> nat list list " where
  "mulpp [] _ = [] "|
  "mulpp (x#xs) ys = (map (op @ x) ys) @ mulpp xs ys"

primrec poly :: "form \<Rightarrow> nat list list" where
  "poly T = [[]]"|
  "poly (Var i)= [[i]]"|
  "poly (And f1 f2) = mulpp (poly f1) (poly f2)"|
  "poly (Xor f1 f2) = poly f1 @ poly f2"

lemma helper1 : "evalp e (xs @ ys) = (evalp e xs <**> evalp e ys)"  by (induction xs ; auto)

lemma helper2 : "evalp e (map (op @ a) f2) = (evalp e [a] \<and> evalp e f2)"
proof (induction f2)
  case Nil
  then show ?case by simp
next
  case (Cons aa f2)
  assume hyp:"evalp e (map (op @ a) f2) = (evalp e [a] \<and> evalp e f2)"
  have "evalp e (map (op @ a) (aa # f2)) = evalp e ((a @ aa) # map (op @ a) f2)" by simp
  also have "\<dots> = (evalm e (a @ aa) <**> evalp e (map (op @ a) f2))" by simp
  also have "\<dots> =  (evalm e (a @ aa) <**> (evalp e [a] \<and> evalp e f2))" using hyp by simp
  finally have tmp:"evalp e (map (op @ a) (aa # f2)) = (evalm e (a @ aa) <**> (evalp e [a] \<and> evalp e f2))" by assumption

  have tmp2:"evalm e (a @ aa) = (evalm e a \<and> evalm e aa)" by (induction a ; simp)

  have "(evalp e [a] \<and> evalp e (aa # f2)) = (evalm e a \<and> evalp e (aa # f2))" by simp
  also have "\<dots> = (evalm e a \<and> (evalm e aa <**> evalp e  f2))" by simp
  also have "\<dots> = ((evalm e a \<and> evalm e aa) <**> (evalm e a  \<and> evalp e  f2))" by auto
  also have "\<dots> = ((evalm e (a@aa)) <**> (evalm e a  \<and> evalp e  f2))" using tmp2 by simp
  also have "\<dots> = ((evalm e (a@aa)) <**> (evalp e [a]  \<and> evalp e  f2))" by simp
  finally  show ?case using tmp by simp
qed

lemma helper3: "evalp e (mulpp f1 f2) = (evalp e f1 \<and> evalp e f2)"
proof (induction f1)
  case Nil
  then show ?case by simp
next
  case (Cons a f1)
  assume hyp:"evalp e (mulpp f1 f2) = (evalp e f1 \<and> evalp e f2)"

  have "evalp e (mulpp (a # f1) f2) = evalp e (map (op @ a) f2 @ mulpp f1 f2)" by simp
  also have "\<dots> = (evalp e (map (op @ a) f2) <**> evalp e (mulpp f1 f2))" using helper1 by simp
  also have "\<dots> = (evalp e (map (op @ a) f2) <**> ((evalp e f1 \<and> evalp e f2)))" using hyp by simp
  finally have tmp1:"evalp e (mulpp (a # f1) f2) = (evalp e (map (op @ a) f2) <**> (evalp e f1 \<and> evalp e f2))" by assumption

  have "(evalp e (a # f1) \<and> evalp e f2) = ((evalm e a <**> evalp e f1) \<and> evalp e f2)" by simp
  also have "\<dots> = ((evalm e a \<and> evalp e f2 ) <**> (evalp e f1 \<and> evalp e f2))" by auto
  also have "\<dots> = (evalp e (map (op @ a) f2) <**> (evalp e f1 \<and> evalp e f2))" using helper2 by simp
  finally show "evalp e (mulpp (a # f1) f2) = (evalp e (a # f1) \<and> evalp e f2)" using tmp1 by simp
qed

theorem poly_correct : "evalf e f = evalp e (poly f)"
proof (induction f)
  case T
  then show ?case by simp
next
  case (Var x)
  then show ?case by simp
next
  case (And f1 f2)
  then show ?case using helper3 by simp
next
  case (Xor f1 f2)
  then show ?case by (simp add: helper1)
qed

github-repos/isabelle/SvenWille-ExerciseSolutions_New/ExerciseSolutions_New-b8243e7a669846c64e2f5520dae88ff41265d233/Isabelle/2. Trees and other inductive data types/Ex2_5.thy


theory ex3_2
imports Main begin

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

datatype aexp = N int | V vname | Plus aexp aexp

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N (i\<^sub>1+i\<^sub>2)"|
"plus (N i) a = (if i=0 then a else Plus (N i) a)"|
"plus a (N i) = (if i=0 then a else Plus a (N i))"|
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"

fun sum_n :: "aexp \<Rightarrow> int" where
"sum_n (N a) = a" |
"sum_n (Plus a b) = (sum_n a) + (sum_n b)" |
"sum_n (V x) = 0"

fun sum_v :: "aexp \<Rightarrow> aexp" where
"sum_v  (N a) = N 0" |
"sum_v  (Plus a b) = Plus (sum_v a) (sum_v b)" |
"sum_v  (V x) = V x"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp a = asimp (Plus (sum_v a) (N (sum_n a)))"

lemma aval_plus [simp]:"aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply(auto)
done

lemma "aval (full_asimp a) s = aval a s"
apply(induction a)
apply(auto)
done

value "full_asimp (Plus (Plus (N 0) (N 7)) (Plus (V x) (N 8)))"

end


(*  Author:      Christian Sternagel
    Maintainer:  Christian Sternagel
*)

theory Efficient_Sort
imports "~~/src/HOL/Library/Multiset"
begin

text {*
A high-level overview of this formalization as well as some experimental data is
to be found in \cite{Sternagel2012}.
*}

section {* Chaining Lists by Predicates *}

text {*
Make sure that some binary predicate @{text P} is satisfied between
every two consecutive elements of a list. We call such a list a
\emph{chain} in the following.
*}
inductive
  linked :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool"
  for P::"'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  Nil[iff]: "linked P []"
| singleton[iff]: "linked P [x]"
| many: "P x y \<Longrightarrow> linked P (y#ys) \<Longrightarrow> linked P (x#y#ys)"

declare eqTrueI[OF Nil, code] eqTrueI[OF singleton, code]

lemma linked_many_eq[simp, code]:
  "linked P (x#y#zs) \<longleftrightarrow> P x y \<and> linked P (y#zs)"
  by (blast intro: linked.many elim: linked.cases)

text {* Take the longest prefix of a list that forms a chain. *}
fun take_chain :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "take_chain a P [] = []"
| "take_chain a P (x#xs) = (if P a x
    then x # take_chain x P xs
    else [])"

text {* Drop the longest prefix of a list that forms a chain. *}
fun drop_chain :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "drop_chain a P [] = []"
| "drop_chain a P (x#xs) = (if P a x
    then drop_chain x P xs
    else x#xs)"

lemma take_chain_drop_chain_id[simp]:
  "take_chain a P xs @ drop_chain a P xs = xs"
  by (induct xs arbitrary: a) simp_all

lemma linked_take_chain:
  "linked P (x # take_chain x P xs)"
  by (induct xs arbitrary: x) simp_all

lemma linked_rev_take_chain_append:
  "linked P (x#ys) \<Longrightarrow> linked P (rev (take_chain x (\<lambda>x y. P y x) xs) @ x#ys)"
  by (induct xs arbitrary: x ys) simp_all

lemma linked_rev_take_chain:
  "linked P (rev (take_chain x (\<lambda>x y. P y x) xs) @ [x])"
  using linked_rev_take_chain_append[of P x "[]" xs] by simp

lemma linked_append:
  "linked P (xs@ys) \<longleftrightarrow> linked P xs \<and> linked P ys
    \<and> (if xs \<noteq> [] \<and> ys \<noteq> [] then P (last xs) (hd ys) else True)"
    (is "?lhs = ?rhs")
proof
  assume "?lhs" thus "?rhs"
  proof (induct xs)
    case (Cons x xs) thus ?case by (cases xs, simp_all) (cases ys, auto)
  qed simp
next
  assume "?rhs" thus "?lhs"
  proof (induct xs)
    case (Cons x xs) thus ?case by (cases ys, auto) (cases xs, auto)
  qed simp
qed

lemma length_drop_chain[termination_simp]:
  "length (drop_chain b P xs) \<le> length xs" (is "?P b xs")
proof (induct xs arbitrary: b rule: length_induct)
  fix xs::"'a list" and b
  assume IH: "\<forall>ys. length ys < length xs \<longrightarrow> (\<forall>x. ?P x ys)"
  show "?P b xs"
  proof (cases xs)
    case (Cons y ys) with IH[rule_format, of ys y] show ?thesis by simp
  qed simp
qed

lemma take_chain_map[simp]:
  "take_chain (f x) P (map f xs) = map f (take_chain x (\<lambda>x y. P (f x) (f y)) xs)"
  by (induct xs arbitrary: x) simp_all

subsection {* Sorted is a Special Case of Linked *}

lemma (in linorder) linked_le_sorted_conv[simp]:
  "linked (op \<le>) xs = sorted xs"
proof
  assume "sorted xs" thus "linked (op \<le>) xs"
  proof (induct xs rule: sorted.induct)
    case (Cons xs x) thus ?case by (cases xs) simp_all
  qed simp
qed (induct xs rule: linked.induct, simp_all)

lemma (in linorder) linked_less_imp_sorted:
  "linked (op <) xs \<Longrightarrow> sorted xs"
  by (induct xs rule: linked.induct) simp_all

abbreviation (in linorder) (input) lt :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "lt key x y \<equiv> key x < key y"

abbreviation (in linorder) (input) le :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "le key x y \<equiv> key x \<le> key y"

abbreviation (in linorder) (input) gt :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "gt key x y \<equiv> key x > key y"

abbreviation (in linorder) (input) ge :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool" where
  "ge key x y \<equiv> key x \<ge> key y"

lemma (in linorder) sorted_take_chain_le[simp]:
  "sorted (key x # map key (take_chain x (le key) xs))"
  using linked_take_chain[of "op \<le>", of "key x" "map key xs"] by simp

lemma (in linorder) sorted_rev_take_chain_gt_append:
  assumes "linked (op <) (key x # map key ys)"
  shows "sorted (map key (rev (take_chain x (gt key) xs)) @ key x # map key ys)"
  using linked_less_imp_sorted[OF linked_rev_take_chain_append[OF assms, of "map key xs"]]
    by (simp add: rev_map)

lemma multiset_of_take_chain_drop_chain[simp]:
  "multiset_of (take_chain x P xs) + multiset_of (drop_chain x P xs) = multiset_of xs"
  by (induct xs arbitrary: x) (simp_all add: ac_simps)

lemma multiset_of_drop_chain_take_chain[simp]:
  "multiset_of (drop_chain x P xs) + multiset_of (take_chain x P xs) = multiset_of xs"
  by (induct xs arbitrary: x) (simp_all add: ac_simps)

section {* GHC Version of Mergesort *}

text {*
In the following we show that the mergesort implementation
used in GHC (see @{url "http://haskell.org/ghc/docs/7.0-latest/html/libraries/base-4.3.1.0/src/Data-List.html#sort"})
is a correct and stable sorting algorithm. Furthermore, experimental
data suggests that generated code for this implementation is much more
efficient than for the implementation provided by @{theory Multiset}.
*}
context linorder
begin

text {*
Split a list into chunks of ascending and descending parts, where
descending parts are reversed. Hence, the result is a list of
sorted lists.
*}
fun sequences :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list list"
  and asc :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> ('b list \<Rightarrow> 'b list) \<Rightarrow> 'b list \<Rightarrow> 'b list list"
  and desc :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list list"
where
  "sequences key (a#b#xs) =
    (if key a > key b then desc key b [a] xs else asc key b (op # a) xs)"
| "sequences key xs = [xs]"
| "asc key a f (b#bs) = (if \<not> key a > key b
    then asc key b (f \<circ> op # a) bs
    else f [a] # sequences key (b#bs))"
| "asc key a f bs = f [a] # sequences key bs"
| "desc key a as (b#bs) = (if key a > key b
    then desc key b (a#as) bs
    else (a#as) # sequences key (b#bs))"
| "desc key a as bs = (a#as) # sequences key bs"

fun merge :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
  "merge key (a#as) (b#bs) = (if key a > key b
    then b # merge key (a#as) bs
    else a # merge key as (b#bs))"
| "merge key [] bs = bs"
| "merge key as [] = as"

fun merge_pairs :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list list \<Rightarrow> 'b list list" where
  "merge_pairs key (a#b#xs) = merge key a b # merge_pairs key xs"
| "merge_pairs key xs = xs"

lemma merge_Nil2[simp]: "merge key as [] = as" by (cases as) simp_all

lemma length_merge[simp]:
  "length (merge key xs ys) = length xs + length ys"
  by (induct xs ys rule: merge.induct) simp_all

lemma merge_pairs_length[termination_simp]:
  "length (merge_pairs key xs) \<le> length xs"
  by (induct xs rule: merge_pairs.induct) simp_all

fun merge_all :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list list \<Rightarrow> 'b list" where
  "merge_all key [] = []"
| "merge_all key [x] = x"
| "merge_all key xs = merge_all key (merge_pairs key xs)"

lemma multiset_of_merge[simp]:
  "multiset_of (merge key xs ys) = multiset_of xs + multiset_of ys"
  by (induct xs ys rule: merge.induct) (simp_all add: ac_simps)

lemma set_merge[simp]:
  "set (merge key xs ys) = set xs \<union> set ys"
  unfolding set_of_multiset_of[symmetric] by simp

lemma multiset_of_concat_merge_pairs[simp]:
  "multiset_of (concat (merge_pairs key xs)) = multiset_of (concat xs)"
  by (induct xs rule: merge_pairs.induct) (auto simp: ac_simps)

lemma set_concat_merge_pairs[simp]:
  "set (concat (merge_pairs key xs)) = set (concat xs)"
  unfolding set_of_multiset_of[symmetric] by simp

lemma multiset_of_merge_all[simp]:
  "multiset_of (merge_all key xs) = multiset_of (concat xs)"
  by (induct xs rule: merge_all.induct) (simp_all add: ac_simps)

lemma set_merge_all[simp]:
  "set (merge_all key xs) = set (concat xs)"
  unfolding set_of_multiset_of[symmetric] by simp

lemma sorted_merge[simp]:
  assumes "sorted (map key xs)" and "sorted (map key ys)"
  shows "sorted (map key (merge key xs ys))"
  using assms by (induct xs ys rule: merge.induct) (auto simp: sorted_Cons)

lemma sorted_merge_pairs[simp]:
  assumes "\<forall>x\<in>set xs. sorted (map key x)"
  shows "\<forall>x\<in>set (merge_pairs key xs). sorted (map key x)"
  using assms by (induct xs rule: merge_pairs.induct) simp_all

lemma sorted_merge_all:
  assumes "\<forall>x\<in>set xs. sorted (map key x)"
  shows "sorted (map key (merge_all key xs))"
  using assms by (induct xs rule: merge_all.induct) simp_all

lemma desc_take_chain_drop_chain_conv[simp]:
  "desc key a bs xs
    = (rev (take_chain a (gt key) xs) @ a # bs) # sequences key (drop_chain a (gt key) xs)"
proof (induct xs arbitrary: a bs)
  case (Cons x xs) thus ?case by (cases "key a < key x") simp_all
qed simp

lemma asc_take_chain_drop_chain_conv_append:
  assumes "\<And>xs ys. f (xs@ys) = f xs @ ys"
  shows "asc key a (f \<circ> op @ as) xs
    = (f as @ a # take_chain a (le key) xs) # sequences key (drop_chain a (le key) xs)"
using assms
proof (induct xs arbitrary: as a)
  case (Cons x xs)
  show ?case
  proof (cases "le key a x")
    case False with Cons show ?thesis by auto
  next
    case True
    with Cons(1)[of "x" "as@[a]"] and Cons(2)
      show ?thesis by (simp add: o_def)
  qed
qed simp

lemma asc_take_chain_drop_chain_conv[simp]:
  "asc key b (op # a) xs
    = (a # b # take_chain b (le key) xs) # sequences key (drop_chain b (le key) xs)"
proof -
  let ?f = "op # a"
  have "\<And>xs ys. (op # a) (xs@ys) = (op # a) xs @ ys" by simp
  from asc_take_chain_drop_chain_conv_append[of ?f key b "[]" xs, OF this]
    show ?thesis by (simp add: o_def)
qed

lemma sequences_induct[case_names Nil singleton many]:
  assumes "\<And>key. P key []" and "\<And>key x. P key [x]"
    and "\<And>key a b xs.
    (le key a b \<Longrightarrow> P key (drop_chain b (le key) xs))
    \<Longrightarrow> (\<not> le key a b \<Longrightarrow> P key (drop_chain b (gt key) xs))
    \<Longrightarrow> P key (a#b#xs)"
  shows "P key xs"
  using assms by (induction_schema) (pat_completeness, lexicographic_order)

lemma sorted_sequences:
  "\<forall>x\<in>set (sequences key xs). sorted (map key x)"
proof (induct key xs rule: sequences_induct)
  case (many key a b xs)
  thus ?case using sorted_rev_take_chain_gt_append[of key b "[a]" xs]
    by (cases "le key a b") auto
qed simp_all

lemma multiset_of_sequences[simp]:
  "multiset_of (concat (sequences key xs)) = multiset_of xs"
  by (induct key xs rule: sequences_induct) (simp_all add: ac_simps)

lemma filter_by_key_drop_chain_gt[simp]:
  assumes "key b \<le> key a"
  shows "[y\<leftarrow>drop_chain b (gt key) xs. key a = key y] = [y\<leftarrow>xs. key a = key y]"
  using assms by (induct xs arbitrary: b) auto

lemma filter_by_key_take_chain_gt[simp]:
  assumes "key b \<le> key a"
  shows "[y\<leftarrow>take_chain b (gt key) xs. key a = key y] = []"
  using assms by (induct xs arbitrary: b) auto

lemma filter_take_chain_drop_chain[simp]:
  "filter P (take_chain x Q xs) @ filter P (drop_chain x Q xs) = filter P xs"
  by (simp add: filter_append[symmetric])

lemma filter_by_key_rev_take_chain_gt_conv[simp]:
  "[y\<leftarrow>rev (take_chain b (gt key) xs). key x = key y]
    = [y\<leftarrow>take_chain b (gt key) xs. key x = key y]"
  by (induct xs arbitrary: b) auto

lemma filter_by_key_sequences[simp]:
  "[y\<leftarrow>concat (sequences key xs). key x = key y]
    = [y\<leftarrow>xs. key x = key y]" (is ?P)
  by (induct key xs rule: sequences_induct) auto

lemma merge_simp[simp]:
  assumes "sorted (map key xs)"
  shows "merge key xs (y#ys)
    = takeWhile (ge key y) xs @ y # merge key (dropWhile (ge key y) xs) ys"
  using assms by (induct xs arbitrary: y ys) (auto simp: sorted_Cons)

lemma sorted_map_dropWhile[simp]:
  assumes "sorted (map key xs)"
  shows "sorted (map key (dropWhile (ge key y) xs))"
  using sorted_dropWhile[OF assms] by (simp add: dropWhile_map o_def)

lemma sorted_merge_induct[consumes 1, case_names Nil IH]:
  assumes "sorted (map key xs)"
    and "\<And>xs. P xs []"
    and "\<And>xs y ys. sorted (map key xs) \<Longrightarrow> P (dropWhile (ge key y) xs) ys
      \<Longrightarrow> P xs (y#ys)"
  shows "P xs ys"
  using assms(2-) assms(1)
  by (induction_schema) (case_tac ys, simp_all, lexicographic_order)

lemma filter_by_key_dropWhile[simp]:
  assumes "sorted (map key xs)"
  shows "[y\<leftarrow>dropWhile (\<lambda>x. key x \<le> key z) xs. key z = key y] = []"
    (is "[y\<leftarrow>dropWhile ?P xs. key z = key y] = []")
using assms
proof (induct xs rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  hence IH: "[y\<leftarrow>dropWhile ?P xs. key z = key y] = []"
    by (auto simp: sorted_append)
  show ?case
  proof (cases "\<forall>z\<in>set xs. ?P z")
    case True
    show ?thesis
      using dropWhile_append2[of xs ?P "[x]"] and True by simp
  next
    case False
    then obtain a where a: "a \<in> set xs" "\<not> ?P a" by auto
    show ?thesis
      unfolding dropWhile_append1[of a xs ?P, OF a]
      using snoc and False by (auto simp: IH sorted_append)
  qed
qed

lemma filter_by_key_takeWhile[simp]:
  assumes "sorted (map key xs)"
  shows "[y\<leftarrow>takeWhile (\<lambda>x. key x \<le> key z) xs. key z = key y]
    = [y\<leftarrow>xs. key z = key y]"
    (is "[y\<leftarrow>takeWhile ?P xs. key z = key y] = _")
using assms
proof (induct xs rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc x xs)
  hence IH: "[y\<leftarrow>takeWhile ?P xs. key z = key y] = [y\<leftarrow>xs. key z = key y]"
    by (auto simp: sorted_append)
  show ?case
  proof (cases "\<forall>z\<in>set xs. ?P z")
    case True
    show ?thesis
      using takeWhile_append2[of xs ?P "[x]"] and True by simp
  next
    case False
    then obtain a where a: "a \<in> set xs" "\<not> ?P a" by auto
    show ?thesis
      unfolding takeWhile_append1[of a xs ?P, OF a]
      using snoc and False by (auto simp: IH sorted_append)
  qed
qed

lemma filter_takeWhile_dropWhile_id[simp]:
  "filter P (takeWhile Q xs) @ filter P (dropWhile Q xs) = filter P xs"
  by (simp add: filter_append[symmetric])

lemma filter_by_key_merge_is_append[simp]:
  assumes "sorted (map key xs)"
  shows "[y\<leftarrow>merge key xs ys. key x = key y]
    = [y\<leftarrow>xs. key x = key y] @ [y\<leftarrow>ys. key x = key y]"
  using assms by (induct xs ys rule: sorted_merge_induct) auto

lemma filter_by_key_merge_pairs[simp]:
  assumes "\<forall>xs\<in>set xss. sorted (map key xs)"
  shows "[y\<leftarrow>concat (merge_pairs key xss). key x = key y]
    = [y\<leftarrow>concat xss. key x = key y]"
  using assms by (induct xss rule: merge_pairs.induct) simp_all

lemma filter_by_key_merge_all[simp]:
  assumes "\<forall>xs\<in>set xss. sorted (map key xs)"
  shows "[y\<leftarrow>merge_all key xss. key x = key y]
    = [y\<leftarrow>concat xss. key x = key y]"
  using assms by (induct xss rule: merge_all.induct) simp_all

lemma filter_by_key_merge_all_sequences[simp]:
  "[x\<leftarrow>merge_all key (sequences key xs) . key y = key x]
    = [x\<leftarrow>xs . key y = key x]"
  using sorted_sequences[of key xs] by simp

lemma sort_key_merge_all_sequences:
  "sort_key key = merge_all key \<circ> sequences key"
  by (intro ext properties_for_sort_key)
     (simp_all add: sorted_merge_all[OF sorted_sequences])

text {*
Replace existing code equations for @{const sort_key} by
@{term "merge_all key \<circ> sequences key"}.
*}
declare sort_key_merge_all_sequences[code]

end
end


(*
Isabelle/HOL source for lectures of Set Theory
created by Yongwang ZHAO
School of Computer Science and Engineering, Beihang University, China
zhaoyw@buaa.edu.cn
*)

theory SetFoundation
imports Main

begin

(*
typedecl Student

consts InRoom :: "Student \<Rightarrow> bool"

definition students_in_room :: "Student set"
  where "students_in_room \<equiv> {x. InRoom(x)}"

typedef nat1 = "{x::nat. x > 0}"
  proof -
    have "(2::nat) \<in> {x::nat. x>0}" by force
    then show ?thesis by blast
  qed
*)

chapter {* chapter 5. Set and Operation *}

section {* section 5.1: sets and elements *}

subsection {* example 5.1 *}

definition "A0 \<equiv> {''a'',''e'',''i'',''w'',''u''}"

lemma "''a'' \<in> A0"
  by (simp add: A0_def)

lemma "''e'' \<in> A0"
  by (simp add: A0_def)

lemma "''i'' \<in> A0"
  by (simp add: A0_def)

lemma "''b'' \<notin> A0"
  by (simp add: A0_def)

lemma "''c'' \<notin> A0"
  by (simp add: A0_def)

subsection {*example 5.2*}

definition "B0 \<equiv> {x::int. x > 0}"

subsection {* predicates and sets *}

lemma "a\<in>{x. P(x)} \<longleftrightarrow> P a" by auto

lemma "b\<notin>{x. P(x)} \<longleftrightarrow> \<not> (P b)" by auto

subsection {*example 5.3*}

definition "S\<^sub>1 \<equiv> {x::int. x > 0 \<and> x mod 2 = 1}"

definition "S\<^sub>3 \<equiv> {x::int. x^3 + x^2 + 2 = 0}"

definition "S\<^sub>5 \<equiv> {x::int. x =  8 \<or> x = -2 \<or> x = 75}"

lemma "S\<^sub>5 = {8, -2 ,75}"
  proof(rule subset_antisym)
    show "S\<^sub>5 \<subseteq> {8, -2, 75}" using S\<^sub>5_def by auto
    show "{8, -2, 75} \<subseteq> S\<^sub>5" using S\<^sub>5_def by auto
  qed

subsection {* definition 5.1 *}

consts P :: "'t \<Rightarrow> bool"

definition "A1 \<equiv> {x. P(x)}"

lemma "\<forall>x. (P(x) \<longleftrightarrow> x\<in>A1)"
  by (simp add: A1_def)

definition A2 :: "('t \<Rightarrow> bool) \<Rightarrow> 't set"
  where aa2: "A2(Q) = {x. Q(x)}"

lemma "\<forall>x. (Q(x) \<longleftrightarrow> x\<in>A2(Q))"
  by (simp add: aa2)

section {* section 5.2: equivalence and containment *}

subsection {* example 5.4 *}

lemma "{1,2,3,4} = {(x::int). x > 0 \<and> x \<le> 4}"
  by auto

lemma "{1,2,3,4} = {(x::int). 0 < x \<and> x < 6 \<and> (\<exists>y. x * y = 12)}"
apply auto apply(subgoal_tac "x = 1 \<or> x = 2 \<or> x = 3 \<or> x = 4 \<or> x = 5")
  prefer 2 apply simp apply auto
  by presburger

subsection {* definition 5.2 *}

 (*definition of set equal*)
lemma "(A = B) = (\<forall>x. (x \<in> A) \<longleftrightarrow> (x \<in> B))"
  using Set.set_eq_iff by fastforce

subsection {* example 5.5 *}

lemma "{1,2,3} = {3,1,2}"
  by auto

lemma "{''a'',''b'',''a''} = {''a'',''a'',''b'',''b'',''a''}"
  by auto

lemma "{''a'',''b'',''a''} = {''a'',''b''}"
  by auto

subsection {* example 5.6 *}

consts d :: "int set"
consts p :: "int set"
consts q :: "int"

definition "B1 \<equiv> {d, {1,2},p,{q}}"

lemma "{q} \<in> B1"
  by (simp add: B1_def)

(*lemma "q \<notin> B1" *)

subsection {* definition 5.3 *}

(*definition of \<subseteq>*)
lemma "(A \<subseteq> B) = (\<forall>t. t \<in> A \<longrightarrow> t \<in> B)"
  using subset_iff by auto

subsection {* definition 5.4 *}

(*definition of \<subseteq>*)
lemma "(A \<subseteq> B) = (\<forall>x\<in>A. x \<in> B)"
  using subset_eq by auto

(*definition of \<subset>*)
lemma "A \<subset> B = ((\<forall>x. x\<in>A \<longrightarrow> x\<in>B) \<and> (\<exists>x. x\<in>B \<and> x\<notin>A))"
  by auto

subsection {* example 5.8 *}

definition "A3 \<equiv> {1,3,4,5,7}"

definition "B2 \<equiv> {1,3,4}"

definition "C1 \<equiv> {4}"

lemma "C1 \<subseteq> B2"
  by (simp add:B2_def C1_def)

lemma "B2 \<subseteq> A3"
  by (simp add:B2_def A3_def)

subsection {* theorem 5.1 *}

lemma "(A = B) = (A \<subseteq> B \<and> B \<subseteq> A)"
  using set_eq_iff by auto

lemma "A \<subseteq> A" by simp

subsection {* theorem 5.2 *}
lemma "A \<subseteq> B \<and> B \<subseteq> C \<Longrightarrow> A \<subseteq> C"
  by auto

subsection {* definition 5.5 *}

lemma "UNIV = {x. True}"
 using UNIV_def by auto  (* {x. P(x) \<or> \<not>P(x)}, is esentially equal to {x. True} *)

lemma "\<forall>x. x\<in>UNIV" by auto

subsection {* definition 5.6 *}

lemma "{} = {x. False}"
  using empty_def by auto

lemma "\<forall>x. x\<notin>{}" by auto

subsection {* theorem 5.3 *}

lemma "\<forall>P. {} \<subseteq> P"
  by simp

section {* section 5.3: power set*}

subsection {* definition 5.7 *}

thm Pow_def (* definition of power set*)

lemma "Pow A = {X. (\<forall>t\<in>X. t\<in>A)}"
  using Pow_def[of A] by blast

lemma "Pow {} = {{}}"
  by simp

lemma "Pow {a} = {{},{a}}"
  by auto

lemma "Pow {a,b} = {{},{a},{b},{a,b}}"
  by auto

lemma "B \<subseteq> A \<Longrightarrow> B \<in> Pow A"
  by simp

lemma "a\<in>A \<Longrightarrow> {a}\<subseteq>A \<and> {a}\<in>Pow A"
  by simp

lemma "a\<in>A \<and> b\<in>A \<Longrightarrow> {a,b}\<subseteq>A \<and> {a,b}\<in>Pow A"
  by simp

subsection {* differences between subset and belong *}
lemma "B \<subseteq> A \<Longrightarrow> B \<in> Pow A"
  by auto

lemma "a\<in>A \<Longrightarrow> {a} \<subseteq> A \<and> {a}\<in>Pow A"
  by auto

lemma "a\<in>A \<and> b\<in>A \<Longrightarrow> {a,b}\<subseteq>A \<and> {a,b}\<in>Pow A"
  by auto

subsection {* definition 5.8 *}

thm card_def (* definition of card of set *)

lemma "finite A \<Longrightarrow> finite (Pow A)"
  by simp

lemma "\<not> (finite A) \<Longrightarrow> \<not> (finite (Pow A))"
  by simp

subsection {* theorem 5.5 *}

lemma "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
  using Power.card_Pow by auto

lemma "infinite A \<Longrightarrow> card A = 0"
  using Finite_Set.card.infinite by auto

subsection {* example 5.9 *}

value "Pow {''a'',''b'',''c''}"

section {* section 5.4: set operations *}

subsection {* definition 5.9 *}

(* definition of intersection*)
lemma "A \<inter> B = {x. x\<in>A \<and> x\<in>B}"
  using Int_def by auto

(* definition of union*)
lemma  "A \<union> B = {x. x \<in> A \<or> x \<in> B}"
  using Un_def by auto

(* definition of difference*)
lemma "A - B = {x. x \<in> A \<and> x \<notin> B}"
  using "set_diff_eq" by auto

subsection {* example 5.10 *}

definition "A4 \<equiv> {1::int,2,3,4}"

definition "B4 \<equiv> {3,4,5,6}"

value "A4 \<union> B4"

value "A4 \<inter> B4"

value "A4 - B4"

value "B4 - A4"

subsection {* definition 5.12 *}

(* definition of complement *)
lemma "-A = (UNIV - A)"
  using Compl_eq_Diff_UNIV by auto

lemma "- A = {x. x\<notin>A}" by auto

subsection {* example 5.11 *}

datatype univ = a | b | c | d

lemma univ_lm: "UNIV = {a, b, c, d}"
  proof (rule UNIV_eq_I)
    fix x show "x \<in> {a, b, c, d}" by (cases x) simp_all
  qed

definition "A7 \<equiv> {a, b}"

value "- A7"

lemma "- A7 = {c, d}"
  using univ_lm A7_def Compl_eq_Diff_UNIV Diff_eq_empty_iff insertE
    insertI1 insert_Diff_if insert_commute singletonD subset_insertI
    univ.distinct(3) univ.distinct(5) univ.distinct(7) univ.distinct(9) by blast

definition "A5 \<equiv> {x::nat. x > 0}"

lemma "- A5 = {x::nat. x = 0}"
  proof -
    have "\<forall>x::nat. x > 0 \<or> x = 0" by auto
    have "\<forall>x::nat. x\<in>{x. x = 0} = (x \<notin> {x. x > 0})" by simp
    have "- A5 = UNIV - A5" by auto
    then have "- A5 = {x::nat \<in> UNIV. x \<notin> {x::nat. x > 0}}" using set_diff_eq A5_def by auto
    then have "- A5 = {x::nat \<in> UNIV. x \<in> {x::nat. x = 0}}" by auto
    then show ?thesis by auto
  qed

subsection {* example 5.12 *}

lemma "A - B = A \<inter> (-B)"
  using Set.Diff_eq by auto

subsection {* example 5.13 *}

lemma "A - (A \<inter> B) = A - B"
  by auto

subsection {* definition 5.13 *}

definition plus :: "'t set \<Rightarrow> 't set \<Rightarrow> 't set" (infix "\<oplus>" 70)
  where "plus A B \<equiv> (A - B) \<union> (B - A)"

definition "A6 \<equiv> {''a'',''b'',''c'',''d''}"

definition "B6 \<equiv> {''a'',''c'',''e''}"

value "A6 - B6"
value "B6 - A6"
value "A6 \<oplus> B6"

subsection {* theorem 5.6 *}

thm Set.Un_absorb
lemma "A \<union> A = A"
  proof -
    have "(\<forall>x. (x \<in> (A \<union> A))) = (\<forall>x. x\<in>{x. x \<in> A \<or> x \<in> A})" using Un_def by simp
    then have "(\<forall>x. (x \<in> (A \<union> A))) = (\<forall>x. x\<in>{x. x \<in> A})" by simp
    then show ?thesis using Un_def by simp
  qed

lemma "A \<inter> A = A"
  by auto
thm Set.Int_absorb

lemma "A \<union> B = B \<union> A"
  by auto
thm Set.Un_ac(3)

lemma "A \<inter> B = B \<inter> A"
  by auto
thm Set.Int_ac(3)

lemma "A \<union> (B \<union> C) = (A \<union> B) \<union> C"
  by auto

lemma "A \<inter> (B \<inter> C) = (A \<inter> B) \<inter> C"
  by auto

lemma "A \<union> (B \<inter> C) = (A \<union> B) \<inter> (A \<union> C)"
  using Set.Un_Int_distrib by auto

lemma "A \<inter> (B \<union> C) = (A \<inter> B) \<union> (A \<inter> C)"
  using Set.Int_Un_distrib by auto

subsection {* theorem 5.7 *}

lemma "A \<union> {} = A"
  using Set.Un_empty_right by auto

lemma "A \<inter> UNIV = A"
  using Set.Int_UNIV_right by auto

subsection {* theorem 5.8 *}

lemma "A \<union> -A = UNIV"
  using Set.Compl_partition by auto

lemma "A \<inter> -A = {}"
  using Set.Compl_disjoint by auto

subsection {* theorem 5.9 *}

lemma "(B = - A) \<longleftrightarrow> (A \<union> B = UNIV \<and> A \<inter> B = {})" by auto

subsection {* theorem 5.10 *}

lemma "-(A \<union> B) = (-A) \<inter> (-B)"
  using Set.Compl_Un by auto

lemma "-(A \<inter> B) = (-A) \<union> (-B)"
  using Set.Compl_Int by auto

subsection {* theorem 5.11 *}

lemma "A \<subseteq> B \<Longrightarrow> A \<union> B = B"
  using Set.Un_absorb1 by auto

lemma "A \<union> B = B \<Longrightarrow> A \<inter> B = A"
  by auto

lemma "A \<inter> B = A \<Longrightarrow> A - B = {}"
  by auto

lemma "A - B = {} \<Longrightarrow> A \<subseteq> B"
  by auto

subsection {* definition 5.14 *}

lemma "\<Union>A = {x. \<exists>B \<in> A. x \<in> B}"
  using Union_eq by auto

lemma "\<Inter>A = {x. \<forall>B \<in> A. x \<in> B}"
  using Inter_eq by auto

lemma "\<Inter>{} = UNIV" by auto

lemma "\<Union>{} = {}" by auto

subsection {* example 5.14 *}

definition "C4 \<equiv> {{0::int},{0,1},{0,1,2}}"

value "\<Union>C4"

definition "A8 \<equiv> {{0::int,1,2},{4,5,6},{2}}"

value "\<Union>A8"
value "\<Inter>A8"

section {* section 5.5 counting *}

lemma "finite A \<and> finite B \<and> A \<inter> B = {} \<Longrightarrow> card (A \<union> B) = card A + card B"
  using card_Un_disjoint by auto

lemma "finite A \<and> finite B \<Longrightarrow> card A + card B = card (A \<union> B) + card (A \<inter> B)"
  using card_Un_Int by auto

lemma card_un_int: "finite A \<and> finite B \<Longrightarrow> card (A \<union> B) = card A + card B - card (A \<inter> B)"
  using card_Un_Int by fastforce

section {* section 5.6 inductive set *}

subsection {* example 5.16 *}
inductive_set even :: "int set"
  where "0 \<in> even" |
        "n \<in> even \<Longrightarrow> n + 2 \<in> even"

subsection {* example 5.17 *}
inductive_set set3 :: "int set"
  where "3 \<in> set3" |
        "\<lbrakk>x \<in> set3; y \<in> set3\<rbrakk> \<Longrightarrow> x + y \<in> set3"

subsection {* string set \<Sigma>* and its caculus *}

type_synonym \<Sigma> = "char"
(* type_synonym string = "\<Sigma> list" *)
type_synonym string = "\<Sigma> list"

subsection {* definition 5.16 *}
inductive_set sigma_set :: "string set" ("\<Sigma>\<^sup>*" 80)
  where nil_str: "Nil \<in> sigma_set" |
        cons_str: "\<lbrakk>chr\<in>\<Sigma>; x\<in>sigma_set\<rbrakk> \<Longrightarrow>chr#x\<in>sigma_set"

subsection {* definition 5.17 *}
primrec str_n :: "\<Sigma> \<Rightarrow> nat \<Rightarrow> string"
  where zero_str: "str_n x 0 = Nil" |
        sucn_str: "str_n x (Suc n) = x#(str_n x n)"

subsection {* definition 5.18 *}
type_synonym Lang = "string set"

lemma "\<forall>l::Lang. l \<subseteq> \<Sigma>\<^sup>*"
  proof -
    {
      fix x
      have "\<forall>l::Lang. x\<in>l \<longrightarrow> x\<in>\<Sigma>\<^sup>*"
        apply(induct x)
        using nil_str apply blast
        using cons_str by blast
    }
    then show ?thesis by auto
  qed

subsection {* definition 5.19 *}

definition multi :: "Lang \<Rightarrow> Lang \<Rightarrow> Lang" (infixl "\<^emph>" 85) (*("_\<^emph>_")*)
  where "A \<^emph> B \<equiv> {z. \<exists>x y. x\<in>A \<and> y\<in>B \<and> z = x@y}"

subsection {* example 5.18 *}

value "{Nil, ''a'',''ab''} \<^emph> {''a'',''bb''}"

value "{''a'',''bb''} \<^emph> {Nil, ''a'',''ab''}"

value "{''a'',''ab''} \<^emph> {''a'',''bb''}"

subsection {* theorem 5.13 *}

lemma "(A \<^emph> {}) = ({} \<^emph> A)" by (simp add: multi_def)

lemma "(A \<^emph> {Nil}) = ({Nil} \<^emph> A)"
  proof -
    have "\<forall>x\<in>(A \<^emph> {Nil}). x\<in>({Nil} \<^emph> A)"
      proof
        fix x
        assume "x \<in> A\<^emph>{Nil}"
        then have "\<exists>x1 y1. x1\<in>A \<and> y1\<in>{Nil} \<and> x = x1@y1" by (simp add:multi_def)
        then show "x\<in>({Nil} \<^emph> A)" using multi_def by auto
      qed
    moreover
    have "\<forall>x\<in>({Nil} \<^emph> A). x\<in>(A \<^emph> {Nil})"
      proof
        fix x
        assume "x\<in>({Nil} \<^emph> A)"
        then have "\<exists>x1 y1. x1\<in>{Nil} \<and> y1\<in>A \<and> x = x1@y1" by (simp add:multi_def)
        then show "x\<in>(A \<^emph> {Nil})" using multi_def by auto
      qed
    ultimately show ?thesis by auto
  qed

lemma comm_lm: "((A \<^emph> B) \<^emph> C) = (A \<^emph> (B \<^emph> C))"
  proof -
    have "\<forall>x\<in>((A \<^emph> B) \<^emph> C). x\<in>(A \<^emph> (B \<^emph> C))"
      proof
        fix x
        assume "x\<in>((A \<^emph> B) \<^emph> C)"
        then have "\<exists>x1 y1. x1\<in>(A \<^emph> B) \<and> y1\<in>C \<and> x = x1@y1" by (simp add:multi_def)
        then have "\<exists>x1 y1 x2 y2. x2\<in>A \<and> y2\<in>B \<and> x1 = x2@y2 \<and> y1\<in>C \<and> x = x1@y1"
          using multi_def by auto
        then have "\<exists>x1 y1 x2 y2. x2\<in>A \<and> y2\<in>B \<and> x1 = y2@y1 \<and> y1\<in>C \<and> x = x2@x1"
          using append_assoc by blast
        then show "x\<in>(A \<^emph> (B \<^emph> C))" using multi_def by auto
      qed
    moreover
    have "\<forall>x\<in>(A \<^emph> (B \<^emph> C)). x\<in>((A \<^emph> B) \<^emph> C)" sorry (* similar to above *)
    ultimately show ?thesis by auto
  qed

lemma "A \<subseteq> B \<and> C \<subseteq> D \<Longrightarrow> (A \<^emph> C) \<subseteq> (B \<^emph> D)"
  proof -
    assume p: "A \<subseteq> B \<and> C \<subseteq> D"
    have "\<forall>x\<in>(A \<^emph> C). x\<in>(B \<^emph> D)"
      proof
        fix x
        assume "x\<in>(A \<^emph> C)"
        with p show "x\<in>(B \<^emph> D)"
          using mem_Collect_eq multi_def set_rev_mp by fastforce
      qed
    then show "(A \<^emph> C) \<subseteq> (B \<^emph> D)" by auto
  qed

lemma "(A \<^emph> (B \<union> C)) = (A \<^emph> B) \<union> (A \<^emph> C)"
  proof -
    have "\<forall>x\<in>(A \<^emph> (B \<union> C)). x\<in>(A \<^emph> B) \<union> (A \<^emph> C)"
      proof
        fix x
        assume "x\<in>(A \<^emph> (B \<union> C))"
        then have "\<exists>y z. y\<in>A \<and> z\<in>B \<union> C \<and> x = y@z" by (simp add:multi_def)
        then have "\<exists>y z. y\<in>A \<and> (z\<in>B \<or> z\<in>C) \<and> x = y@z" by simp
        then have "\<exists>y z. (y\<in>A \<and> z\<in>B \<and> x = y@z) \<or> (y\<in>A \<and> z\<in>C \<and> x = y@z)" by auto
        then have "(\<exists>y z. (y\<in>A \<and> z\<in>B \<and> x = y@z)) \<or> (\<exists>y z. (y\<in>A \<and> z\<in>C \<and> x = y@z))" by auto
        then have "x\<in>(A \<^emph> B) \<or> x\<in>(A \<^emph> C)" by (simp add:multi_def)
        then show "x\<in>(A \<^emph> B) \<union> (A \<^emph> C)" by simp
      qed
    moreover
    have "\<forall>x\<in>(A \<^emph> B) \<union> (A \<^emph> C). x\<in>(A \<^emph> (B \<union> C))" sorry (* similar to the above formula*)
    ultimately show ?thesis by auto
  qed

lemma "((B \<union> C) \<^emph> A) = ((B \<^emph> A) \<union> (C \<^emph> A))"
  sorry (*similar to the above lemma*)

lemma "(A \<^emph> (B \<inter> C)) \<subseteq> (A \<^emph> B) \<inter> (A \<^emph> C)"
  proof -
  {
    fix x
    assume "x\<in>(A \<^emph> (B \<inter> C))"
    then have "\<exists>y z. y\<in>A \<and> z\<in>B \<inter> C \<and> x = y@z" by (simp add:multi_def)
    then have "\<exists>y z. y\<in>A \<and> (z\<in>B \<and> z\<in>C) \<and> x = y@z" by simp
    then have "\<exists>y z. (y\<in>A \<and> z\<in>B \<and> x = y@z) \<and> (y\<in>A \<and> z\<in>C \<and> x = y@z)" by auto
    then have "(\<exists>y z. (y\<in>A \<and> z\<in>B \<and> x = y@z)) \<and> (\<exists>y z. (y\<in>A \<and> z\<in>C \<and> x = y@z))" by auto
    then have "x\<in>(A \<^emph> B) \<and> x\<in>(A \<^emph> C)" by (simp add:multi_def)
    then have "x\<in>(A \<^emph> B) \<inter> (A \<^emph> C)" by simp
  }
  then show ?thesis by auto
  qed

lemma "((B \<inter> C) \<^emph> A) \<subseteq> ((B \<^emph> A) \<inter> (C \<^emph> A))"
  sorry (*similar to the above lemma*)

subsection {* definition 5.20 *}

primrec A_n :: "Lang \<Rightarrow> nat \<Rightarrow> Lang" ("_\<^sup>_" [81] 80)
  where a_n_nil: "(A\<^sup>0) = {Nil}" |
        a_n_cons: "A_n A (Suc n) = (A \<^emph> (A\<^sup>n))"

subsection {* example 5.19 *}

value "A_n ({Nil, ''a'', ''ab''}) 0"

value "A_n ({Nil, ''a'', ''ab''}) 1"

value "A_n ({Nil, ''a'', ''ab''}) 2"

subsection {* theorem 5.14 *}

lemma A_n_plus: "\<forall>A m n. ((A\<^sup>m) \<^emph> (A\<^sup>n)) = (A_n A (m+n))"
  proof -
  {
    fix m A
    have "\<forall>n. ((A\<^sup>m) \<^emph> (A\<^sup>n)) = (A_n A (m+n))"
      proof(induct m)
        case 0
        show ?case
          proof
            fix n
            have "\<forall>x\<in>((A\<^sup>0) \<^emph> (A\<^sup>n)). x\<in>(A_n A (0 + n))"
              proof
                fix x
                assume "x\<in>((A\<^sup>0) \<^emph> (A\<^sup>n))"
                then have "x\<in>({Nil} \<^emph> (A\<^sup>n))" using a_n_nil by simp
                then have "\<exists>y z. y\<in>{Nil} \<and> z\<in>(A\<^sup>n) \<and> x = y@z" by (simp add:multi_def)
                then have "x\<in>(A\<^sup>n)" by (simp add:multi_def)
                then show "x\<in>(A_n A (0 + n))" by simp
              qed
            moreover
            have "\<forall>x\<in>(A_n A (0 + n)). x\<in>((A\<^sup>0) \<^emph> (A\<^sup>n))"
              proof
                fix x
                assume "x\<in>(A_n A (0 + n))"
                then have "x\<in>(A\<^sup>n)" by simp
                then have "\<exists>y z. y\<in>{Nil} \<and> z\<in>(A\<^sup>n) \<and> x = y@z" by (simp add:multi_def)
                then show "x\<in>((A\<^sup>0) \<^emph> (A\<^sup>n))" by (simp add:multi_def)
              qed
            ultimately show "((A\<^sup>0) \<^emph> (A\<^sup>n)) = (A_n A (0 + n))" by auto
          qed
      next
        case (Suc m)
        assume p: "\<forall> n. ((A\<^sup>m) \<^emph> (A\<^sup>n)) = (A_n A (m + n))"
        show ?case
          proof
            fix n
            from p have "((A\<^sup>m) \<^emph> (A\<^sup>n)) = (A_n A (m + n))" by simp
            moreover
            have "(A_n A (Suc m)) \<^emph> (A\<^sup>n) = (A \<^emph> (A\<^sup>m)) \<^emph> (A\<^sup>n)"
              using a_n_cons by simp
            moreover
            have "(A_n A (Suc m + n)) = (A \<^emph> A_n A (m + n))"
              using a_n_cons by simp

            ultimately show "((A_n A (Suc m)) \<^emph> (A\<^sup>n)) = (A_n A (Suc m + n))"
              by (simp add: comm_lm)
          qed
      qed
  }
  then show ?thesis by simp
  qed

lemma "\<forall>A m n. A_n (A\<^sup>m) n = A_n A (m*n)"
  proof -
  {
    fix A m
    have "\<forall>n. A_n (A\<^sup>m) n = A_n A (m*n)"
      proof(induct m)
        case 0
        show ?case
          proof
            fix n
            have "A_n (A\<^sup>0) n = (A\<^sup>0)"
              proof(induct n)
                case 0
                show ?case using a_n_nil by auto
              next
                case (Suc k)
                assume "A_n (A\<^sup>0) k = (A\<^sup>0)"
                then have "A_n (A\<^sup>0) (Suc k) = (A\<^sup>0) \<^emph> (A\<^sup>0)"
                  using a_n_cons by auto
                then show ?case by (simp add:multi_def)
              qed
            then show "A_n (A\<^sup>0) n = A_n A (0 * n)" by simp
          qed
      next
        case (Suc k)
        assume p: "\<forall>n. A_n (A\<^sup>k) n = A_n A (k * n)"
        show ?case
          proof
            fix n
            show "A_n (A_n A (Suc k)) n = A_n A (Suc k * n)"
              proof(induct n)
                case 0
                show ?case using a_n_nil by auto
              next
                case (Suc l)
                assume a0: "A_n (A_n A (Suc k)) l = A_n A (Suc k * l)"

                have "A_n (A_n A (Suc k)) l = A_n (A \<^emph> (A_n A k)) l"
                  using a_n_nil by auto
                then have a1: "A_n (A_n A (Suc k)) (Suc l) = ((A_n A (Suc k)) \<^emph> (A_n (A_n A (Suc k)) l))"
                  using a_n_nil by auto
                with a0 have "A_n (A_n A (Suc k)) (Suc l) = ((A_n A (Suc k)) \<^emph> (A_n A (Suc k * l)))"
                  by simp
                then have "A_n (A_n A (Suc k)) (Suc l) = ((A \<^emph> (A_n A k)) \<^emph> (A_n A (Suc k * l)))"
                  using a_n_cons by auto
                then show ?case
                  using A_n_plus by (metis a1 a0 mult.commute mult_Suc)
              qed
          qed
      qed
  }
  then show ?thesis by auto
  qed

lemma "A \<subseteq> B \<Longrightarrow> (A\<^sup>n) \<subseteq> (B\<^sup>n)" sorry
  (* please prove it by youself *)

subsection {* definition 5.21 *}
definition A_star :: "Lang \<Rightarrow> Lang" ("(_\<^sup>\<star>)" [1000] 999)
  where "A\<^sup>\<star> \<equiv> (\<Union>n. A\<^sup>n)"

definition A_star1 :: "Lang \<Rightarrow> Lang" ("(_\<^sup>+)" [1000] 999)
  where "A\<^sup>+ \<equiv> (\<Union>n\<in>{0<..}. A\<^sup>n)"

lemma A_star1_lm: "(x\<in>A\<^sup>+) = (\<exists>n::nat>0. x\<in>A\<^sup>n)"
  proof -
    have "(x\<in>A\<^sup>+) \<longrightarrow> (\<exists>n::nat>0. x\<in>A\<^sup>n)" using A_star1_def by blast
    moreover
    have "(\<exists>n::nat>0. x\<in>A\<^sup>n) \<longrightarrow> (x\<in>A\<^sup>+)" using A_star1_def by blast
    ultimately show ?thesis by auto
  qed

lemma A_star_lm: "(x\<in>A\<^sup>\<star>) = (\<exists>n::nat. x\<in>A\<^sup>n)"
  proof -
    have "(x\<in>A\<^sup>\<star>) \<longrightarrow> (\<exists>n::nat. x\<in>A\<^sup>n)" using A_star_def by blast
    moreover
    have "(\<exists>n::nat. x\<in>A\<^sup>n) \<longrightarrow> (x\<in>A\<^sup>\<star>)" using A_star_def by blast
    ultimately show ?thesis by auto
  qed

subsection{* example 5.20 *}

lemma "{''a''}\<^sup>+ = (\<Union>n\<in>{0<..}. {''a''}\<^sup>n)"
  unfolding A_star1_def using a_n_cons by blast

lemma "{''a''}\<^sup>\<star> = (\<Union>n. {''a''}\<^sup>n)"
  unfolding A_star_def using a_n_cons by blast

subsection{* theorem 5.15 *}

lemma A_star_lm2: "A\<^sup>\<star> = A\<^sup>+ \<union> A\<^sup>0"
  proof -
  {
    fix x
    have "(x \<in> A\<^sup>\<star>) \<longrightarrow> (x = [] \<or> x \<in> A\<^sup>+)"
      using A_star_lm A_star1_lm by (metis a_n_nil gr0I singletonD)
    moreover
    have "(x = [] \<or> x \<in> A\<^sup>+) \<longrightarrow> (x \<in> A\<^sup>\<star>)"
      using A_star_lm A_star1_lm by (metis a_n_nil insert_iff)
    ultimately have "(x \<in> A\<^sup>\<star>) = (x = [] \<or> x \<in> A\<^sup>+)" by auto
  }
  then show ?thesis by (simp add:set_eq_iff)
  qed

lemma "A\<^sup>n \<subseteq> A\<^sup>\<star>"
  using A_star_lm by auto

lemma "n > 0 \<Longrightarrow> A\<^sup>n \<subseteq> A\<^sup>+"
  using A_star1_lm by auto

lemma "A \<subseteq> (A \<^emph> (B\<^sup>\<star>))"
  sorry

lemma "A \<subseteq> ((B\<^sup>\<star>) \<^emph> A)"
  sorry

lemma "A \<subseteq> B \<Longrightarrow> A\<^sup>\<star> \<subseteq> B\<^sup>\<star>"
  sorry

lemma "A \<subseteq> B \<Longrightarrow> (A_star1 A) \<subseteq> (A_star1 B)"
  sorry

lemma "A \<^emph> (A\<^sup>\<star>) = (A\<^sup>\<star>) \<^emph> A"
  sorry

lemma "Nil\<in>A \<Longrightarrow> A\<^sup>\<star> = A\<^sup>+"
  sorry

lemma "(A\<^sup>\<star>)\<^sup>\<star> = (A\<^sup>\<star>) \<^emph> (A\<^sup>\<star>)"
  sorry

lemma "(A\<^sup>\<star>)\<^sup>\<star> = (A\<^sup>+)\<^sup>\<star>"
  sorry

lemma "A_star1 (A_star1 A) = A_star1 A"
  sorry

section {* section 5.7 pair and product *}

subsection {* definition 5.22*}

value "(x,y)"

value "fst (x,y)"

value "snd (x,y)"

lemma "x \<noteq> y \<Longrightarrow> (x,y)\<noteq>(y,x)" by auto

lemma "(x,y) \<noteq> (y,x)" nitpick sorry (*it is not correct*)

lemma "{x,y} = {y,x}" by auto

lemma "{x,x} = {x}" by auto

subsection {* theorem 5.16*}

lemma "(x,y) = (u,v) \<longleftrightarrow> u = x \<and> v = y" by auto

subsection {* definition 5.23*}

value "(x1,x2,x3,x4)"

lemma "(x1,x2,x3,x4) = (x1,(x2,(x3,x4)))" by auto

(* lemma "(x1,x2,x3,x4) = (((x1,x2),x3),x4)" *)
(* syntax error*)

lemma "(x1,x2,x3,x4) = (y1,y2,y3,y4) \<longleftrightarrow> x1 = y1 \<and> x2 = y2 \<and> x3 = y3 \<and> x4 = y4"
  by auto

subsection {* definition 5.24*}

(* thm Times_Un_distrib1 *)

thm Sigma_def

lemma "A \<times> B = {(x,y). x\<in>A \<and> y\<in>B}" by auto

subsection {* example 5.21 *}

definition "A9 \<equiv> {''a'',''b''}"

definition "B9 \<equiv> {1::int,2,3}"

value "A9 \<times> B9"

value "B9 \<times> A9"

value "A9 \<times> A9"

value "B9 \<times> B9"

(*  value "(A9 \<times> B9) \<inter> (B9 \<times> A9)"  *)

subsection {* example 5.22 *}

value "({}:: int set) \<times> {1::int,2,3}"

value "{1::int,2,3} \<times> ({}:: int set)"

section {* exercise *}

lemma "{{}} \<subseteq> {{}, {{}}}" by auto

end


section \<open>A Hilbert Proof Calculus for Propositional Logic (PL)\<close>

(*<*)
theory Hilbert
imports Main

begin
(*>*)

subsection \<open>Logical Connectives for PL\<close>

subsubsection \<open>Primitive Connectives\<close>

consts impl :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<rightarrow>" 49)
consts not :: "bool \<Rightarrow> bool" ("\<^bold>\<not>")

text \<open>In philosophy, we often assume that the only two logical connectives
  are the implication @{const impl} and the negation @{const not}.
  This is handy, since it simplifies proofs to only consider these two
  cases.
\<close>

subsubsection \<open>Further Defined Connectives\<close>

text \<open>We can of course add further connectives that are to be
  understood as abbreviations that are defined in terms of the primitive
  connectives above.\<close>

abbreviation disj :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<or>"50) where
  "A \<^bold>\<or> B \<equiv> \<^bold>\<not>A \<^bold>\<rightarrow> B"
abbreviation conj :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<^bold>\<and>"51) where
  "A \<^bold>\<and> B \<equiv> \<^bold>\<not>(A \<^bold>\<rightarrow> \<^bold>\<not>B)"

subsection \<open>Hilbert Axioms for PL\<close>

subsubsection \<open>Axiom Schemes\<close>

axiomatization where
  (* A1: "(A \<^bold>\<rightarrow> A)" and*)
  A2: "A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)" and
  A3: "(A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> C)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> C))" and
  A4: "(\<^bold>\<not>A \<^bold>\<rightarrow> \<^bold>\<not>B) \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)"

subsubsection \<open>Inference Rules\<close>

axiomatization where
  ModusPonens: "(A \<^bold>\<rightarrow> B) \<Longrightarrow> A \<Longrightarrow> B"

(* Test soundness of axiomatizaion *)
lemma True nitpick [satisfy, user_axioms, expect = genuine] oops

subsection \<open>A Proof\<close>

(* just playing around *)
thm A3[where A = "A" and B = "(B \<^bold>\<rightarrow> A)" and C = "A"]
thm A3[of "A" "(B \<^bold>\<rightarrow> A)" "A"]

text \<open>We show that A1 is redundant\<close>

theorem A1Redundant:
  shows "A \<^bold>\<rightarrow> A"
proof -
  have 1: "(A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> ((A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A))" by (rule A3[where B = "(B \<^bold>\<rightarrow> A)" and C = "A"])
  have 2: "A \<^bold>\<rightarrow> ((B \<^bold>\<rightarrow> A) \<^bold>\<rightarrow> A)"  by (rule A2[where B = "B \<^bold>\<rightarrow> A"])
  from 1 2 have 3: "(A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> A)" by (rule ModusPonens)
  have 4: "(A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> A))" by (rule A2)
  from 3 4 have 5: "A \<^bold>\<rightarrow> A" by (rule ModusPonens)
  thus ?thesis .
qed

theorem
  shows "A \<^bold>\<rightarrow> A"
  by (metis (full_types) A2 ModusPonens) -- "Sledgehammer even finds a proof without using A3"

subsection \<open>Exercise 3\<close>

theorem transitivity:
  assumes 1: "A \<^bold>\<rightarrow> B" and
  2: "B \<^bold>\<rightarrow> C"
  shows "A \<^bold>\<rightarrow> C"
  proof -
    have 3: "(A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> C)) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> C)" by (rule A3)
    have 4: "(B \<^bold>\<rightarrow> C) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> C))" by (rule A2)
    from 4 2 have 5: "A \<^bold>\<rightarrow> (B \<^bold>\<rightarrow> C)" by (rule ModusPonens)
    from 3 5 have 6: "(A \<^bold>\<rightarrow> B) \<^bold>\<rightarrow> (A \<^bold>\<rightarrow> C)" by (rule ModusPonens)
    from 6 1 have 7: "A \<^bold>\<rightarrow> C" by (rule ModusPonens)
    thus ?thesis .
qed
(*<*)
end
(*>*)


theory theory29 imports Main begin

declare [[names_short]]

(* 3.1 *)

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N a) s = a" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N a) = N a" |
"asimp_const (V x) = V x" |
"asimp_const (Plus p q) =
 (case (asimp_const p, asimp_const q) of
  (N a, N b) \<Rightarrow> N (a+b) |
  (x, y) \<Rightarrow> Plus x y)"

fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N a) (N b) = N (a+b)" |
"plus p (N i) = (if i = 0 then p else Plus p (N i))" |
"plus (N i) p = (if i = 0 then p else Plus (N i) p)" |
"plus p q = (Plus p q)"

fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N a) = N a" |
"asimp (V x) = V x" |
"asimp (Plus p q) = plus (asimp p) (asimp q)"

lemma plus_correct: "aval (plus e1 e2) s = aval e1 s + aval e2 s"
  apply(induction rule:plus.induct)
  apply(auto)
  done

theorem asimp_correct: "aval (asimp e) s = aval e s"
  apply (induction e)
  apply (auto simp add: plus_correct)
  done

(* 3.2 *)

datatype bexp = Bc bool | Not bexp | And bexp bexp | Less aexp aexp

fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And a b) s = (bval a s \<and> bval b s)" |
"bval (Less a b) s = (aval a s < aval b s)"

fun less :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
"less (N n) (N m) = Bc(n < m)" |
"less a b = Less a b"

fun "and" :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and a b = And a b"

lemma and_0: "bval (and a1 a2) s = (bval a1 s \<and> bval a2 s)"
  apply (induction rule: and.induct)
  apply (auto)
  done

fun not :: "bexp \<Rightarrow> bexp" where
"not (Bc True) = Bc False" |
"not (Bc False) = Bc True" |
"not b = Not b"

fun bsimp :: "bexp \<Rightarrow> bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not(bsimp b)" |
"bsimp (And a b) = and (bsimp a) (bsimp b)" |
"bsimp (Less a b) = less (asimp a) (asimp b)"

(* 3.3  *)

datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk = n # stk" |
"exec1 (LOAD x) s stk = s(x) # stk" |
"exec1 ADD _ (x # y # stk) = (x+y) # stk"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#is) s stk = exec is s (exec1 i s stk)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

lemma exec_append: "exec (is1 @ is2) s stk = exec is2 s (exec is1 s stk)"
apply (induction is1 arbitrary:stk)
apply (auto)
done

lemma "exec (comp a) s stk = aval a s # stk"
apply (induction a arbitrary:stk)
apply (auto  simp add: exec_append)
done


header {* Log Upper and Lower Bounds *}

theory Log_CF_Bounds
imports Bounds_Lemmas

begin

theorem ln_upper_1: "0<x \<Longrightarrow> ln(x) \<le> x - 1"
by (rule ln_le_minus_one)

definition ln_lower_1 :: "real \<Rightarrow> real"
  where "ln_lower_1 \<equiv> \<lambda>x. 1 - (inverse x)"

corollary ln_lower_1: "0<x \<Longrightarrow> ln_lower_1 x \<le> ln x"
  unfolding ln_lower_1_def
  by (metis ln_inverse ln_le_minus_one positive_imp_inverse_positive minus_diff_eq minus_le_iff)

theorem ln_lower_1_eq: "0<x \<Longrightarrow> ln_lower_1 x = (x - 1)/x"
  by (auto simp: ln_lower_1_def divide_simps)

section {*Upper Bound 3*}

definition ln_upper_3 :: "real \<Rightarrow> real"
  where "ln_upper_3 \<equiv> \<lambda>x. (x + 5)*(x - 1) / (2*(2*x + 1))"

definition diff_delta_ln_upper_3 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_3 \<equiv> \<lambda>x. (x - 1)^3 / ((2*x + 1)^2 * x)"

lemma d_delta_ln_upper_3: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_3 x - ln x) has_field_derivative diff_delta_ln_upper_3 x) (at x)"
unfolding ln_upper_3_def diff_delta_ln_upper_3_def
apply (intro derivative_eq_intros | simp)+
apply (simp add: divide_simps add_nonneg_eq_0_iff, algebra)
done

text{*Strict inequalities also possible*}
lemma ln_upper_3_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_3 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_3])
apply (auto simp: diff_delta_ln_upper_3_def ln_upper_3_def)
done

lemma ln_upper_3_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_3 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_3])
using assms
apply (auto simp: diff_delta_ln_upper_3_def divide_simps ln_upper_3_def)
done

theorem ln_upper_3: "0<x \<Longrightarrow> ln(x) \<le> ln_upper_3 x"
by (metis le_less_linear less_eq_real_def ln_upper_3_neg ln_upper_3_pos)

definition ln_lower_3 :: "real \<Rightarrow> real"
  where "ln_lower_3 \<equiv> \<lambda>x. - ln_upper_3 (inverse x)"

corollary ln_lower_3: "0<x \<Longrightarrow> ln_lower_3 x \<le> ln x"
  unfolding ln_lower_3_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_3)

theorem ln_lower_3_eq: "0<x \<Longrightarrow> ln_lower_3 x = (1/2)*(1 + 5*x)*(x - 1) / (x*(2 + x))"
  unfolding ln_lower_3_def ln_upper_3_def
  by (simp add: divide_simps) algebra

section {*Upper Bound 5*}

definition ln_upper_5 :: "real \<Rightarrow> real"
  where "ln_upper_5 x \<equiv> (x^2 + 19*x + 10)*(x - 1) / (3*(3*x^2 + 6*x + 1))"

definition diff_delta_ln_upper_5 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_5 \<equiv> \<lambda>x. (x - 1)^5 / ((3*x^2 + 6*x + 1)^2*x)"

lemma d_delta_ln_upper_5: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_5 x - ln x) has_field_derivative diff_delta_ln_upper_5 x) (at x)"
  unfolding ln_upper_5_def diff_delta_ln_upper_5_def
  apply (intro derivative_eq_intros | simp add: add_nonneg_eq_0_iff)+
  apply (simp add: divide_simps add_nonneg_eq_0_iff, algebra)
  done

lemma ln_upper_5_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_5 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_5])
apply (auto simp: diff_delta_ln_upper_5_def ln_upper_5_def)
done

lemma ln_upper_5_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_5 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_5])
using assms
apply (auto simp: diff_delta_ln_upper_5_def divide_simps ln_upper_5_def mult_less_0_iff)
done

theorem ln_upper_5: "0<x \<Longrightarrow> ln(x) \<le> ln_upper_5 x"
by (metis le_less_linear less_eq_real_def ln_upper_5_neg ln_upper_5_pos)

definition ln_lower_5 :: "real \<Rightarrow> real"
  where "ln_lower_5 \<equiv> \<lambda>x. - ln_upper_5 (inverse x)"

corollary ln_lower_5: "0<x \<Longrightarrow> ln_lower_5 x \<le> ln x"
  unfolding ln_lower_5_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_5)

theorem ln_lower_5_eq: "0<x \<Longrightarrow>
    ln_lower_5 x = (1/3)*(10*x^2 + 19*x + 1)*(x - 1) / (x*(x^2 + 6*x + 3))"
  unfolding ln_lower_5_def ln_upper_5_def
  by (simp add: zero_less_mult_iff add_pos_pos dual_order.strict_implies_not_eq divide_simps)
     algebra

section {*Upper Bound 7*}

definition ln_upper_7 :: "real \<Rightarrow> real"
  where "ln_upper_7 x \<equiv> (3*x^3 + 131*x^2 + 239*x + 47)*(x - 1) / (12*(4*x^3 + 18*x^2 + 12*x + 1))"

definition diff_delta_ln_upper_7 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_7 \<equiv> \<lambda>x. (x - 1)^7 / ((4*x^3 + 18*x^2 + 12*x + 1)^2 * x)"

lemma d_delta_ln_upper_7: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_7 x - ln x) has_field_derivative diff_delta_ln_upper_7 x) (at x)"
unfolding ln_upper_7_def diff_delta_ln_upper_7_def
apply (intro derivative_eq_intros | simp)+
apply auto
apply (auto simp: add_pos_pos dual_order.strict_implies_not_eq divide_simps, algebra)
done

lemma ln_upper_7_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_7 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_7])
apply (auto simp: diff_delta_ln_upper_7_def ln_upper_7_def)
done

lemma ln_upper_7_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_7 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_7])
using assms
apply (auto simp: diff_delta_ln_upper_7_def divide_simps ln_upper_7_def mult_less_0_iff)
done

theorem ln_upper_7: "0 < x \<Longrightarrow> ln(x) \<le> ln_upper_7 x"
  by (metis le_less_linear less_eq_real_def ln_upper_7_neg ln_upper_7_pos)

definition ln_lower_7 :: "real \<Rightarrow> real"
  where "ln_lower_7 \<equiv> \<lambda>x. - ln_upper_7 (inverse x)"

corollary ln_lower_7: "0 < x \<Longrightarrow> ln_lower_7 x \<le> ln x"
  unfolding ln_lower_7_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_7)

theorem ln_lower_7_eq: "0 < x \<Longrightarrow>
  ln_lower_7 x = (1/12)*(47*x^3 + 239*x^2 + 131*x + 3)*(x - 1) / (x*(x^3 + 12*x^2 + 18*x + 4))"
  unfolding ln_lower_7_def ln_upper_7_def
  by (simp add: zero_less_mult_iff add_pos_pos dual_order.strict_implies_not_eq divide_simps)
     algebra

section {*Upper Bound 9*}

definition ln_upper_9 :: "real \<Rightarrow> real"
  where "ln_upper_9 x \<equiv> (6*x^4 + 481*x^3 + 1881*x^2 + 1281*x + 131)*(x - 1) /
                         (30 * (5*x^4 + 40*x^3 + 60*x^2 + 20*x + 1))"

definition diff_delta_ln_upper_9 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_9 \<equiv> \<lambda>x. (x - 1)^9 / (((5*x^4 + 40*x^3 + 60*x^2 + 20*x + 1)^2) * x)"

lemma d_delta_ln_upper_9: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_9 x - ln x) has_field_derivative diff_delta_ln_upper_9 x) (at x)"
unfolding ln_upper_9_def diff_delta_ln_upper_9_def
apply (intro derivative_eq_intros | simp)+
apply auto
apply (auto simp: add_pos_pos dual_order.strict_implies_not_eq divide_simps, algebra)
done

lemma ln_upper_9_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_9 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_9])
apply (auto simp: diff_delta_ln_upper_9_def ln_upper_9_def)
done

lemma ln_upper_9_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_9 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_9])
using assms
apply (auto simp: diff_delta_ln_upper_9_def divide_simps ln_upper_9_def mult_less_0_iff)
done

theorem ln_upper_9: "0<x \<Longrightarrow> ln(x) \<le> ln_upper_9 x"
by (metis le_less_linear less_eq_real_def ln_upper_9_neg ln_upper_9_pos)

definition ln_lower_9 :: "real \<Rightarrow> real"
  where "ln_lower_9 \<equiv> \<lambda>x. - ln_upper_9 (inverse x)"

corollary ln_lower_9: "0 < x \<Longrightarrow> ln_lower_9 x \<le> ln x"
  unfolding ln_lower_9_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_9)

theorem ln_lower_9_eq: "0 < x \<Longrightarrow>
      ln_lower_9 x = (1/30)*(6 + 481*x + 1881*x^2 + 1281*x^3 + 131*x^4)*(x - 1) /
                     (x*(5 + 40*x + 60*x^2 + 20*x^3 + x^4))"
  unfolding ln_lower_9_def ln_upper_9_def
  by (simp add: zero_less_mult_iff add_pos_pos dual_order.strict_implies_not_eq divide_simps)
     algebra

section {*Upper Bound 11*}

text{*Extended bounds start here*}

definition ln_upper_11 :: "real \<Rightarrow> real"
  where "ln_upper_11 x \<equiv>
           (5*x^5 + 647*x^4 + 4397*x^3 + 6397*x^2 + 2272*x + 142) * (x - 1) /
           (30*(6*x^5 + 75*x^4 + 200*x^3 + 150*x^2 + 30*x + 1))"

definition diff_delta_ln_upper_11 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_11 \<equiv> \<lambda>x. (x - 1)^11 / ((6*x^5 + 75*x^4 + 200*x^3 + 150*x^2 + 30*x + 1)^2 * x)"

lemma d_delta_ln_upper_11: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_11 x - ln x) has_field_derivative diff_delta_ln_upper_11 x) (at x)"
unfolding ln_upper_11_def diff_delta_ln_upper_11_def
apply (intro derivative_eq_intros | simp)+
apply auto
apply (auto simp: add_pos_pos dual_order.strict_implies_not_eq divide_simps, algebra)
done

lemma ln_upper_11_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_11 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_11])
apply (auto simp: diff_delta_ln_upper_11_def ln_upper_11_def)
done

lemma ln_upper_11_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_11 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_11])
using assms
apply (auto simp: diff_delta_ln_upper_11_def divide_simps ln_upper_11_def mult_less_0_iff)
done

theorem ln_upper_11: "0<x \<Longrightarrow> ln(x) \<le> ln_upper_11 x"
by (metis le_less_linear less_eq_real_def ln_upper_11_neg ln_upper_11_pos)

definition ln_lower_11 :: "real \<Rightarrow> real"
  where "ln_lower_11 \<equiv> \<lambda>x. - ln_upper_11 (inverse x)"

corollary ln_lower_11: "0<x \<Longrightarrow> ln_lower_11 x \<le> ln x"
  unfolding ln_lower_11_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_11)

theorem ln_lower_11_eq: "0<x \<Longrightarrow>
    ln_lower_11 x = (1/30)*(142*x^5 + 2272*x^4 + 6397*x^3 + 4397*x^2 + 647*x + 5)*(x - 1) /
                    (x*(x^5 + 30*x^4 + 150*x^3 + 200*x^2 + 75*x + 6))"
  unfolding ln_lower_11_def ln_upper_11_def
  by (simp add: zero_less_mult_iff add_pos_pos dual_order.strict_implies_not_eq divide_simps)
     algebra

section {*Upper Bound 13*}

definition ln_upper_13 :: "real \<Rightarrow> real"
  where "ln_upper_13 x \<equiv> (353 + 8389*x + 20149*x^4 + 50774*x^3 + 38524*x^2 + 1921*x^5 + 10*x^6) * (x - 1)
                          / (70*(1 + 42*x + 525*x^4 + 700*x^3 + 315*x^2 + 126*x^5 + 7*x^6))"

definition diff_delta_ln_upper_13 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_13 \<equiv> \<lambda>x. (x - 1)^13 /
                     ((1 + 42*x + 525*x^4 + 700*x^3 + 315*x^2 + 126*x^5 + 7*x^6)^2*x)"

lemma d_delta_ln_upper_13: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_13 x - ln x) has_field_derivative diff_delta_ln_upper_13 x) (at x)"
unfolding ln_upper_13_def diff_delta_ln_upper_13_def
apply (intro derivative_eq_intros | simp)+
apply auto
apply (auto simp: add_pos_pos dual_order.strict_implies_not_eq divide_simps, algebra)
done

lemma ln_upper_13_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_13 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_13])
apply (auto simp: diff_delta_ln_upper_13_def ln_upper_13_def)
done

lemma ln_upper_13_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_13 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_13])
using assms
apply (auto simp: diff_delta_ln_upper_13_def divide_simps ln_upper_13_def mult_less_0_iff)
done

theorem ln_upper_13: "0<x \<Longrightarrow> ln(x) \<le> ln_upper_13 x"
  by (metis le_less_linear less_eq_real_def ln_upper_13_neg ln_upper_13_pos)

definition ln_lower_13 :: "real \<Rightarrow> real"
  where "ln_lower_13 \<equiv> \<lambda>x. - ln_upper_13 (inverse x)"

corollary ln_lower_13: "0<x \<Longrightarrow> ln_lower_13 x \<le> ln x"
  unfolding ln_lower_13_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_13)

theorem ln_lower_13_eq: "0<x \<Longrightarrow>
    ln_lower_13 x = (1/70)*(10 + 1921*x + 20149*x^2 + 50774*x^3 + 38524*x^4 + 8389*x^5 + 353*x^6)*(x - 1) /
                    (x*(7 + 126*x + 525*x^2 + 700*x^3 + 315*x^4 + 42*x^5 + x^6))"
  unfolding ln_lower_13_def ln_upper_13_def
  by (simp add: zero_less_mult_iff add_pos_pos dual_order.strict_implies_not_eq divide_simps)
     algebra

section {*Upper Bound 15*}

definition ln_upper_15 :: "real \<Rightarrow> real"
  where "ln_upper_15 x \<equiv>
           (1487 + 49199*x + 547235*x^4 + 718735*x^3 + 334575*x^2 + 141123*x^5 + 35*x^7 + 9411*x^6)*(x - 1) /
           (280*(1 + 56*x + 2450*x^4 + 1960*x^3 + 588*x^2 + 1176*x^5 + 8*x^7 + 196*x^6))"

definition diff_delta_ln_upper_15 :: "real \<Rightarrow> real"
  where "diff_delta_ln_upper_15
         \<equiv> \<lambda>x. (x - 1)^15 / ((1+56*x+2450*x^4+1960*x^3+588*x^2+8*x^7+196*x^6+1176*x^5)^2 * x)"

lemma d_delta_ln_upper_15: "x > 0 \<Longrightarrow>
    ((\<lambda>x. ln_upper_15 x - ln x) has_field_derivative diff_delta_ln_upper_15 x) (at x)"
unfolding ln_upper_15_def diff_delta_ln_upper_15_def
apply (intro derivative_eq_intros | simp)+
apply auto
apply (auto simp: add_pos_pos dual_order.strict_implies_not_eq divide_simps, algebra)
done

lemma ln_upper_15_pos:
  assumes "1 \<le> x" shows "ln(x) \<le> ln_upper_15 x"
apply (rule gen_upper_bound_increasing [OF assms d_delta_ln_upper_15])
apply (auto simp: diff_delta_ln_upper_15_def ln_upper_15_def)
done

lemma ln_upper_15_neg:
  assumes "0 < x" and x1: "x \<le> 1" shows "ln(x) \<le> ln_upper_15 x"
apply (rule gen_upper_bound_decreasing [OF x1 d_delta_ln_upper_15])
using assms
apply (auto simp: diff_delta_ln_upper_15_def divide_simps ln_upper_15_def mult_less_0_iff)
done

theorem ln_upper_15: "0<x \<Longrightarrow> ln(x) \<le> ln_upper_15 x"
  by (metis le_less_linear less_eq_real_def ln_upper_15_neg ln_upper_15_pos)

definition ln_lower_15 :: "real \<Rightarrow> real"
  where "ln_lower_15 \<equiv> \<lambda>x. - ln_upper_15 (inverse x)"

corollary ln_lower_15: "0<x \<Longrightarrow> ln_lower_15 x \<le> ln x"
  unfolding ln_lower_15_def
  by (metis ln_inverse inverse_positive_iff_positive minus_le_iff ln_upper_15)

theorem ln_lower_15_eq: "0<x \<Longrightarrow>
    ln_lower_15 x = (1/280)*(35 + 9411*x + 141123*x^2 + 547235*x^3 + 718735*x^4 + 334575*x^5 + 49199*x^6 + 1487*x^7)*(x - 1) /
                    (x*(8 + 196*x + 1176*x^2 + 2450*x^3 + 1960*x^4 + 588*x^5 + 56*x^6 + x^7))"
  unfolding ln_lower_15_def ln_upper_15_def
  by (simp add: zero_less_mult_iff add_pos_pos dual_order.strict_implies_not_eq
              divide_simps) algebra

end


section \<open>Operations on sorted lists\<close>

theory Sorted_List_Operations2
imports Sorted_Less2
begin

text\<open>The definition and the inter\_sorted\_correct lemma in this theory are the same as those
     in Collections \<^cite>\<open>"OpsOnSortedLists-AFP"\<close>.
     except the former is for a descending list while the latter is for an ascending one.\<close>

fun inter_sorted_rev :: "'a::{linorder} list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
   "inter_sorted_rev [] l2 = []"
 | "inter_sorted_rev l1 [] = []"
 | "inter_sorted_rev (x1 # l1) (x2 # l2) =
    (if (x1 > x2) then (inter_sorted_rev l1 (x2 # l2)) else
      (if (x1 = x2) then x1 # (inter_sorted_rev l1 l2) else inter_sorted_rev (x1 # l1) l2))"

lemma inter_sorted_correct :
  assumes l1_OK: "sorted (rev l1)"
  assumes l2_OK: "sorted (rev l2)"
    shows "sorted (rev (inter_sorted_rev l1 l2)) \<and> set (inter_sorted_rev l1 l2) = set l1 \<inter> set l2"
using assms
proof (induct l1 arbitrary: l2)
  case Nil thus ?case by simp
next
  case (Cons x1 l1 l2)
  note x1_l1_props = Cons(2)
  note l2_props = Cons(3)

  from x1_l1_props have l1_props: "sorted (rev l1)"
                    and x1_nin_l1: "x1 \<notin> set l1"
                    and x1_gt: "\<And>x. x \<in> set l1 \<Longrightarrow> x1 > x"
    by (auto simp add: Ball_def sorted_wrt_append)

  note ind_hyp_l1 = Cons(1)[OF l1_props]
  show ?case
  using l2_props
  proof (induct l2)
    case Nil with x1_l1_props show ?case by simp
  next
    case (Cons x2 l2)
    note x2_l2_props = Cons(2)  (* sorted (rev (x2 # l2))*)
    from x2_l2_props have l2_props: "sorted (rev l2)"
                    and x2_nin_l2: "x2 \<notin> set l2"
                    and x2_gt: "\<And>x. x \<in> set l2 \<Longrightarrow> x2 > x"
    by (auto simp  add: Ball_def sorted_wrt_append )

    note ind_hyp_l2 = Cons(1)[OF l2_props]
    show ?case
    proof (cases "x1 > x2")
      case True note x1_gt_x2 = this
      have "set l1 \<inter> set (x2 # l2) = set (x1 # l1)\<inter> set (x2 # l2)"
        using x1_gt_x2 x1_nin_l1 x2_nin_l2 x1_gt x2_gt
        by fastforce
      then show ?thesis using ind_hyp_l1[OF x2_l2_props]  using x1_gt_x2 x1_nin_l1 x2_nin_l2 x1_gt x2_gt
        by (auto simp add:Ball_def sorted_wrt_append)
    next
      case False note x2_ge_x1 = this
      show ?thesis
      proof (cases "x1 = x2")
        case True note x1_eq_x2 = this
        then show ?thesis using ind_hyp_l1[OF l2_props]
          using x1_eq_x2  x1_nin_l1 x2_nin_l2 x1_gt x2_gt by (auto simp add:Ball_def sorted_wrt_append)
      next
        case False note x1_neq_x2 = this
        with x2_ge_x1 have x2_gt_x1 : "x2 > x1" by auto
        from ind_hyp_l2 x2_ge_x1 x1_neq_x2 x2_gt x2_nin_l2 x1_gt
        show ?thesis by auto
      qed
    qed
  qed
qed

lemma inter_sorted_rev_refl: "inter_sorted_rev xs xs = xs"
  by (induct xs) auto

lemma  inter_sorted_correct_col:
  assumes "sorted (rev xs)"
      and "sorted (rev ys)"
    shows "(inter_sorted_rev xs ys) = rev (sorted_list_of_set (set xs \<inter> set ys))"
  using assms
proof-
  from assms have 1: "sorted (rev (inter_sorted_rev xs ys)) "
              and 2: "set (inter_sorted_rev xs ys) = set xs \<inter> set ys" using inter_sorted_correct by auto
  have "sorted (rev (rev (sorted_list_of_set (set xs \<inter> set ys))))" by ( simp add:sorted_less_sorted_list_of_set)
  with 1 2 show ?thesis by (auto intro:sorted_less_rev_set_unique)
qed

lemma cons_set_eq: "set (x # xs) \<inter> set xs = set xs"
  by auto

lemma inter_sorted_cons: "sorted (rev (x # xs)) \<Longrightarrow> inter_sorted_rev (x # xs) xs = xs"
proof-
  assume ass: "sorted (rev (x # xs))"
  then have sorted_xs: "sorted (rev xs)" by (auto simp add:sorted_wrt_append)
  with ass have "inter_sorted_rev (x # xs) xs = rev (sorted_list_of_set (set (x # xs) \<inter> set xs))"
    by (simp add:inter_sorted_correct_col)
  then have "inter_sorted_rev (x # xs) xs = rev (rev xs)"using  sorted_xs by (simp only:cons_set_eq sorted_less_rev_set_eq)
  then show ?thesis using sorted_xs by auto
qed

end