header "Permutation Lemmas"

theory PermutationLemmas
imports "~~/src/HOL/Library/Permutation" "~~/src/HOL/Library/Multiset"
begin

  -- "following function is very close to that in multisets- now we can make the connection that x <~~> y iff the multiset of x is the same as that of y"

subsection "perm, count equivalence"

primrec count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat"
where
  "count x [] = 0"
| "count x (y#ys) = (if x=y then 1 else 0) + count x ys"

lemma perm_count: "A <~~> B \<Longrightarrow> (\<forall> x. count x A = count x B)"
  by(induct set: perm) auto

lemma count_0: "(\<forall>x. count x B = 0) = (B = [])"
  by(induct B) auto

lemma count_Suc: "count a B = Suc m \<Longrightarrow> a : set B"
  apply(induct B)
   apply auto
  apply(case_tac "a = aa")
   apply auto
  done

lemma count_append: "count a (xs@ys) = count a xs + count a ys"
  by(induct xs) auto

lemma count_perm: "!! B. (\<forall> x. count x A = count x B) \<Longrightarrow> A <~~> B"
  apply(induct A)
  apply(simp add: count_0)
proof -
  fix a list B
  assume a: "\<And>B. \<forall>x. count x list = count x B \<Longrightarrow> list <~~> B"
    and b: "\<forall>x. count x (a # list) = count x B"
  from b have "a : set B"
    apply auto
    apply (drule_tac x=a in spec, simp) apply(metis count_Suc) done
  from split_list[OF this] obtain xs ys where B: "B = xs@a#ys" by blast
  let ?B' = "xs@ys"
  from b have "\<forall>x. count x list = count x ?B'" by(simp add: count_append B)
  from a[OF this] have c: "list <~~> xs@ys" .
  hence "a#list <~~> a#(xs@ys)" by rule
  also have "a#(xs@ys) <~~> xs@a#ys" by(rule perm_append_Cons)
  also (perm.trans) note B[symmetric]
  finally show "a # list <~~> B" .
qed

lemma perm_count_conv: "A <~~> B = (\<forall> x. count x A = count x B)"
  apply(blast intro!: perm_count count_perm) done

subsection "Properties closed under Perm and Contr hold for x iff hold for remdups x"

lemma remdups_append: "y : set ys --> remdups (ws@y#ys) = remdups (ws@ys)"
  apply (induct ws, simp)
  apply (case_tac "y = a", simp, simp)
  done

lemma perm_contr': assumes perm[rule_format]: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and contr'[rule_format]: "! x xs. P(x#x#xs) = P (x#xs)"
  shows "! xs. length xs = n --> (P xs = P (remdups xs))"
  apply(induct n rule: nat_less_induct)
proof (safe)
  fix xs :: "'a list"
  assume a[rule_format]: "\<forall>m<length xs. \<forall>ys. length ys = m \<longrightarrow> P ys = P (remdups ys)"
  show "P xs = P (remdups xs)"
  proof (cases "distinct xs")
    case True
    thus ?thesis by(simp add:distinct_remdups_id)
  next
    case False
    from not_distinct_decomp[OF this] obtain ws ys zs y where xs: "xs = ws@[y]@ys@[y]@zs" by force
    have "P xs = P (ws@[y]@ys@[y]@zs)" by (simp add: xs)
    also have "... = P ([y,y]@ws@ys@zs)"
      apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
    also have "... = P ([y]@ws@ys@zs)" apply simp apply(rule contr') done
    also have "... = P (ws@ys@[y]@zs)"
      apply(rule perm) apply(rule iffD2[OF perm_count_conv]) apply rule apply(simp add: count_append) done
    also have "... = P (remdups (ws@ys@[y]@zs))"
      apply(rule a) by(auto simp: xs)
    also have "(remdups (ws@ys@[y]@zs)) = (remdups xs)"
      apply(simp add: xs remdups_append) done
    finally show "P xs = P (remdups xs)" .
  qed
qed

lemma perm_contr: assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and contr': "! x xs. P(x#x#xs) = P (x#xs)"
  shows "(P xs = P (remdups xs))"
  apply(rule perm_contr'[OF perm contr', rule_format]) by force

subsection "List properties closed under Perm, Weak and Contr are monotonic in the set of the list"

definition
  rem :: "'a => 'a list => 'a list" where
  "rem x xs = filter (%y. y ~= x) xs"

lemma rem: "x ~: set (rem x xs)"
  by(simp add: rem_def)

lemma length_rem: "length (rem x xs) <= length xs"
  by(simp add: rem_def)

lemma rem_notin: "x ~: set xs ==> rem x xs = xs"
  apply(simp add: rem_def)
  apply(rule filter_True)
  apply force
  done

lemma perm_weak_filter': assumes perm[rule_format]: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and weak[rule_format]: "! x xs. P xs --> P (x#xs)"
  shows "! ys. P (ys@filter Q xs) --> P (ys@xs)"
  apply (induct xs, simp, rule)
  apply rule
  apply simp
  apply (case_tac "Q a", simp)
   apply(drule_tac x="ys@[a]" in spec) apply simp
  apply simp
  apply(drule_tac x="ys@[a]" in spec) apply simp
  apply(erule impE)
   apply(subgoal_tac "(ys @ a # filter Q xs) <~~> a#ys@filter Q xs")
    apply(simp add: perm)
    apply(rule weak) apply simp
   apply(rule perm_sym) apply(rule perm_append_Cons)
  .

lemma perm_weak_filter: assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and weak: "! x xs. P xs --> P (x#xs)"
  shows "P (filter Q xs) ==> P xs"
  using perm_weak_filter'[OF perm weak, rule_format, of "[]", simplified]
  by blast

  -- "right, now in a position to prove that in presence of perm, contr and weak, set x leq set y and x : ded implies y : ded"

lemma perm_weak_contr_mono:
  assumes perm: "! xs ys. xs <~~> ys --> (P xs = P ys)"
  and contr: "! x xs. P (x#x#xs) --> P (x#xs)"
  and weak: "! x xs. P xs --> P (x#xs)"
  and xy: "set x <= set y"
  and Px : "P x"
  shows "P y"
proof -
  from contr weak have contr': "! x xs. P(x#x#xs) = P (x#xs)" by blast

  def y' == "filter (% z. z : set x) y"
  from xy have "set x = set y'" apply(simp add: y'_def) apply blast done
  hence rxry': "remdups x <~~> remdups y'" by(simp add: perm_remdups_iff_eq_set)

  from Px perm_contr[OF perm contr'] have Prx: "P (remdups x)" by simp
  with rxry' have "P (remdups y')" by(simp add: perm)

  with perm_contr[OF perm contr'] have "P y'" by simp
  thus "P y"
    apply(simp add: y'_def)
    apply(rule perm_weak_filter[OF perm weak]) .
qed

(* No, not used
subsection "Following used in Soundness"

primrec multiset_of_list :: "'a list \<Rightarrow> 'a multiset"
where
  "multiset_of_list [] = {#}"
| "multiset_of_list (x#xs) = {#x#} + multiset_of_list xs"

lemma count_count[symmetric]: "count x A = Multiset.count (multiset_of_list A) x"
  by (induct A) simp_all

lemma perm_multiset: "A <~~> B = (multiset_of_list A = multiset_of_list B)"
  apply(simp add: perm_count_conv)
  apply(simp add: multiset_eq_iff)
  apply(simp add: count_count)
  done

lemma set_of_multiset_of_list: "set_of (multiset_of_list A) = set A"
  by (induct A) auto
*)
end


(* Authors: Tobias Nipkow and Thomas Sewell *)

section "Sorting via Priority Queues Based on Braun Trees"

theory Sorting_Braun
imports Priority_Queue_Braun
begin

text \<open>This theory is about sorting algorithms based on heaps.
Algorithm A can be found here
\<^url>\<open>http://www.csse.canterbury.ac.nz/walter.guttmann/publications/0005.pdf\<close> on p. 54.
(published here \<^url>\<open>http://www.jucs.org/doi?doi=10.3217/jucs-009-02-0173\<close>)
Not really the classic heap sort but a mixture of heap sort and merge sort.
The algorithm (B) in Larry's book comes closer to the classic heap sort:
\<^url>\<open>https://www.cl.cam.ac.uk/~lp15/MLbook/programs/sample7.sml\<close>.

Both algorithms have two phases:
build a heap from a list, then extract the elements of the heap into a sorted list.
\<close>

abbreviation(input)
  "nlog2 n == nat(ceiling(log 2 n))"

section \<open>Phase 1: List to Tree\<close>

text \<open>Algorithm A does this naively, in $O(n lg n)$ fashion and generates a Braun tree:\<close>

fun heap_of_A :: "('a::linorder) list \<Rightarrow> 'a tree" where
"heap_of_A [] = Leaf" |
"heap_of_A (a#as) = insert a (heap_of_A as)"

(* just for testing
definition
  shuffle100 :: "nat list"
  where
  "shuffle100 = [50 :: nat, 7, 77, 15, 42, 82, 87, 68, 69, 29, 43, 24, 84, 12, 35, 30, 95, 45, 14, 47, 54, 66, 96, 71, 98, 4, 22, 0, 92, 86, 34, 33, 57, 91, 20, 13, 64, 73, 70, 8, 85, 40, 16, 18, 81, 99, 63, 41, 56, 72, 79, 48, 78, 52, 25, 49, 65, 90, 26, 76, 3, 59, 74, 58, 46, 38, 61, 94, 75, 11, 88, 31, 53, 17, 44, 89, 39, 93, 62, 5, 1, 21, 6, 55, 83, 28, 37, 60, 19, 67, 23, 97, 51, 10, 27, 32, 2, 36, 9, 80]"

value "heap_of_A shuffle100"
*)

lemma heap_heap_of_A: "heap (heap_of_A xs)"
by(induction xs)(simp_all add: heap_insert)

lemma braun_heap_of_A: "braun (heap_of_A xs)"
by(induction xs)(simp_all add: braun_insert)

lemma mset_tree_heap_of_A: "mset_tree (heap_of_A xs) = mset xs"
by(induction xs)(simp_all add: mset_insert)

text \<open>Running time is n*log n, which we can approximate with height.\<close>

fun t_insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_insert a Leaf = 1" |
"t_insert a (Node l x r) =
 (if a < x then 1 + t_insert x r else 1 + t_insert a r)"

fun t_heap_of_A :: "('a::linorder) list \<Rightarrow> nat" where
"t_heap_of_A [] = 0" |
"t_heap_of_A (a#as) = t_insert a (heap_of_A as) + t_heap_of_A as"

lemma t_insert_height:
  "t_insert x t \<le> height t + 1"
  apply (induct t arbitrary: x; simp)
  apply (simp only: max_Suc_Suc[symmetric] le_max_iff_disj, simp)
  done

lemma height_insert_ge:
  "height t \<le> height (insert x t)"
  apply (induct t arbitrary: x; simp add: le_max_iff_disj)
  apply (metis less_imp_le_nat less_le_trans not_le_imp_less)
  done

lemma t_heap_of_A_bound:
  "t_heap_of_A xs \<le> length xs * (height (heap_of_A xs) + 1)"
proof (induct xs)
  case (Cons x xs)

  let ?lhs = "t_insert x (heap_of_A xs) + t_heap_of_A xs"

  have "?lhs \<le> ?lhs"
    by simp
  also note Cons
  also note height_insert_ge[of "heap_of_A xs" x]
  also note t_insert_height[of x "heap_of_A xs"]

  finally show ?case
    apply simp
    apply (erule order_trans)
    apply (simp add: height_insert_ge)
    done
qed simp_all

lemma size_heap_of_A:
  "size (heap_of_A xs) = length xs"
  using arg_cong[OF mset_tree_heap_of_A, of size xs]
  by simp

lemma t_heap_of_A_log_bound:
  "t_heap_of_A xs \<le> length xs * (nlog2 (length xs + 1) + 1)"
  using t_heap_of_A_bound[of xs]
    balanced_if_braun[OF braun_heap_of_A, of xs]
  by (simp add: height_balanced size1_size size_heap_of_A)

text \<open>Algorithm B mimics heap sort more closely by building heaps bottom up in a balanced way:\<close>

fun heapify :: "nat \<Rightarrow> ('a::linorder) list \<Rightarrow> 'a tree * 'a list" where
"heapify 0 xs = (Leaf, xs)" |
"heapify (Suc n) (x#xs) =
	 (let (l, ys) = heapify (Suc n div 2) xs;
		    (r, zs) = heapify (n div 2) ys
	  in (sift_down l x r, zs))"

text \<open>The result should be a Braun tree:\<close>

lemma heapify_snd:
  "n \<le> length xs \<Longrightarrow> snd (heapify n xs) = drop n xs"
  apply (induct xs arbitrary: n rule: measure_induct[where f=length])
  apply (case_tac n; simp)
  apply (clarsimp simp: Suc_le_length_iff case_prod_beta)
  apply (rule arg_cong[where f="\<lambda>n. drop n xs" for xs])
  apply simp
  done

lemma heapify_snd_tup:
  "heapify n xs = (t, ys) \<Longrightarrow> n \<le> length xs \<Longrightarrow> ys = drop n xs"
  by (drule heapify_snd, simp)

lemma heapify_correct:
  "n \<le> length xs \<Longrightarrow> heapify n xs = (t, ys) \<Longrightarrow>
    size t = n \<and> heap t \<and> braun t \<and> mset_tree t = mset (take n xs)"
proof (induct n xs arbitrary: t ys rule: heapify.induct)
  case (2 n x xs)

  note len = "2.prems"(1)

  obtain t1 ys1 where h1: "heapify (Suc n div 2) xs = (t1, ys1)"
    by (simp add: prod_eq_iff)
  obtain t2 ys2 where h2: "heapify (n div 2) ys1 = (t2, ys2)"
    by (simp add: prod_eq_iff)

  from len have le1: "Suc n div 2 \<le> length xs"
    by simp
  note ys1 = heapify_snd_tup[OF h1 le1]
  from len have le2: "n div 2 \<le> length ys1"
    by (simp add: ys1)

  note app_hyps = "2.hyps"(1)[OF le1 h1]
    "2.hyps"(2)[OF refl h1[symmetric], simplified, OF le2 h2]

  hence braun: "braun (Node t1 x t2)"
    by (simp, linarith)

  have eq:
    "n div 2 + Suc n div 2 = n"
    by simp

  have msets:
    "mset (take (Suc n div 2) xs) + mset (take (n div 2) ys1) = mset (take n xs)"
    apply (subst append_take_drop_id[symmetric, where n="Suc n div 2" and t="take n xs"],
        subst mset_append)
    apply (simp add: take_drop min_absorb1 le1 eq ys1)
    done

  from "2.prems" app_hyps msets show ?case
    apply (clarsimp simp: h1 h2 le2)
    apply (clarsimp simp: size_sift_down[OF braun]
                       braun_sift_down[OF braun]
                       mset_sift_down[OF braun])
    apply (simp add: heap_sift_down[OF braun])
    done
qed simp_all

lemma braun_heapify:
  "n \<le> length xs \<Longrightarrow> braun (fst (heapify n xs))"
  by (cases "heapify n xs", drule(1) heapify_correct, simp)

lemma heap_heapify:
  "n \<le> length xs \<Longrightarrow> heap (fst (heapify n xs))"
  by (cases "heapify n xs", drule(1) heapify_correct, simp)

lemma mset_heapify:
  "n \<le> length xs \<Longrightarrow> mset_tree (fst (heapify n xs)) = mset (take n xs)"
  by (cases "heapify n xs", drule(1) heapify_correct, simp)

text \<open>The running time of heapify is linear.
  (similar to \<^url>\<open>https://en.wikipedia.org/wiki/Binary_heap#Building_a_heap\<close>)

This is an interesting result, so we embark on this exercise
to prove it the hard way.
\<close>

context includes pattern_aliases
begin

function (sequential) t_sift_down :: "'a::linorder tree \<Rightarrow> 'a \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_sift_down Leaf a Leaf = 1" |
"t_sift_down (Node Leaf x Leaf) a Leaf = 2" |
"t_sift_down (Node l1 x1 r1 =: t1) a (Node l2 x2 r2 =: t2) =
  (if a \<le> x1 \<and> a \<le> x2
   then 1
   else if x1 \<le> x2 then 1 + t_sift_down l1 a r1
        else 1 + t_sift_down l2 a r2)"
by pat_completeness auto

termination
by (relation "measure (%(l,a,r). size l + size r)") auto

end

fun t_heapify :: "nat \<Rightarrow> ('a::linorder) list \<Rightarrow> nat" where
"t_heapify 0 xs = 1" |
"t_heapify (Suc n) (x#xs) =
	 (let (l, ys) = heapify (Suc n div 2) xs;
        t1 = t_heapify (Suc n div 2) xs;
        (r, zs) = heapify (n div 2) ys;
		    t2 = t_heapify (n div 2) ys
	  in 1 + t1 + t2 + t_sift_down l x r)"

lemma t_sift_down_height:
  "braun (Node l x r) \<Longrightarrow> t_sift_down l x r \<le> height (Node l x r)"
  by (induct l x r rule: t_sift_down.induct; auto)

lemma sift_down_height:
  "braun (Node l x r) \<Longrightarrow> height (sift_down l x r) \<le> height (Node l x r)"
  by (induct l x r rule: sift_down.induct; auto simp: Let_def)

lemma braun_height_r_le:
  "braun (Node l x r) \<Longrightarrow> height r \<le> height l"
  by (rule balanced_optimal, auto intro: balanced_if_braun)

lemma braun_height_l_le:
  assumes b: "braun (Node l x r)"
  shows "height l \<le> Suc (height r)"
  using b balanced_if_braun[OF b] min_height_le_height[of r]
  by (simp add: balanced_def)

lemma braun_height_node_eq:
  assumes b: "braun (Node l x r)"
  shows "height (Node l x r) = Suc (height l)"
  using b braun_height_r_le[OF b]
  by (auto simp add: max_def)

lemma t_heapify_induct:
  "i \<le> length xs \<Longrightarrow> t_heapify i xs + height (fst (heapify i xs)) \<le> 5 * i + 1"
proof (induct i xs rule: t_heapify.induct)
  case (1 vs)
  thus ?case
    by simp
next
  case (2 i x xs)

  obtain l ys where h1: "heapify (Suc i div 2) xs = (l, ys)"
    by (simp add: prod_eq_iff)
  note hyps1 = "2.hyps"[OF h1[symmetric] refl, simplified]
  obtain r zs where h2: "heapify (i div 2) ys = (r, zs)"
    by (simp add: prod_eq_iff)

  from "2.prems" heapify_snd_tup[OF h1]
  have le1: "Suc i div 2 \<le> length xs"
    and le2: "i div 2 \<le> length xs"
    and le4: "i div 2 \<le> length ys"
    by simp_all

  note hyps2 = hyps1(1)[OF le1] hyps1(2)[OF refl h2[symmetric] refl le4]

  note prem = add_le_mono[OF add_le_mono[OF hyps2] order_refl[where x=3]]

  from heapify_correct[OF le1 h1] heapify_correct[OF le4 h2]
  have braun: "braun \<langle>l, x, r\<rangle>"
    by auto

  have t_sift_l:
    "t_sift_down l x r \<le> height l + 1"
    using t_sift_down_height[OF braun] braun_height_r_le[OF braun]
    by simp

  from t_sift_down_height[OF braun]
  have height_sift_r:
    "height (sift_down l x r) \<le> height r + 2"
    using sift_down_height[OF braun] braun_height_l_le[OF braun]
    by simp

  from h1 h2 t_sift_l height_sift_r "2.prems"
  show ?case
    apply simp
    apply (rule order_trans, rule order_trans[rotated], rule prem)
     apply simp_all
    apply (simp only: mult_le_cancel1 add_mult_distrib2[symmetric])
    apply simp
    done

qed simp_all

lemma t_heapify_bound:
  "i \<le> length xs \<Longrightarrow> t_heapify i xs \<le> 5 * i + 1"
  using t_heapify_induct[of i xs]
  by simp

section \<open>Phase 2: Heap to List\<close>

text\<open>Algorithm A extracts (\<open>list_of_A\<close>) the list by removing the root and merging the children:\<close>

(* For termination of \<open>merge\<close> only: *)
lemma size_prod_measure[measure_function]:
  "is_measure f \<Longrightarrow> is_measure g \<Longrightarrow> is_measure (size_prod f g)"
by (rule is_measure_trivial)

fun merge :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"merge Leaf t2 = t2" |
"merge t1 Leaf = t1" |
"merge (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then Node (merge l1 r1) a1 (Node l2 a2 r2)
    else Node (Node l1 a1 r1) a2 (merge l2 r2))"

(* Merging does not preserve braun: *)
value "merge \<langle>\<langle>\<rangle>, 0::int, \<langle>\<rangle>\<rangle> \<langle>\<langle>\<rangle>, 0, \<langle>\<rangle>\<rangle> = \<langle>\<langle>\<rangle>, 0, \<langle>\<langle>\<rangle>, 0, \<langle>\<rangle>\<rangle>\<rangle>"

lemma merge_size[termination_simp]:
  "size (merge l r) = size l + size r"
  by (induct rule: merge.induct; simp)

fun list_of_A :: "('a::linorder) tree \<Rightarrow> 'a list" where
"list_of_A Leaf = []" |
"list_of_A (Node l a r) = a # list_of_A (merge l r)"

value "list_of_A (heap_of_A shuffle100)"

lemma set_tree_merge[simp]:
  "set_tree (merge l r) = set_tree l \<union> set_tree r"
  by (induct l r rule: merge.induct; simp)

lemma mset_tree_merge[simp]:
  "mset_tree (merge l r) = mset_tree l + mset_tree r"
  by (induct l r rule: merge.induct; simp)

lemma merge_heap:
  "heap l \<Longrightarrow> heap r \<Longrightarrow> heap (merge l r)"
  by (induct l r rule: merge.induct; auto simp: ball_Un)

lemma set_list_of_A[simp]:
  "set (list_of_A t) = set_tree t"
  by (induct t rule: list_of_A.induct; simp)

lemma mset_list_of_A[simp]:
  "mset (list_of_A t) = mset_tree t"
  by (induct t rule: list_of_A.induct; simp)

lemma sorted_list_of_A:
  "heap t \<Longrightarrow> sorted (list_of_A t)"
  by (induct t rule: list_of_A.induct; simp add: merge_heap)

lemma sortedA: "sorted (list_of_A (heap_of_A xs))"
by (simp add: heap_heap_of_A sorted_list_of_A)

lemma msetA: "mset (list_of_A (heap_of_A xs)) = mset xs"
  by (simp add: mset_tree_heap_of_A)

text\<open>Does \<open>list_of_A\<close> take time $O(n lg n)$? Although \<open>merge\<close> does not preserve \<open>braun\<close>,
it cannot increase the height of the heap.\<close>

lemma merge_height:
  "height (merge l r) \<le>  Suc (max (height l) (height r))"
  by (induct rule: merge.induct, auto)

corollary merge_height_display:
  "height (merge l r) \<le> height (Node l x r)"
  using merge_height by simp

fun t_merge :: "('a::linorder) tree \<Rightarrow> 'a tree \<Rightarrow> nat" where
"t_merge Leaf t2 = 0" |
"t_merge t1 Leaf = 0" |
"t_merge (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then 1 + t_merge l1 r1
    else 1 + t_merge l2 r2)"

fun t_list_of_A :: "('a::linorder) tree \<Rightarrow> nat" where
"t_list_of_A Leaf = 0" |
"t_list_of_A (Node l a r) = 1 + t_merge l r + t_list_of_A (merge l r)"

lemma t_merge_height:
  "t_merge l r \<le> max (height l) (height r)"
  by (induct rule: t_merge.induct, auto)

lemma t_list_of_A_induct:
  "height t \<le> n \<Longrightarrow> t_list_of_A t \<le> 2 * n * size t"
  apply (induct rule: t_list_of_A.induct)
   apply simp
  apply simp
  apply (drule meta_mp)
   apply (rule order_trans, rule merge_height)
   apply simp
  apply (simp add: merge_size)
  apply (cut_tac l=l and r=r in t_merge_height)
  apply linarith
  done

lemma t_list_of_A_bound:
  "t_list_of_A t \<le> 2 * height t * size t"
  by (rule t_list_of_A_induct, simp)

lemma t_list_of_A_log_bound:
  "braun t \<Longrightarrow> t_list_of_A t \<le> 2 * nlog2 (size t + 1) * size t"
  using t_list_of_A_bound[of t]
  by (simp add: height_balanced balanced_if_braun size1_size)

value "t_list_of_A (heap_of_A shuffle100)"

theorem t_sortA:
  "t_heap_of_A xs + t_list_of_A (heap_of_A xs) \<le> 3 * length xs * (nlog2 (length xs + 1) + 1)"
  (is "?lhs \<le> _")
proof -
  have "?lhs \<le> ?lhs" by simp
  also note t_heap_of_A_log_bound[of xs]
  also note t_list_of_A_log_bound[of "heap_of_A xs", OF braun_heap_of_A]
  finally show ?thesis
    by (simp add: size_heap_of_A)
qed

text \<open>Running time of algorithm B:\<close>

(* Unfortunately this can only be proven to terminate conditionally.
   To make it unconditional would require a total specification of
   sift_down, which would be complex and differ substantially from
   Paulson's presentation.  *)
function list_of_B :: "('a::linorder) tree \<Rightarrow> 'a list" where
"list_of_B Leaf = []" |
"list_of_B (Node l a r) = a # list_of_B (del_min (Node l a r))"
  by pat_completeness auto

lemma list_of_B_braun_ptermination:
  "braun t \<Longrightarrow> list_of_B_dom t"
  apply (induct t rule: measure_induct[where f=size])
  apply (rule accpI, erule list_of_B_rel.cases)
  apply (clarsimp simp: size_del_min braun_del_min)
  done

lemmas list_of_B_braun_simps
    = list_of_B.psimps[OF list_of_B_braun_ptermination]

lemma mset_list_of_B:
  "braun t \<Longrightarrow> mset (list_of_B t) = mset_tree t"
  apply (induct t rule: measure_induct[where f=size])
  apply (case_tac x; simp add: list_of_B_braun_simps)
  apply (simp add: size_del_min braun_del_min mset_del_min)
  done

lemma set_list_of_B:
  "braun t \<Longrightarrow> set (list_of_B t) = set_tree t"
  by (simp only: set_mset_mset[symmetric] mset_list_of_B, simp)

lemma sorted_list_of_B:
  "braun t \<Longrightarrow> heap t \<Longrightarrow> sorted (list_of_B t)"
  apply (induct t rule: measure_induct[where f=size])
  apply (case_tac x; simp add: list_of_B_braun_simps)
  apply (clarsimp simp: set_list_of_B braun_del_min size_del_min heap_del_min)
  apply (simp add: set_mset_tree[symmetric] mset_del_min del: set_mset_tree)
  done

definition
  "heap_of_B xs = fst (heapify (length xs) xs)"

lemma sortedB: "sorted (list_of_B (heap_of_B xs))"
by (simp add: heap_of_B_def braun_heapify heap_heapify sorted_list_of_B)

lemma msetB: "mset (list_of_B (heap_of_B xs)) = mset xs"
by (simp add: heap_of_B_def braun_heapify mset_heapify mset_list_of_B)

fun t_del_left :: "'a tree \<Rightarrow> nat" where
"t_del_left (Node Leaf x r) = 1" |
"t_del_left (Node l x r) = (let (y,l') = del_left l in 2 + t_del_left l)"

fun t_del_min :: "'a::linorder tree \<Rightarrow> nat" where
"t_del_min Leaf = 0" |
"t_del_min (Node Leaf x r) = 0" |
"t_del_min (Node l x r) = (let (y,l') = del_left l in t_del_left l + t_sift_down r y l')"

function t_list_of_B :: "('a::linorder) tree \<Rightarrow> nat" where
"t_list_of_B Leaf = 0" |
"t_list_of_B (Node l a r) = 1 + t_del_min (Node l a r) + t_list_of_B (del_min (Node l a r))"
  by pat_completeness auto

lemma t_del_left_bound:
  "t \<noteq> Leaf \<Longrightarrow> t_del_left t \<le> 2 * height t"
  apply (induct rule: t_del_left.induct; clarsimp)
  apply (atomize(full); clarsimp simp: prod_eq_iff)
  apply (simp add: nat_mult_max_right le_max_iff_disj)
  done

lemma del_left_height:
  "del_left t = (v, t') \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> height t' \<le> height t"
  apply (induct t arbitrary: v t' rule: del_left.induct; simp)
  apply (atomize(full), clarsimp split: prod.splits)
  apply simp
  done

lemma t_del_min_bound:
  "braun t \<Longrightarrow> t_del_min t \<le> 3 * height t"
  apply (cases t rule: t_del_min.cases; simp)
  apply (clarsimp split: prod.split)
  apply (frule del_left_braun, simp+)
  apply (frule del_left_size, simp+)
  apply (frule del_left_height, simp)
  apply (rule order_trans)
   apply ((rule add_le_mono t_del_left_bound t_sift_down_height | simp)+)[1]
   apply auto[1]
  apply (simp add: max_def)
  done

lemma t_list_of_B_braun_ptermination:
  "braun t \<Longrightarrow> t_list_of_B_dom t"
  apply (induct t rule: measure_induct[where f=size])
  apply (rule accpI, erule t_list_of_B_rel.cases)
  apply (clarsimp simp: size_del_min braun_del_min)
  done

lemmas t_list_of_B_braun_simps
    = t_list_of_B.psimps[OF t_list_of_B_braun_ptermination]

lemma del_min_height:
  "braun t \<Longrightarrow> height (del_min t) \<le> height t"
  apply (cases t rule: del_min.cases; simp)
  apply (clarsimp split: prod.split)
  apply (frule del_left_braun, simp+)
  apply (frule del_left_size, simp+)
  apply (drule del_left_height)
   apply simp
  apply (rule order_trans, rule sift_down_height, auto)
  done

lemma t_list_of_B_induct:
  "braun t \<Longrightarrow> height t \<le> n \<Longrightarrow> t_list_of_B t \<le> 3 * (n + 1) * size t"
  apply (induct t rule: measure_induct[where f=size])
  apply (drule_tac x="del_min x" in spec)
  apply (frule del_min_height)
  apply (case_tac x; simp add: t_list_of_B_braun_simps)
  apply (rename_tac l x' r)
  apply (clarsimp simp: braun_del_min size_del_min)
  apply (rule order_trans)
   apply ((rule add_le_mono t_del_min_bound | assumption | simp)+)[1]
  apply simp
  done

lemma t_list_of_B_bound:
  "braun t \<Longrightarrow> t_list_of_B t \<le> 3 * (height t + 1) * size t"
  by (erule t_list_of_B_induct, simp)

definition
  "t_heap_of_B xs = length xs + t_heapify (length xs) xs"

lemma t_heap_of_B_bound:
  "t_heap_of_B xs \<le> 6 * length xs + 1"
  by (simp add: t_heap_of_B_def order_trans[OF t_heapify_bound])

lemmas size_heapify = arg_cong[OF mset_heapify, where f=size, simplified]

theorem t_sortB:
  "t_heap_of_B xs + t_list_of_B (heap_of_B xs)
    \<le> 3 * length xs * (nlog2 (length xs + 1) + 3) + 1"
  (is "?lhs \<le> _")
proof -
  have "?lhs \<le> ?lhs" by simp
  also note t_heap_of_B_bound[of xs]
  also note t_list_of_B_log_bound[of "heap_of_B xs"]
  finally show ?thesis
    apply (simp add: size_heapify braun_heapify heap_of_B_def)
    apply (simp add: field_simps)
    done
qed

(* One suspects that algorithm A is actually faster, despite being
algorithmically slower on the construction of the heap. The operation
merge needs to allocate one constructor per level of the heap,
as opposed to del_min, which needs three, so the extraction is probably
much faster. Not sure how to validate that.

value "t_list_of_B (heap_of
  [50 :: nat, 7, 77, 15, 42, 82, 87, 68, 69, 29, 43, 24, 84, 12, 35, 30, 95, 45, 14, 47, 54, 66, 96, 71, 98, 4, 22, 0, 92, 86, 34, 33, 57, 91, 20, 13, 64, 73, 70, 8, 85, 40, 16, 18, 81, 99, 63, 41, 56, 72, 79, 48, 78, 52, 25, 49, 65, 90, 26, 76, 3, 59, 74, 58, 46, 38, 61, 94, 75, 11, 88, 31, 53, 17, 44, 89, 39, 93, 62, 5, 1, 21, 6, 55, 83, 28, 37, 60, 19, 67, 23, 97, 51, 10, 27, 32, 2, 36, 9, 80]
)"
 *)

end


section {* Types of Cardinality 2 or Greater *}

theory Two
imports HOL.Real
begin

text {* The two class states that a type's carrier is either infinite, or else it has a finite
  cardinality of at least 2. It is needed when we depend on having at least two distinguishable
  elements. *}

class two =
  assumes card_two: "infinite (UNIV :: 'a set) \<or> card (UNIV :: 'a set) \<ge> 2"
begin
lemma two_diff: "\<exists> x y :: 'a. x \<noteq> y"
proof -
  obtain A where "finite A" "card A = 2" "A \<subseteq> (UNIV :: 'a set)"
  proof (cases "infinite (UNIV :: 'a set)")
    case True
    with infinite_arbitrarily_large[of "UNIV :: 'a set" 2] that
    show ?thesis by auto
  next
    case False
    with card_two that
    show ?thesis
      by (metis UNIV_bool card_UNIV_bool card_image card_le_inj finite.intros(1) finite_insert finite_subset)
  qed
  thus ?thesis
    by (metis (full_types) One_nat_def Suc_1 UNIV_eq_I card.empty card.insert finite.intros(1) insertCI nat.inject nat.simps(3))
qed
end

instance bool :: two
  by (intro_classes, auto)

instance nat :: two
  by (intro_classes, auto)

instance int :: two
  by (intro_classes, auto simp add: infinite_UNIV_int)

instance rat :: two
  by (intro_classes, auto simp add: infinite_UNIV_char_0)

instance real :: two
  by (intro_classes, auto simp add: infinite_UNIV_char_0)

instance list :: (type) two
  by (intro_classes, auto simp add: infinite_UNIV_listI)

end


(*  Title:      HOL/Examples/Ackermann.thy
    Author:     Larry Paulson
*)

section \<open>A Tail-Recursive, Stack-Based Ackermann's Function\<close>

theory Ackermann imports Main

begin

text\<open>This theory investigates a stack-based implementation of Ackermann's function.
Let's recall the traditional definition,
as modified by R{\'o}zsa P\'eter and Raphael Robinson.\<close>

fun ack :: "[nat,nat] \<Rightarrow> nat" where
  "ack 0 n             = Suc n"
| "ack (Suc m) 0       = ack m 1"
| "ack (Suc m) (Suc n) = ack m (ack (Suc m) n)"

text\<open>Here is the stack-based version, which uses lists.\<close>

function (domintros) ackloop :: "nat list \<Rightarrow> nat" where
  "ackloop (n # 0 # l)         = ackloop (Suc n # l)"
| "ackloop (0 # Suc m # l)     = ackloop (1 # m # l)"
| "ackloop (Suc n # Suc m # l) = ackloop (n # Suc m # m # l)"
| "ackloop [m] = m"
| "ackloop [] =  0"
  by pat_completeness auto

text\<open>
The key task is to prove termination. In the first recursive call, the head of the list gets bigger
while the list gets shorter, suggesting that the length of the list should be the primary
termination criterion. But in the third recursive call, the list gets longer. The idea of trying
a multiset-based termination argument is frustrated by the second recursive call when m = 0:
the list elements are simply permuted.

Fortunately, the function definition package allows us to define a function and only later identify its domain of termination.
Instead, it makes all the recursion equations conditional on satisfying
the function's domain predicate. Here we shall eventually be able
to show that the predicate is always satisfied.\<close>

text\<open>@{thm [display] ackloop.domintros[no_vars]}\<close>
declare ackloop.domintros [simp]

text \<open>Termination is trivial if the length of the list is less then two.
The following lemma is the key to proving termination for longer lists.\<close>
lemma "\<And>n l. ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
proof (induction m)
  case 0
  then show ?case
    by auto
next
  case (Suc m)
  note IH = Suc
  have "\<And>l. ackloop_dom (ack (Suc m) n # l) \<Longrightarrow> ackloop_dom (n # Suc m # l)"
  proof (induction n)
    case 0
    then show ?case
      by (simp add: IH)
  next
    case (Suc n)
    then show ?case
      by (auto simp: IH)
  qed
  then show ?case
    using Suc.prems by blast
qed

text \<open>The proof above (which actually is unused) can be expressed concisely as follows.\<close>
lemma ackloop_dom_longer:
  "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
  by (induction m n arbitrary: l rule: ack.induct) auto

lemma "ackloop_dom (ack m n # l) \<Longrightarrow> ackloop_dom (n # m # l)"
  by (induction m n arbitrary: l rule: ack.induct) auto

text\<open>This function codifies what @{term ackloop} is designed to do.
Proving the two functions equivalent also shows that @{term ackloop} can be used
to compute Ackermann's function.\<close>
fun acklist :: "nat list \<Rightarrow> nat" where
  "acklist (n#m#l) = acklist (ack m n # l)"
| "acklist [m] = m"
| "acklist [] =  0"

text\<open>The induction rule for @{term acklist} is @{thm [display] acklist.induct[no_vars]}.\<close>

lemma ackloop_dom: "ackloop_dom l"
  by (induction l rule: acklist.induct) (auto simp: ackloop_dom_longer)

termination ackloop
  by (simp add: ackloop_dom)

text\<open>This result is trivial even by inspection of the function definitions
(which faithfully follow the definition of Ackermann's function).
All that we needed was termination.\<close>
lemma ackloop_acklist: "ackloop l = acklist l"
  by (induction l rule: ackloop.induct) auto

theorem ack: "ack m n = ackloop [n,m]"
  by (simp add: ackloop_acklist)

end


theory Reihen
imports Complex_Main
begin

lemma gauss :   "(\<Sum>i=0 .. (n::nat) . i) = n*(n+1) div 2"
proof (induct n)
  case 0
  show ?case by simp
 next
  case (Suc n)
  assume "\<Sum>{0..n} = n * (n + 1) div 2"
  thus ?case by simp
qed

lemma "(\<Sum>i=0..(n::nat) . (2*i - 1)) = n^2"
  using [[simp_trace_new mode=full]]
proof (induct n)
  case 0
  show ?case by simp
 next
  fix n
  case (Suc n)
  assume a:"(\<Sum>i = 0..n. 2 * i - 1) = n\<^sup>2"
  have " ((\<Sum>i = 0..Suc n. 2 * i - 1) = (Suc n)\<^sup>2) =  ( (2*n+1)  + (\<Sum>i = 0.. n. 2 * i - 1) = (Suc n)\<^sup>2)" by auto
  also have " \<dots> =  ( (2*n+1)  + (\<Sum>i = 0.. n. 2 * i - 1) = (n + 1)^2)"  by simp
  also have "\<dots> =  ( (2*n+1)  + (\<Sum>i = 0.. n. 2 * i - 1) = n^2 + 2*n + 1) " unfolding power2_sum by simp
  also from a have  " \<dots> =   ( (2*n+1)  + n^2 = n^2 + 2*n + 1)  " by auto
  finally show ?case by auto
qed

lemma fixes n::nat shows"(\<Sum>i = 1 .. n . i^2) = (n*(n + 1)*(2*n + 1)) div 6"
proof (induct n)
  case 0
  show ?case by simp
 next
  fix n::nat
  case (Suc n)
  assume hyp:"(\<Sum>i = 1..n. i\<^sup>2) = (n * (n + 1) * (2 * n + 1)) div 6"

  have "Suc n * (Suc n + 1) * (2 * Suc n + 1)   = (n + 1) * (n + 2) * (2 * n + 2 + 1) " by simp
  also have " \<dots> =  (n^2 +3*n + 2) * (2 * n + 2 +1)" by (simp add : power2_eq_square)
  also have "\<dots>  =  (n^2 +3*n + 2) * (2 * n + 3)"
  proof -
    have tmp:"(2 * n + 2 +1) = (2 * n + 3)" by auto
    show ?thesis by (simp only: tmp )
  qed
  also have "\<dots> =   (n^2 +3*n + 2)*2*n +   (n^2 +3*n + 2)*3" by (simp only : ring_distribs)
  also have "\<dots> =  (n^2 +3*n + 2)*2*n +   3*n^2 +9*n + 6 " by (simp only : ring_distribs)
  also have "\<dots>  = 2*(n^2)*n +6*n^2 + 4*n  + 3*n^2 +9*n + 6" by (simp add : ring_distribs power2_eq_square)
  also have "\<dots> = 2*n^3 +9*n^2 + 13*n + 6 " by (simp add: power2_eq_square power3_eq_cube)
  finally have " (Suc n * (Suc n + 1) * (2 * Suc n + 1)) div 6 =  (2 * n ^ 3 + 9 * n\<^sup>2 + 13 * n + 6) div 6" by simp
  note tmpResult1 = this

  have "(\<Sum>i = 1..Suc n. i\<^sup>2) =   (\<Sum>i = 1 .. (n + 1).  i\<^sup>2)" by simp
  also have "\<dots> = (n^2 + 2*n + 1)+ (\<Sum>i = 1 .. n.  i\<^sup>2)" by (simp add : power2_eq_square)
  also have "\<dots> = (6*(n^2 + 2*n + 1) div 6) + (\<Sum>i = 1 .. n.  i\<^sup>2)" by auto
  also have "\<dots> = ((6*n^2 + 12*n + 6) div 6) + (\<Sum>i = 1 .. n.  i\<^sup>2)" by simp
  also have "\<dots> =  ((6*n^2 + 12*n + 6) div 6) + (n * (n + 1) * (2 * n + 1)) div 6 " unfolding hyp by simp
  also have "\<dots> = ((6*n^2 + 12*n + 6) + (n * (n + 1) * (2 * n + 1)))div 6 " by simp
  also have "\<dots> = ((6*n^2 + 12*n + 6) + ((n^2 + n)* (2 * n + 1))) div 6" by (simp add : power2_eq_square ring_distribs)
  also have "\<dots> = ((6*n^2 + 12*n + 6) + (2*n^3 + 3*n^2 + n)) div 6" by (simp add : power2_eq_square power3_eq_cube ring_distribs)
  also  have "\<dots> = (2*n^3 + 9*n^2 + 13*n + 6) div 6 " by simp
  note tmpResult2 =  calculation
  from tmpResult1 and tmpResult2 show ?case by simp
qed

theorem fixes n:: nat and p::nat and q::nat shows "\<Sum> i = 0 .. n . "

lemma " suminf (\<lambda>n. c^n) = (1 / (1 - c))"
proof


section \<open>Powerset\<close>
theory Powerset
  imports
    Main
    n_Sequences
    Common_Lemmas
    Filter_Bool_List
begin

subsection"Definition"

text "Pow A"
text "Cardinality: \<open>2 ^ card A\<close>"
text "Example: \<open>Pow {0,1} = {{}, {1}, {0}, {0, 1}}\<close>"

subsection"Algorithm"

fun all_bool_lists :: "nat \<Rightarrow> bool list list" where
  "all_bool_lists 0 = [[]]"
| "all_bool_lists (Suc x) = concat [[False#xs, True#xs] . xs \<leftarrow> all_bool_lists x]"

fun powerset_enum where
  "powerset_enum xs = [(filter_bool_list x xs) . x \<leftarrow> all_bool_lists (length xs)]"

subsection"Verification"

text "First we show the relevant theorems for \<open>all_bool_lists\<close>, then we'll transfer the
results to the enumeration algorithm for powersets."

lemma distinct_concat_aux: "distinct xs \<Longrightarrow> distinct (concat (map (\<lambda>xs. [False # xs, True # xs]) xs))"
  by (induct xs) auto

lemma distinct_all_bool_lists : "distinct (all_bool_lists x)"
  by (induct x) (auto simp add: distinct_concat_aux)

lemma all_bool_lists_correct: "set (all_bool_lists x) = {xs. length xs = x}"
proof(standard)
  show "set (all_bool_lists x) \<subseteq> {xs. length xs = x}"
    by (induct x) auto
next
  show "{xs. length xs = x} \<subseteq> set (all_bool_lists x)"
  proof(induct x)
    case 0
    then show ?case by simp
  next
    case (Suc x)
    have "length ys = Suc x \<Longrightarrow> \<exists>xs. ys = False # xs \<or> ys = True # xs" for ys
      by (metis (full_types) Suc_length_conv)
    then show ?case using Suc
      by fastforce
  qed
qed

subsubsection"Correctness"

theorem powerset_enum_correct: "set (map set (powerset_enum xs)) = Pow (set xs)"
proof(standard)
  show "set (map set (powerset_enum xs)) \<subseteq> Pow (set xs)"
    using filter_bool_list_not_elem by fastforce
next
  have "\<And>x. x \<subseteq> set xs \<Longrightarrow> x \<in> (\<lambda>x. set (filter_bool_list x xs)) ` {zs. length zs = length xs}"
    unfolding image_def using filter_bool_list_exist_length image_def by auto
  then show "Pow (set xs) \<subseteq> set (map set (powerset_enum xs))"
    using all_bool_lists_correct by auto
qed

subsubsection"Distinctness"

theorem powerset_enum_distinct_elem: "distinct xs \<Longrightarrow> ys \<in> set (powerset_enum xs) \<Longrightarrow> distinct ys"
  using filter_bool_list_distinct by auto

theorem powerset_enum_distinct: "distinct xs \<Longrightarrow> distinct (powerset_enum xs)"
proof -
  assume dis: "distinct xs"
  then have " distinct (map (\<lambda>x. filter_bool_list x xs) (all_bool_lists (length xs)))"
    using distinct_map filter_bool_list_inj distinct_all_bool_lists
    by (metis all_bool_lists_correct)
  then show ?thesis
    using dis by simp
qed

subsubsection"Cardinality"

text "Cardinality for powersets is already shown in @{thm [source] card_Pow}."

subsection"Alternative algorithm with \<open>n_sequence_enum\<close>"

fun all_bool_lists2 :: "nat \<Rightarrow> bool list list" where
  "all_bool_lists2 n = n_sequence_enum [True, False] n"

lemma all_bool_lists2_distinct: "distinct (all_bool_lists2 n)"
  by (auto simp add: n_sequence_enum_distinct)

lemma all_bool_lists2_correct: "set (all_bool_lists n) = set (all_bool_lists2 n)"
  by (auto simp: all_bool_lists_correct n_sequence_enum_correct n_sequences_def)

end


theory MyList
imports Main
begin

fun itrev :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"itrev [] ys = ys" |
"itrev (x#xs) ys = itrev xs (x#ys)"

lemma "itrev xs [] = rev xs"
apply(induction xs)
apply(auto)
done

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc (add m n)"

fun iadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"iadd 0 n = n" |
"iadd (Suc m) n = iadd m (Suc n)"

value "iadd 3 2"
value "iadd 2 0"
value "iadd 0 0"

lemma [simp] : "add m (Suc n) = Suc (add m n)"
apply(induction m)
apply(auto)
done

lemma "iadd m n = add m n"
apply(induction m arbitrary: n)
apply(auto)
done

end


theory tangle_relation
imports Datatype Main
begin

lemma symmetry1: assumes "symp R"
shows "\<forall>x y. (x, y) \<in> {(x, y). R x y}\<^sup>* \<longrightarrow> (y, x) \<in> {(x, y). R x y}\<^sup>*"
proof-
have  "R x y \<longrightarrow>  R y x" by (metis assms sympD)
then have " (x, y) \<in> {(x, y). R x y} \<longrightarrow> (y, x) \<in> {(x, y). R x y}" by auto
then have 2:"\<forall> x y. (x, y) \<in> {(x, y). R x y} \<longrightarrow> (y, x) \<in> {(x, y). R x y}"
 by (metis (full_types) assms mem_Collect_eq split_conv sympE)
then have "sym {(x, y). R x y}" unfolding sym_def by auto
then have 3: "sym (rtrancl {(x, y). R x y})" using sym_rtrancl by auto
then show ?thesis by (metis symE)
qed

lemma symmetry2: assumes "\<forall>x y. (x, y) \<in> {(x, y). R x y}\<^sup>* \<longrightarrow> (y, x) \<in> {(x, y). R x y}\<^sup>* "
shows "symp R^**"
unfolding symp_def Enum.rtranclp_rtrancl_eq assms by (metis assms)

lemma symmetry3: assumes "symp R" shows "symp R^**" using assms symmetry1 symmetry2 by metis

lemma symm_trans: assumes "symp R" shows "symp R^++" by (metis assms rtranclpD symmetry3 symp_def tranclp_into_rtranclp)

end


section \<open>Peano's axioms for Natural Numbers\<close>

theory Peano_Axioms
  imports MainRLT
begin

locale peano =  \<comment> \<open>or: \<^theory_text>\<open>class\<close>\<close>
  fixes zero :: 'a
  fixes succ :: "'a \<Rightarrow> 'a"
  assumes succ_neq_zero [simp]: "succ m \<noteq> zero"
  assumes succ_inject [simp]: "succ m = succ n \<longleftrightarrow> m = n"
  assumes induct [case_names zero succ, induct type: 'a]:
    "P zero \<Longrightarrow> (\<And>n. P n \<Longrightarrow> P (succ n)) \<Longrightarrow> P n"
begin

lemma zero_neq_succ [simp]: "zero \<noteq> succ m"
  by (rule succ_neq_zero [symmetric])

text \<open>\<^medskip> Primitive recursion as a (functional) relation -- polymorphic!\<close>

inductive Rec :: "'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
  for e :: 'b and r :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
where
  Rec_zero: "Rec e r zero e"
| Rec_succ: "Rec e r m n \<Longrightarrow> Rec e r (succ m) (r m n)"

lemma Rec_functional: "\<exists>!y::'b. Rec e r x y" for x :: 'a
proof -
  let ?R = "Rec e r"
  show ?thesis
  proof (induct x)
    case zero
    show "\<exists>!y. ?R zero y"
    proof
      show "?R zero e" ..
      show "y = e" if "?R zero y" for y
        using that by cases simp_all
    qed
  next
    case (succ m)
    from \<open>\<exists>!y. ?R m y\<close>
    obtain y where y: "?R m y" and yy': "\<And>y'. ?R m y' \<Longrightarrow> y = y'"
      by blast
    show "\<exists>!z. ?R (succ m) z"
    proof
      from y show "?R (succ m) (r m y)" ..
    next
      fix z
      assume "?R (succ m) z"
      then obtain u where "z = r m u" and "?R m u"
        by cases simp_all
      with yy' show "z = r m y"
        by (simp only:)
    qed
  qed
qed

text \<open>\<^medskip> The recursion operator -- polymorphic!\<close>

definition rec :: "'b \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
  where "rec e r x = (THE y. Rec e r x y)"

lemma rec_eval:
  assumes Rec: "Rec e r x y"
  shows "rec e r x = y"
  unfolding rec_def
  using Rec_functional and Rec by (rule the1_equality)

lemma rec_zero [simp]: "rec e r zero = e"
proof (rule rec_eval)
  show "Rec e r zero e" ..
qed

lemma rec_succ [simp]: "rec e r (succ m) = r m (rec e r m)"
proof (rule rec_eval)
  let ?R = "Rec e r"
  have "?R m (rec e r m)"
    unfolding rec_def using Rec_functional by (rule theI')
  then show "?R (succ m) (r m (rec e r m))" ..
qed

text \<open>\<^medskip> Example: addition (monomorphic)\<close>

definition add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  where "add m n = rec n (\<lambda>_ k. succ k) m"

lemma add_zero [simp]: "add zero n = n"
  and add_succ [simp]: "add (succ m) n = succ (add m n)"
  unfolding add_def by simp_all

lemma add_zero_right: "add m zero = m"
  by (induct m) simp_all

lemma add_succ_right: "add m (succ n) = succ (add m n)"
  by (induct m) simp_all

lemma "add (succ (succ (succ zero))) (succ (succ zero)) =
    succ (succ (succ (succ (succ zero))))"
  by simp

text \<open>\<^medskip> Example: replication (polymorphic)\<close>

definition repl :: "'a \<Rightarrow> 'b \<Rightarrow> 'b list"
  where "repl n x = rec [] (\<lambda>_ xs. x # xs) n"

lemma repl_zero [simp]: "repl zero x = []"
  and repl_succ [simp]: "repl (succ n) x = x # repl n x"
  unfolding repl_def by simp_all

lemma "repl (succ (succ (succ zero))) True = [True, True, True]"
  by simp

end

text \<open>\<^medskip> Just see that our abstract specification makes sense \dots\<close>

interpretation peano 0 Suc
proof
  fix m n
  show "Suc m \<noteq> 0" by simp
  show "Suc m = Suc n \<longleftrightarrow> m = n" by simp
  show "P n"
    if zero: "P 0"
    and succ: "\<And>n. P n \<Longrightarrow> P (Suc n)"
    for P
  proof (induct n)
    case 0
    show ?case by (rule zero)
  next
    case Suc
    then show ?case by (rule succ)
  qed
qed

end


(*  Title:      HOL/ex/Pythagoras.thy
    Author:     Amine Chaieb
*)

section "The Pythagorean Theorem"

theory Pythagoras
imports Complex_Main
begin

text \<open>Expressed in real numbers:\<close>

lemma pythagoras_verbose:
  "((A1::real) - B1) * (C1 - B1) + (A2 - B2) * (C2 - B2) = 0 \<Longrightarrow>
  (C1 - A1) * (C1 - A1) + (C2 - A2) * (C2 - A2) =
  ((B1 - A1) * (B1 - A1) + (B2 - A2) * (B2 - A2)) + (C1 - B1) * (C1 - B1) + (C2 - B2) * (C2 - B2)"
  by algebra

text \<open>Expressed in vectors:\<close>

type_synonym point = "real \<times> real"

lemma pythagoras:
  defines ort:"orthogonal \<equiv> (\<lambda>(A::point) B. fst A * fst B + snd A * snd B = 0)"
       and vc:"vector \<equiv> (\<lambda>(A::point) B. (fst A  - fst B, snd A - snd B))"
      and vcn:"vecsqnorm \<equiv> (\<lambda>A::point. fst A ^ 2 + snd A ^2)"
 assumes o: "orthogonal (vector A B) (vector C B)"
 shows "vecsqnorm(vector C A) = vecsqnorm(vector B  A) + vecsqnorm(vector C B)"
   using o unfolding ort vc vcn by (algebra add: fst_conv snd_conv)

 end


theory Assertion imports
"State"

begin

(*evalF defines the semantics of assertions written in first-order logic*)
primrec evalF :: "state => fform => bool" where
"evalF (f,WTrue) = (True)" |
"evalF (f,WFalse) = (False)" |
"evalF (f,e1 [=] e2) = (case (evalE (f,e1), evalE (f,e2)) of
                            (RR (r1),RR (r2)) => ((r1::real) = r2) |
                            (SS (r1),SS (r2)) => ((r1::string) = r2) |
                            (BB (r1),BB (r2)) => ((r1::bool) = r2) |
                            (_,_) => False)" |
"evalF (f,e1 [<] e2) = (case (evalE (f,e1), evalE (f,e2)) of
                            (RR (r1),RR (r2)) => ((r1::real) < r2) |
                            (_,_) => False)" |
"evalF (f,e1 [>] e2) = (case (evalE (f,e1), evalE (f,e2)) of
                            (RR (r1),RR (r2)) => (r1::real) > r2 |
                            (_,_) => False)" |
"evalF (f,[~] form1) = (~ (evalF (f,form1)))" |
"evalF (f,form1 [&] form2) = ((evalF (f,form1)) & (evalF (f,form2)))" |
"evalF (f,form1 [|] form2) = ((evalF (f,form1)) | (evalF (f,form2)))" |
"evalF (f,form1 [-->] form2) = ((evalF (f,form1)) --> (evalF (f,form2)))" |
"evalF (f,form1 [<->] form2) = ((evalF (f,form1)) <-> (evalF (f,form2)))" |
"evalF (f,WALL x form1)= (ALL (v::real). (evalF((%a. %i. (if (a=x) then (RR (v)) else (f(a, i)))), form1)))" |
"evalF (f,WEX x form1)= (EX (v::real). evalF((%a. %i. (if (a=x) then (RR (v)) else f(a, i))), form1))"

definition evalFP :: "cstate => fform => now => bool" where
"evalFP(f,P,c) == ALL s. inList(s,f(c)) --> evalF(s,P)"

(*ievalF defines the semantics of assertions written in interval logic and duration calculus*)
consts ievalF :: "cstate => fform => now => now => bool"
axiomatization where
chop_eval: "ievalF (f, P[^]Q, c, d) =  (EX k s1 s2. s1@s2=f(k) & ievalF (%t. if t=k then s1 else f(t), P, c, k)
                                                  & ievalF (%t. if t=k then s2 else f(t), Q, k, d))" and
chop_sep: "ievalF (f, P, c, d) = (ALL k s1 s2. s1@s2=f(k) --> ievalF (%t. if t=k then s1 else f(t), P, c, k)
                                                  & ievalF (%t. if t=k then s2 else f(t), P, k, d))" and
pf_eval: "ievalF (f, pf (P), c, d) = (c=d & (EX s. inList(s, f(c))) & evalF (s, P))" and
high_eval: "ievalF (f, high P, c, d) = ((ALL (k::real). (c<k & k<d) --> evalFP (f, P, k)))" and
chop_interval: "(ALL t. (c=d --> f(c)=g(c)) & (c<=t & t<=d --> f(t)=g(t))) ==> ievalF(f,P,c,d)=ievalF(g,P,c,d)"

lemma chop_eval1: "(EX k. ievalF (f, P, c, k) & ievalF (f, Q, k, d)) ==> ievalF (f, P[^]Q, c, d)"
apply (simp add: chop_eval,auto)
apply (cut_tac x=k in exI,auto)
apply (cut_tac x="f(k)" in exI,auto)
apply (subgoal_tac "f = (%t. if t = k then f(k) else f(t))",auto)
apply (subgoal_tac "(ALL ka s1 s2. s1@s2=f(ka) --> ievalF (%t. if t=ka then s1 else f(t), Q, k, ka)
                                                  & ievalF (%t. if t=ka then s2 else f(t), Q, ka, d))")
apply (subgoal_tac "ievalF(%t. if t = k then f(k) else f(t), Q, k, k) &
               ievalF(%t. if t = k then [] else f(t), Q, k, d)")
apply blast
apply (erule allE)+
apply blast
apply (cut_tac f=f and P=Q and c=k and d=d in chop_sep,auto)
done

(*The following axioms define the evaluation of formulas of part of first-order interval logic.*)
axiomatization where
True_eval : "ievalF (f,WTrue, c, d) = (True)"  and
False_eval : "ievalF (f,WFalse,c,d) = (False)" and
L_eval : "ievalF (f, (l [=] Real L), c, d) = (d-c = L)" and
(*Equal_eval : "ievalF (f,e1 [=] e2,c,d) = evalFP(f,e1 [=] e2,c)" and
Less_eval : "ievalF (f,e1 [<] e2,c,d) = evalFP(f,e1 [<] e2,c)" and
Great_eval: "ievalF (f,e1 [>] e2,c,d) = evalFP(f,e1 [>] e2,c)" and*)
Not_eval: "ievalF (f,[~] form1,c,d) = (~ (ievalF (f,form1,c,d)))" and
And_eval: "ievalF (f,form1 [&] form2,c,d) = ((ievalF (f,form1,c,d)) & (ievalF (f,form2,c,d)))" and
Or_eval: "ievalF (f,F [|] G,c,d) = ((ievalF (f,F,c,d)) | (ievalF (f,G,c,d)))" and
Imply_eval: "ievalF (f,form1 [-->] form2,c,d) = ((ievalF (f,form1,c,d)) --> (ievalF (f,form2,c,d)))" and
Equiv_eval: "ievalF (f,form1 [<->] form2,c,d) = ((ievalF (f,form1,c,d)) <-> (ievalF (f,form2,c,d)))" and
ALL_eval: "ievalF (f,WALL x form1,c,d)= (ALL (v::real). ievalF((%t. List.map(%s. %y i. if y=x & i=R then RR(v) else s(y,i),f(t))), form1, c, d))" and
EX_eval: "ievalF (f,WEX x form1,c,d)= (EX (v::real). ievalF((%t. List.map(%s. %y i. if y=x & i=R then RR(v) else s(y,i),f(t))), form1, c, d))"

(*The following axioms define the semantic meanings of closure of formulas.*)
axiomatization where
close_fact1: "ALL t. (t>=b & t<c --> evalF (f, p)) --> (evalF (f, close(p)))" and
close_fact2: "ALL t. (t>=b & t<c --> evalF (f, p)) --> (evalF (f, close([~]p)))" and
close_fact3: "evalF (s,p) ==> evalF (s,close(p))"

end


section \<open> Enumeration Extras \<close>

theory Enum_extra
  imports "HOL-Library.Cardinality"
begin

subsection \<open> First Index Function \<close>

text \<open> The following function extracts the index of the first occurrence of an element in a list,
  assuming it is indeed an element. \<close>

fun first_ind :: "'a list \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat" where
"first_ind [] y i = undefined" |
"first_ind (x # xs) y i = (if (x = y) then i else first_ind xs y (Suc i))"

lemma first_ind_length:
  "x \<in> set(xs) \<Longrightarrow> first_ind xs x i < length(xs) + i"
  by (induct xs arbitrary: i, auto, metis add_Suc_right)

lemma nth_first_ind:
  "\<lbrakk> distinct xs; x \<in> set(xs) \<rbrakk> \<Longrightarrow> xs ! (first_ind xs x i - i) = x"
  apply (induct xs arbitrary: i)
   apply (auto)
  apply (metis One_nat_def add.right_neutral add_Suc_right add_diff_cancel_left' diff_diff_left empty_iff first_ind.simps(2) list.set(1) nat.simps(3) neq_Nil_conv nth_Cons' zero_diff)
  done

lemma first_ind_nth:
  "\<lbrakk> distinct xs; i < length xs \<rbrakk> \<Longrightarrow> first_ind xs (xs ! i) j = i + j"
  apply (induct xs arbitrary: i j)
   apply (auto)
   apply (metis less_Suc_eq_le nth_equal_first_eq)
  using less_Suc_eq_0_disj apply auto
  done

subsection \<open> Enumeration Indices \<close>

syntax
  "_ENUM" :: "type \<Rightarrow> logic" ("ENUM'(_')")

translations
  "ENUM('a)" => "CONST Enum.enum :: ('a::enum) list"

text \<open> Extract a unique natural number associated with an enumerated value by using its index
  in the characteristic list \<^term>\<open>ENUM('a)\<close>. \<close>

definition enum_ind :: "'a::enum \<Rightarrow> nat" where
"enum_ind (x :: 'a::enum) = first_ind ENUM('a) x 0"

lemma length_enum_CARD: "length ENUM('a) = CARD('a)"
  by (simp add: UNIV_enum distinct_card enum_distinct)

lemma CARD_length_enum: "CARD('a) = length ENUM('a)"
  by (simp add: length_enum_CARD)

lemma enum_ind_less_CARD [simp]: "enum_ind (x :: 'a::enum) < CARD('a)"
  using first_ind_length[of x, OF in_enum, of 0] by (simp add: enum_ind_def CARD_length_enum)

lemma enum_nth_ind [simp]: "Enum.enum ! (enum_ind x) = x"
  using nth_first_ind[of Enum.enum x 0, OF enum_distinct in_enum] by (simp add: enum_ind_def)

lemma enum_distinct_conv_nth:
  assumes "i < CARD('a)" "j < CARD('a)" "ENUM('a) ! i = ENUM('a) ! j"
  shows "i = j"
proof -
  have "(\<forall>i<length ENUM('a). \<forall>j<length ENUM('a). i \<noteq> j \<longrightarrow> ENUM('a) ! i \<noteq> ENUM('a) ! j)"
    using distinct_conv_nth[of "ENUM('a)", THEN sym] by (simp add: enum_distinct)
  with assms show ?thesis
    by (auto simp add: CARD_length_enum)
qed

lemma enum_ind_nth [simp]:
  assumes "i < CARD('a::enum)"
  shows "enum_ind (ENUM('a) ! i) = i"
  using assms first_ind_nth[of "ENUM('a)" i 0, OF enum_distinct]
  by (simp add: enum_ind_def CARD_length_enum)

lemma enum_ind_spec:
  "enum_ind (x :: 'a::enum) = (THE i. i < CARD('a) \<and> Enum.enum ! i = x)"
proof (rule sym, rule the_equality, safe)
  show "enum_ind x < CARD('a)"
    by (simp add: enum_ind_less_CARD[of x])
  show "enum_class.enum ! enum_ind x = x"
    by simp
  show "\<And>i. i < CARD('a) \<Longrightarrow> x = ENUM('a) ! i \<Longrightarrow> i = enum_ind (ENUM('a) ! i)"
    by (simp add: enum_ind_nth)
qed

lemma enum_ind_inj: "inj (enum_ind :: 'a::enum \<Rightarrow> nat)"
  by (rule inj_on_inverseI[of _ "\<lambda> i. ENUM('a) ! i"], simp)

lemma enum_ind_neq [simp]: "x \<noteq> y \<Longrightarrow> enum_ind x \<noteq> enum_ind y"
  by (simp add: enum_ind_inj inj_eq)

end


header "Derivatives of regular expressions"

(* Author: Christian Urban *)

theory Derivatives
imports Regular_Exp
begin

text{* This theory is based on work by Brozowski \cite{Brzozowski64} and Antimirov \cite{Antimirov95}. *}

subsection {* Brzozowski's derivatives of regular expressions *}

primrec
  deriv :: "'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "deriv c (Zero) = Zero"
| "deriv c (One) = Zero"
| "deriv c (Atom c') = (if c = c' then One else Zero)"
| "deriv c (Plus r1 r2) = Plus (deriv c r1) (deriv c r2)"
| "deriv c (Times r1 r2) =
    (if nullable r1 then Plus (Times (deriv c r1) r2) (deriv c r2) else Times (deriv c r1) r2)"
| "deriv c (Star r) = Times (deriv c r) (Star r)"

primrec
  derivs :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "derivs [] r = r"
| "derivs (c # s) r = derivs s (deriv c r)"

lemma atoms_deriv_subset: "atoms (deriv x r) \<subseteq> atoms r"
by (induction r) (auto)

lemma atoms_derivs_subset: "atoms (derivs w r) \<subseteq> atoms r"
by (induction w arbitrary: r) (auto dest: atoms_deriv_subset[THEN subsetD])

lemma lang_deriv: "lang (deriv c r) = Deriv c (lang r)"
by (induct r) (simp_all add: nullable_iff)

lemma lang_derivs: "lang (derivs s r) = Derivs s (lang r)"
by (induct s arbitrary: r) (simp_all add: lang_deriv)

text {* A regular expression matcher: *}

definition matcher :: "'a rexp \<Rightarrow> 'a list \<Rightarrow> bool" where
"matcher r s = nullable (derivs s r)"

lemma matcher_correctness: "matcher r s \<longleftrightarrow> s \<in> lang r"
by (induct s arbitrary: r)
   (simp_all add: nullable_iff lang_deriv matcher_def Deriv_def)

subsection {* Antimirov's partial derivatives *}

abbreviation
  "Timess rs r \<equiv> (\<Union>r' \<in> rs. {Times r' r})"

primrec
  pderiv :: "'a \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp set"
where
  "pderiv c Zero = {}"
| "pderiv c One = {}"
| "pderiv c (Atom c') = (if c = c' then {One} else {})"
| "pderiv c (Plus r1 r2) = (pderiv c r1) \<union> (pderiv c r2)"
| "pderiv c (Times r1 r2) =
    (if nullable r1 then Timess (pderiv c r1) r2 \<union> pderiv c r2 else Timess (pderiv c r1) r2)"
| "pderiv c (Star r) = Timess (pderiv c r) (Star r)"

primrec
  pderivs :: "'a list \<Rightarrow> 'a rexp \<Rightarrow> ('a rexp) set"
where
  "pderivs [] r = {r}"
| "pderivs (c # s) r = \<Union> (pderivs s ` pderiv c r)"

abbreviation
 pderiv_set :: "'a \<Rightarrow> 'a rexp set \<Rightarrow> 'a rexp set"
where
  "pderiv_set c rs \<equiv> \<Union> (pderiv c ` rs)"

abbreviation
  pderivs_set :: "'a list \<Rightarrow> 'a rexp set \<Rightarrow> 'a rexp set"
where
  "pderivs_set s rs \<equiv> \<Union> (pderivs s ` rs)"

lemma pderivs_append:
  "pderivs (s1 @ s2) r = \<Union> (pderivs s2 ` pderivs s1 r)"
by (induct s1 arbitrary: r) (simp_all)

lemma pderivs_snoc:
  shows "pderivs (s @ [c]) r = pderiv_set c (pderivs s r)"
by (simp add: pderivs_append)

lemma pderivs_simps [simp]:
  shows "pderivs s Zero = (if s = [] then {Zero} else {})"
  and   "pderivs s One = (if s = [] then {One} else {})"
  and   "pderivs s (Plus r1 r2) = (if s = [] then {Plus r1 r2} else (pderivs s r1) \<union> (pderivs s r2))"
by (induct s) (simp_all)

lemma pderivs_Atom:
  shows "pderivs s (Atom c) \<subseteq> {Atom c, One}"
by (induct s) (simp_all)

subsection {* Relating left-quotients and partial derivatives *}

lemma Deriv_pderiv:
  shows "Deriv c (lang r) = \<Union> (lang ` pderiv c r)"
by (induct r) (auto simp add: nullable_iff conc_UNION_distrib)

lemma Derivs_pderivs:
  shows "Derivs s (lang r) = \<Union> (lang ` pderivs s r)"
proof (induct s arbitrary: r)
  case (Cons c s)
  have ih: "\<And>r. Derivs s (lang r) = \<Union> (lang ` pderivs s r)" by fact
  have "Derivs (c # s) (lang r) = Derivs s (Deriv c (lang r))" by simp
  also have "\<dots> = Derivs s (\<Union> (lang ` pderiv c r))" by (simp add: Deriv_pderiv)
  also have "\<dots> = Derivss s (lang ` (pderiv c r))"
    by (auto simp add:  Derivs_def)
  also have "\<dots> = \<Union> (lang ` (pderivs_set s (pderiv c r)))"
    using ih by auto
  also have "\<dots> = \<Union> (lang ` (pderivs (c # s) r))" by simp
  finally show "Derivs (c # s) (lang r) = \<Union> (lang ` pderivs (c # s) r)" .
qed (simp add: Derivs_def)

subsection {* Relating derivatives and partial derivatives *}

lemma deriv_pderiv:
  shows "\<Union> (lang ` (pderiv c r)) = lang (deriv c r)"
unfolding lang_deriv Deriv_pderiv by simp

lemma derivs_pderivs:
  shows "\<Union> (lang ` (pderivs s r)) = lang (derivs s r)"
unfolding lang_derivs Derivs_pderivs by simp

subsection {* Finiteness property of partial derivatives *}

definition
  pderivs_lang :: "'a lang \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp set"
where
  "pderivs_lang A r \<equiv> \<Union>x \<in> A. pderivs x r"

lemma pderivs_lang_subsetI:
  assumes "\<And>s. s \<in> A \<Longrightarrow> pderivs s r \<subseteq> C"
  shows "pderivs_lang A r \<subseteq> C"
using assms unfolding pderivs_lang_def by (rule UN_least)

lemma pderivs_lang_union:
  shows "pderivs_lang (A \<union> B) r = (pderivs_lang A r \<union> pderivs_lang B r)"
by (simp add: pderivs_lang_def)

lemma pderivs_lang_subset:
  shows "A \<subseteq> B \<Longrightarrow> pderivs_lang A r \<subseteq> pderivs_lang B r"
by (auto simp add: pderivs_lang_def)

definition
  "UNIV1 \<equiv> UNIV - {[]}"

lemma pderivs_lang_Zero [simp]:
  shows "pderivs_lang UNIV1 Zero = {}"
unfolding UNIV1_def pderivs_lang_def by auto

lemma pderivs_lang_One [simp]:
  shows "pderivs_lang UNIV1 One = {}"
unfolding UNIV1_def pderivs_lang_def by (auto split: if_splits)

lemma pderivs_lang_Atom [simp]:
  shows "pderivs_lang UNIV1 (Atom c) = {One}"
unfolding UNIV1_def pderivs_lang_def
apply(auto)
apply(frule rev_subsetD)
apply(rule pderivs_Atom)
apply(simp)
apply(case_tac xa)
apply(auto split: if_splits)
done

lemma pderivs_lang_Plus [simp]:
  shows "pderivs_lang UNIV1 (Plus r1 r2) = pderivs_lang UNIV1 r1 \<union> pderivs_lang UNIV1 r2"
unfolding UNIV1_def pderivs_lang_def by auto

text {* Non-empty suffixes of a string (needed for the cases of @{const Times} and @{const Star} below) *}

definition
  "PSuf s \<equiv> {v. v \<noteq> [] \<and> (\<exists>u. u @ v = s)}"

lemma PSuf_snoc:
  shows "PSuf (s @ [c]) = (PSuf s) @@ {[c]} \<union> {[c]}"
unfolding PSuf_def conc_def
by (auto simp add: append_eq_append_conv2 append_eq_Cons_conv)

lemma PSuf_Union:
  shows "(\<Union>v \<in> PSuf s @@ {[c]}. f v) = (\<Union>v \<in> PSuf s. f (v @ [c]))"
by (auto simp add: conc_def)

lemma pderivs_lang_snoc:
  shows "pderivs_lang (PSuf s @@ {[c]}) r = (pderiv_set c (pderivs_lang (PSuf s) r))"
unfolding pderivs_lang_def
by (simp add: PSuf_Union pderivs_snoc)

lemma pderivs_Times:
  shows "pderivs s (Times r1 r2) \<subseteq> Timess (pderivs s r1) r2 \<union> (pderivs_lang (PSuf s) r2)"
proof (induct s rule: rev_induct)
  case (snoc c s)
  have ih: "pderivs s (Times r1 r2) \<subseteq> Timess (pderivs s r1) r2 \<union> (pderivs_lang (PSuf s) r2)"
    by fact
  have "pderivs (s @ [c]) (Times r1 r2) = pderiv_set c (pderivs s (Times r1 r2))"
    by (simp add: pderivs_snoc)
  also have "\<dots> \<subseteq> pderiv_set c (Timess (pderivs s r1) r2 \<union> (pderivs_lang (PSuf s) r2))"
    using ih by fast
  also have "\<dots> = pderiv_set c (Timess (pderivs s r1) r2) \<union> pderiv_set c (pderivs_lang (PSuf s) r2)"
    by (simp)
  also have "\<dots> = pderiv_set c (Timess (pderivs s r1) r2) \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by (simp add: pderivs_lang_snoc)
  also
  have "\<dots> \<subseteq> pderiv_set c (Timess (pderivs s r1) r2) \<union> pderiv c r2 \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by auto
  also
  have "\<dots> \<subseteq> Timess (pderiv_set c (pderivs s r1)) r2 \<union> pderiv c r2 \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by (auto simp add: if_splits)
  also have "\<dots> = Timess (pderivs (s @ [c]) r1) r2 \<union> pderiv c r2 \<union> pderivs_lang (PSuf s @@ {[c]}) r2"
    by (simp add: pderivs_snoc)
  also have "\<dots> \<subseteq> Timess (pderivs (s @ [c]) r1) r2 \<union> pderivs_lang (PSuf (s @ [c])) r2"
    unfolding pderivs_lang_def by (auto simp add: PSuf_snoc)
  finally show ?case .
qed (simp)

lemma pderivs_lang_Times_aux1:
  assumes a: "s \<in> UNIV1"
  shows "pderivs_lang (PSuf s) r \<subseteq> pderivs_lang UNIV1 r"
using a unfolding UNIV1_def PSuf_def pderivs_lang_def by auto

lemma pderivs_lang_Times:
  shows "pderivs_lang UNIV1 (Times r1 r2) \<subseteq> Timess (pderivs_lang UNIV1 r1) r2 \<union> pderivs_lang UNIV1 r2"
apply(rule pderivs_lang_subsetI)
apply(rule subset_trans)
apply(rule pderivs_Times)
using pderivs_lang_Times_aux1 pderivs_lang_Times_aux2
apply(blast)
done

lemma pderivs_Star:
  assumes a: "s \<noteq> []"
  shows "pderivs s (Star r) \<subseteq> Timess (pderivs_lang (PSuf s) r) (Star r)"
using a
proof (induct s rule: rev_induct)
  case (snoc c s)
  have ih: "s \<noteq> [] \<Longrightarrow> pderivs s (Star r) \<subseteq> Timess (pderivs_lang (PSuf s) r) (Star r)" by fact
  { assume asm: "s \<noteq> []"
    have "pderivs (s @ [c]) (Star r) = pderiv_set c (pderivs s (Star r))" by (simp add: pderivs_snoc)
    also have "\<dots> \<subseteq> pderiv_set c (Timess (pderivs_lang (PSuf s) r) (Star r))"
      using ih[OF asm] by fast
    also have "\<dots> \<subseteq> Timess (pderiv_set c (pderivs_lang (PSuf s) r)) (Star r) \<union> pderiv c (Star r)"
      by (auto split: if_splits)
    also have "\<dots> \<subseteq> Timess (pderivs_lang (PSuf (s @ [c])) r) (Star r) \<union> (Timess (pderiv c r) (Star r))"
      by (simp only: PSuf_snoc pderivs_lang_snoc pderivs_lang_union)
         (auto simp add: pderivs_lang_def)
    also have "\<dots> = Timess (pderivs_lang (PSuf (s @ [c])) r) (Star r)"
      by (auto simp add: PSuf_snoc PSuf_Union pderivs_snoc pderivs_lang_def)
    finally have ?case .
  }
  moreover
  { assume asm: "s = []"
    then have ?case by (auto simp add: pderivs_lang_def pderivs_snoc PSuf_def)
  }
  ultimately show ?case by blast
qed (simp)

lemma pderivs_lang_Star:
  shows "pderivs_lang UNIV1 (Star r) \<subseteq> Timess (pderivs_lang UNIV1 r) (Star r)"
apply(rule pderivs_lang_subsetI)
apply(rule subset_trans)
apply(rule pderivs_Star)
apply(simp add: UNIV1_def)
apply(simp add: UNIV1_def PSuf_def)
apply(auto simp add: pderivs_lang_def)
done

lemma finite_Timess [simp]:
  assumes a: "finite A"
  shows "finite (Timess A r)"
using a by auto

lemma finite_pderivs_lang_UNIV1:
  shows "finite (pderivs_lang UNIV1 r)"
apply(induct r)
apply(simp_all add:
  finite_subset[OF pderivs_lang_Times]
  finite_subset[OF pderivs_lang_Star])
done

lemma pderivs_lang_UNIV:
  shows "pderivs_lang UNIV r = pderivs [] r \<union> pderivs_lang UNIV1 r"
unfolding UNIV1_def pderivs_lang_def
by blast

lemma finite_pderivs_lang_UNIV:
  shows "finite (pderivs_lang UNIV r)"
unfolding pderivs_lang_UNIV
by (simp add: finite_pderivs_lang_UNIV1)

lemma finite_pderivs_lang:
  shows "finite (pderivs_lang A r)"
by (metis finite_pderivs_lang_UNIV pderivs_lang_subset rev_finite_subset subset_UNIV)

end


theory Chap5 imports Main
begin

lemma "\<not> surj ( f :: 'a \<Rightarrow> 'a set )"
proof
  assume 0 : "surj f"
  from this have "\<forall> A . \<exists> a . A = f a" by ( simp add: surj_def)
  from this have "\<exists> a . { x . x \<notin> f x } = f a" by blast
  from this have "\<exists> a . x \<in> f a = ( x \<notin> f a )" by blast
  from this show "False" by blast
qed

lemma
  assumes T : "\<forall> x y . T x y \<or> T y x"
      and A : "\<forall> x y . A x y \<and> A y x \<longrightarrow> x = y"
      and TA: "\<forall> x y . T x y \<longrightarrow> A x y"
      and "A x y"
    shows "T x y"
proof cases
  assume "T x y"
  thus "T x y" by simp
next
  assume "\<not> T x y"
  hence "T y x" using T by blast
  hence "A y x" using TA by blast
  hence "x = y" using assms by blast
  thus "T x y" using T by blast
qed

lemma "( \<exists> ys zs . xs = ys @ zs \<and> length ys = length zs )
     \<or> ( \<exists> ys zs . xs = ys @ zs \<and> length ys = length zs + 1 )"
proof cases
  assume "even ( length xs )"
    hence "\<exists> n . length xs = 2*n" by ( auto simp add: dvd_def )
    then obtain n where "length xs = 2*n" by blast
    let ?ys = "take n xs"
    let ?zs = "drop n xs"
    have "length ?ys = length ?zs" by (simp add: `length xs = 2 * n`)
    hence "xs = ?ys @ ?zs \<and> length ?ys = length ?zs" by simp
    hence "\<exists> ys zs . xs = ys @ zs \<and> length ys = length zs" by blast
  thus ?thesis by blast
next
  assume "odd ( length xs )"
    hence "\<exists> n . length xs = (2 * n) + 1" by presburger
    from this obtain n where "length xs = (2 * n) + 1" by blast
    let ?ys = "take ( n + 1 ) xs"
    let ?zs = "drop ( n + 1 ) xs"
    have "length ?ys = length ?zs + 1" by ( simp add: `length xs = (2 * n) + 1`)
    hence "xs = ?ys @ ?zs \<and> length ?ys = length ?zs + 1" by auto
    hence "\<exists> ys zs . xs = ys @ zs \<and> length ys = length zs + 1" by blast
  thus ?thesis by blast
qed

lemma "length(tl xs) = length xs - 1"
proof ( cases xs )
  assume "xs = []"
  thus ?thesis by simp
next
  fix y ys assume "xs = y # ys"
  thus ?thesis by simp
qed

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS : "ev n \<Longrightarrow> ev (Suc(Suc n))"

lemma "ev n \<Longrightarrow> ev ( n - 2 )"
proof -
  assume "ev n"
  from this have "ev ( n - 2 )"
  proof ( cases )
    case ev0 thus "ev ( n - 2 )" by ( simp add: ev.ev0 )
  next
    case (evSS k) thus "ev ( n - 2 )" by simp
  qed
  thus ?thesis by blast
qed

lemma "ev ( Suc m ) \<Longrightarrow> \<not> ev m"
proof ( induction "Suc m" arbitrary: m rule: ev.induct )
  fix n assume IH: "\<And> m . n = Suc m \<Longrightarrow> \<not> ev m"
  show "\<not> ev ( Suc n )"
  proof -- contradiction
    assume "ev ( Suc n )"
    thus False
    proof ( cases "Suc n" -- rule  )
      fix k assume "n = Suc k" "ev k"
      thus False using IH by auto
    qed
  qed
qed

lemma
  assumes "ev n"
  shows "ev ( n - 2 )"
proof -
  show "ev ( n - 2 )" using `ev n`
  proof cases
    case ev0 thus "ev ( n - 2 )" by ( simp add: ev.ev0)
  next
    case evSS thus "ev ( n - 2 )" by simp
  qed
qed

lemma
  assumes a: "ev ( Suc ( Suc n ) )"
  shows "ev n"
proof -
  from a show "ev n" by cases
qed

lemma "\<not> ev ( Suc ( Suc ( Suc 0 ) ) )"
proof
  assume "ev ( Suc ( Suc ( Suc 0 ) ) )"
  thus False
  proof cases
    assume "ev ( Suc 0 )" hence False by cases
    thus False by blast
  qed
qed

inductive star :: "( 'a \<Rightarrow> 'a \<Rightarrow> bool ) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl  : "star r x x" |
  step  : "r x y  \<Longrightarrow>  star r y z  \<Longrightarrow>  star r x z"

inductive iter :: "( 'a \<Rightarrow> 'a \<Rightarrow> bool ) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl_i : "iter r 0 x x" |
  step_i : "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r ( n + 1 ) x z"

lemma "iter r n x y \<Longrightarrow> star r x y"
proof ( induction rule: iter.induct )
  fix x show "star r x x" by ( simp add: refl )
  fix x y n z assume "r x y" "star r y z"
  thus "star r x z" by ( metis step )
qed

fun elems :: "'a list \<Rightarrow> 'a set" where
  "elems [] = {}" |
  "elems ( a # as ) = { a } \<union> elems as"

lemma "x \<in> elems xs \<Longrightarrow> \<exists> ys zs. xs = ys @ x # zs \<and> x \<notin> elems ys"
proof ( induction xs rule: elems.induct )
  assume "x \<in> elems []"
  thus "\<exists> ys zs . [] = ys @ x # zs \<and> x \<notin> elems ys"  by simp

  next
  fix a as assume IH : "(x \<in> elems as \<Longrightarrow> \<exists>ys zs. as = ys @ x # zs \<and> x \<notin> elems ys)"
               and H : "x \<in> elems (a # as)"
  thus "\<exists>ys zs. a # as = ys @ x # zs \<and> x \<notin> elems ys"

  proof ( cases "x = a" )
    assume "x \<noteq> a"
    hence "x \<in> elems as" using H by auto
    hence "\<exists> ys zs . as = ys @ x # zs \<and> x \<notin> elems ys" using IH  by auto
    then obtain ys zs where "as = ys @ x # zs \<and> x \<notin> elems ys" by blast
      hence "a # as = (a # ys) @ x # zs \<and> x \<notin> elems ( a # ys )" using `x \<noteq> a` by auto
    thus "\<exists>ys zs. a # as = ys @ x # zs \<and> x \<notin> elems ys" by blast

  next
    assume "x = a"
    hence "a # as = [] @ x # as \<and> x \<notin> elems []" by auto
    thus ?thesis by blast

  qed
qed

datatype alpha = a | b

inductive S :: "alpha list \<Rightarrow> bool" where
  emptyS  : "S []" |
  middl   : "S w \<Longrightarrow> S ( a # w @ [b] )" |
  doubl   : "S w \<Longrightarrow> S v \<Longrightarrow> S ( w @ v )"

inductive T :: "alpha list \<Rightarrow> bool" where
  emptyT  : "T []" |
  alter   : "T w \<Longrightarrow> T v \<Longrightarrow> T ( w @ a # v @ [b] )"

lemma TImpS : "T w \<Longrightarrow> S w"
  apply ( induction rule: T.induct )
  apply ( rule emptyS )
  apply ( rule doubl )
  apply ( assumption )
  apply ( rule middl )
  apply ( assumption )
done

lemma app_emp : "T ([] @ a # w @ [b]) \<Longrightarrow> T ( a # w @ [b])"
  apply ( auto )
done

lemma assoc_arb : "X ((w @ a # v @ b # wa) @ a # va @ [b]) \<Longrightarrow> X (w @ a # v @ b # wa @ a # va @ [b])"
  apply ( auto )
done

lemma append_T : "T ts \<Longrightarrow> T v \<Longrightarrow> T w \<Longrightarrow> T (w @ a # v @ b # ts)"
  apply ( induction rule: T.induct )
  apply ( metis alter )
  apply ( rule assoc_arb )
  apply ( metis alter )
done

lemma doublT : "T w \<Longrightarrow> T v \<Longrightarrow> T ( w @ v)"
  apply ( induction rule: T.induct )
  apply ( auto )
  apply ( metis append_T )
done

lemma SImpT : "S w \<Longrightarrow> T w"
  apply ( induction rule: S.induct )
  apply ( rule emptyT )
  apply ( rule app_emp )
  apply ( rule alter )
  apply ( rule emptyT )
  apply ( assumption )
  apply ( metis doublT )
done

thm append_eq_append_conv_if leD

lemma "S w = T w" by ( metis SImpT TImpS )

lemma ab_inter : "S ( v @ w ) \<Longrightarrow> S ( v @ a # b # w )"
proof ( induction "v @ w" arbitrary: v w rule: S.induct )

  fix v :: "alpha list" and w assume
    E : "[] = v @ w"
    show "S ( v @ a # b # w )"
  proof -
    have "S ( a # [] @ [b] )" by ( metis middl emptyS )
    hence "S ( a # [b] )" by simp
    moreover have "v=[]" using E by simp
    moreover have "w=[]" using E by simp
    ultimately show "S ( v @ a # b # w )" by simp
  qed

  next
  fix w v w' assume
    H : "S w" and
    IH : "\<And>v w' . w = v @ w' \<Longrightarrow> S ( v @ a # b # w' )" and
    EH : "a # w @ [b] = v @ w'"
    show "S ( v @ a # b # w' )"
  proof ( cases "v = []" )
    assume "v = []" show "S ( v @ a # b # w' )"
    proof -
      have "w' = a # w @ [b]" using `v = []` EH by simp
      moreover hence "S ( w' )" using H by ( metis middl )
      moreover hence "S ( v @ a # [ b ] )" using `v = []` by ( metis append_Nil emptyS middl )
      ultimately have "S ( ( v @ a # [ b ] ) @ w' )" by ( metis doubl )
      thus "S ( v @ a # b # w' )" by simp
    qed

    next
    assume "v \<noteq> []" show "S ( v @ a # b # w' )"
    proof ( cases "w' = []" )
      assume "w' = []" show "S ( v @ a # b # w' )"
      proof -
        have "v = a # w @ [b]" using `w' = []` EH by simp
        moreover hence "S ( v )" using H by ( metis middl )
        moreover hence "S ( v @ a # [ b ] )" by ( metis emptyS middl doubl append_Nil )
        ultimately have "S ( v @ a # [ b ] @ w' )" using `w' = []` by simp
        thus "S ( v @ a # b # w' )" by simp
      qed

      next
      assume "w' \<noteq> []" show "S ( v @ a # b # w' )"
      proof -
        have "v @ w' = ( hd v ) # ( tl v ) @ w'" using `v \<noteq> []` by simp
        hence V: "w @ [ b ] = tl v @ w' \<and> hd v = a" using `v \<noteq> []` EH by ( metis list.inject )
        hence "w @ [ b ] = ( tl v @ butlast w' ) @ [ last w' ]" using `w' \<noteq> []` by simp
        hence W': "w = tl v @ butlast w' \<and> last w' = b" by ( metis append1_eq_conv )
        hence "S ( tl v @ butlast w' )" using H by metis
        hence "S ( tl v @ a # b # butlast w' )" using IH W' by metis
        hence "S ( a # (tl v @ a # b # butlast w' ) @ [ b ] )" by ( metis middl )
        hence "S ( ( a # tl v ) @ [a,b] @ ( butlast w' @ [ b ] ) )" by simp
        moreover have "a # tl v = v" using V list.collapse `v \<noteq> []` by force
        moreover have "butlast w' @ [ b ] = w'" using W' append_butlast_last_id `w' \<noteq> []` by force
        ultimately show "S (  v @ a # b # w' )" by simp
      qed
    qed
  qed

  next
  fix w v p s assume
    W : "S w"
    "\<And>p s. w = p @ s \<Longrightarrow> S ( p @ a # b # s )" and
    V : "S v"
    "\<And>p s. v = p @ s \<Longrightarrow> S ( p @ a # b # s )" and
    EH : "w @ v = p @ s"
    show "S ( p @ a # b # s )"
  proof ( cases "length p = length w" )
    assume LH : "length p = length w" show "S ( p @ a # b # s )"
    proof -
      have "S ( a # [ b ] )" by ( metis emptyS middl append_Nil)
      moreover have "w = p \<and> v = s" using EH LH by simp
      ultimately have "S ( p @ [ a , b ] @ s )" using W V by ( metis doubl )
      thus ?thesis by simp
    qed

    next
    assume LD : "length p \<noteq> length w" show "S ( p @ a # b # s )"
    proof ( cases "length p < length w" )
      assume LPLTLW : "length p < length w" show "S ( p @ a # b # s )"
      proof -
        have "w = take ( length p ) w @ drop ( length p ) w" using LPLTLW by simp
        moreover have PS : "p = take ( length p ) w \<and>
                              s = drop ( length p ) w @ v"
                                using EH LPLTLW by (metis append_eq_append_conv_if leD)
        ultimately have "w = p @ drop ( length p ) w" by simp
        hence "S ( p @ a # b # drop ( length p ) w )" using W  by metis
        hence "S ( ( p @ a # b # drop ( length p ) w ) @ v )" using V by ( metis doubl )
        thus "S ( p @ a # b # s )" using PS by simp
      qed

      next
      assume LNL : "\<not> length p < length w" show "S ( p @ a # b # s )"
      proof -
        have "length p > length w" using LD LNL by ( metis linorder_class.less_linear )
        moreover hence "length w = length ( take ( length w ) p )" by simp
        moreover have "w @ v = take ( length w ) p @ drop ( length w ) p @ s" using EH by simp
        ultimately have
          "w = take ( length w ) p \<and>
            v = drop ( length w ) p @ s" by ( metis append_eq_append_conv )
        moreover hence "S ( drop ( length w ) p @ a # b # s )" using V by metis
        ultimately have "S ( take ( length w ) p @ drop ( length w ) p @ a # b # s )"
          using W by ( metis doubl )
        thus ?thesis by ( metis append_take_drop_id  append_assoc )
      qed
    qed
  qed
qed

fun balanced :: "nat \<Rightarrow> alpha list \<Rightarrow> bool" where
  "balanced 0 [] = True" |
  "balanced _ [] = False" |
  "balanced 0 ( b # _ ) = False" |
  "balanced n ( a # w ) = balanced ( Suc n ) w" |
  "balanced ( Suc n ) ( b # w ) = balanced n w"

value "balanced 1 [b]"

lemma "balanced n w \<Longrightarrow> S ( replicate n a @ w )"
  proof ( induction n w rule: balanced.induct )
  assume "balanced 0 []" thus "S ( replicate 0 a @ [] )" using emptyS replicate_0 by auto

  next
  fix v assume
    H : "balanced ( Suc v ) []"
    show "S ( replicate ( Suc v ) a @ [] )"
  proof -
    have False using H by simp
    thus ?thesis by metis
  qed

  next
  fix as assume
    H : "balanced 0 ( b # as )"
    show "S ( replicate 0 a @ b # as )"
  proof -
    have False using H by simp
    thus ?thesis by metis
  qed

  next
  fix n w assume
    IH : "balanced ( Suc n ) w \<Longrightarrow> S ( replicate ( Suc n ) a @ w )" and
    H  : "balanced n ( a # w )"
    show "S ( replicate n a @ a # w )"
  proof -
    have "balanced ( Suc n ) w" using H by simp
    hence "S ( replicate ( Suc n ) a @ w )" using IH by metis
    hence "S ( a # replicate n a @ w )" by simp
    thus ?thesis using replicate_app_Cons_same by metis
  qed

  next
  fix n w assume
    IH : "balanced n w \<Longrightarrow> S ( replicate n a @ w )" and
    H  : "balanced ( Suc n ) ( b # w )"
    show "S ( replicate ( Suc n ) a @ b # w )"
  proof -
    have "balanced n w" using H by simp
    hence "S ( replicate n a @ w )" using IH by metis
    hence "S ( replicate n a @ a # b # w )" using ab_inter by metis
    hence "S ( ( replicate n a @ [ a ] ) @ b # w )" by simp
    hence "S ( ( a # replicate n a ) @ b # w )" by ( metis replicate_append_same )
    thus ?thesis by simp
  qed
qed

end


theory AExp imports Main begin

subsection "Arithmetic Expressions"

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

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp = N int | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
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"
text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw{*}%endsnip*}

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
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"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
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)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end


(* License: LGPL *)
(*
Author: Julian Parsert <julian.parsert@gmail.com>
Author: Cezary Kaliszyk
*)

section \<open> Utility Functions \<close>

text \<open> Utility functions and results involving them. \<close>

theory Utility_Functions
  imports
    Preferences
begin

subsection "Ordinal utility functions"

text \<open> Ordinal utility function locale \<close>

locale ordinal_utility =
  fixes carrier :: "'a set"
  fixes relation :: "'a relation"
  fixes u :: "'a \<Rightarrow> real"
  assumes util_def[iff]: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> x \<succeq>[relation] y \<longleftrightarrow> u x \<ge> u y"
  assumes not_outside: "x \<succeq>[relation] y \<Longrightarrow> x \<in> carrier"
    and "x \<succeq>[relation] y \<Longrightarrow> y \<in> carrier"
begin

lemma util_def_conf: "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> u x \<ge> u y \<longleftrightarrow> x \<succeq>[relation] y"
  using util_def by blast

lemma relation_subset_crossp:
  "relation \<subseteq> carrier \<times> carrier"
proof
  fix x
  assume "x \<in> relation"
  have "\<forall>(a,b) \<in> relation. a \<in> carrier \<and> b \<in> carrier"
    by (metis (no_types, lifting) case_prod_conv ordinal_utility_axioms ordinal_utility_def surj_pair)
  then show "x \<in> carrier \<times> carrier"
    using \<open>x \<in> relation\<close> by auto
qed

text \<open> Utility function implies totality of relation \<close>
lemma util_imp_total: "total_on carrier relation"
proof
  fix x and y
  assume x_inc: "x \<in> carrier" and y_inc : "y \<in> carrier"
  have fst : "u x \<ge> u y \<or> u y \<ge> u x"
    using util_def by auto
  then show  "x \<succeq>[relation] y \<or> y \<succeq>[relation] x"
    by (simp add: x_inc y_inc)
qed

lemma x_y_in_carrier: "x \<succeq>[relation] y \<Longrightarrow> x \<in> carrier \<and> y \<in> carrier"
  by (meson ordinal_utility_axioms ordinal_utility_def)

text \<open> Utility function implies transitivity of relation. \<close>

lemma util_imp_trans: "trans relation"
proof (rule transI)
  fix x and y and z
  assume x_y: "x \<succeq>[relation] y"
  assume y_z: "y \<succeq>[relation] z"
  have x_ge_y: "x \<succeq>[relation] y"
    using x_y by auto
  then have x_y: "u x \<ge> u y"
    by (meson x_y_in_carrier ordinal_utility_axioms util_def x_y)
  have "u y \<ge> u z"
    by (meson y_z ordinal_utility_axioms ordinal_utility_def)
  have "x \<in> carrier"
    using x_y_in_carrier[of x y] x_ge_y  by simp
  then have "u x \<ge> u z"
    using \<open>u z \<le> u y\<close> order_trans x_y by blast
  hence "x \<succeq>[relation] z"
    by (meson \<open>x \<in> carrier\<close> ordinal_utility_axioms ordinal_utility_def y_z)
  then show "x \<succeq>[relation] z" .
qed

lemma util_imp_refl: "refl_on carrier relation"
  by (simp add: refl_on_def relation_subset_crossp)

lemma affine_trans_is_u:
  shows "\<forall>\<alpha>>0. (\<forall>\<beta>. ordinal_utility  carrier relation (\<lambda>x. u(x)*\<alpha> + \<beta>))"
proof (rule allI, rule impI, rule allI)
  fix \<alpha>::real and \<beta>
  assume *:"\<alpha> > 0"
  show "ordinal_utility carrier relation (\<lambda>x. u x * \<alpha> + \<beta>)"
  proof (subst ordinal_utility_def, rule conjI, goal_cases)
    case 1
    then show ?case
      by (metis * add.commute add_le_cancel_left not_le real_mult_less_iff1 util_def_conf)
  next
    case 2
    then show ?case
      by (meson refl_on_domain util_imp_refl)
  qed
qed

text \<open> This utility function definition is ordinal.
        Hence they are only unique up to a monotone transformation. \<close>

lemma ordinality_of_utility_function :
  fixes f :: "real \<Rightarrow> real"
  assumes monot: "monotone (>) (>) f"
  shows "(f \<circ> u) x > (f \<circ> u) y \<longleftrightarrow> u x > u y"
proof -
  let ?func = "(\<lambda>x. f(u x))"
  have "\<forall>m n . u m \<ge> u n \<longleftrightarrow> ?func m \<ge> ?func n"
    by (metis le_less monot monotone_def not_less)
  hence "u x > u y \<longleftrightarrow> ?func x > ?func y"
    using not_le by blast
  thus ?thesis  by auto
qed

corollary utility_prefs_corresp :
  fixes f :: "real \<Rightarrow> real"
  assumes monotonicity : "monotone (>) (>) f"
  shows "\<forall>x\<in>carrier. \<forall>y\<in>carrier. (x,y) \<in> relation \<longleftrightarrow> (f \<circ> u) x \<ge> (f \<circ> u) y"
  by (meson monotonicity not_less ordinality_of_utility_function util_def_conf)

corollary monotone_comp_is_utility:
  fixes f :: "real \<Rightarrow> real"
  assumes monot: "monotone (>) (>) f"
  shows "ordinal_utility carrier relation (f \<circ> u)"
proof (rule ordinal_utility.intro, goal_cases)
case (1 x y)
  then show ?case
    using monot utility_prefs_corresp by blast
next
  case (2 x y)
  then show ?case
    using not_outside by blast
next
  case (3 x y)
  then show ?case
    using x_y_in_carrier by blast
qed

lemma ordinal_utility_left:
  assumes "x \<succeq>[relation] y"
  shows "u x \<ge> u y"
  using assms x_y_in_carrier by blast

lemma add_right:
  assumes "\<And>x y. x \<succeq>[relation] y \<Longrightarrow> f x \<ge> f y"
  shows   "ordinal_utility carrier relation (\<lambda>x. u x + f x)"
proof (rule ordinal_utility.intro, goal_cases)
  case (1 x y)
  assume xy: "x \<in> carrier" "y \<in> carrier"
  then show ?case
  proof -
    have "u x \<le> u y \<longrightarrow> (\<exists>r. ((x, y) \<notin> relation \<and> \<not> r \<le> u x + f x) \<and> r \<le> u y + f y) \<or> u y \<le> u x"
      by (metis (no_types) add_le_cancel_left add_le_cancel_right assms util_def xy(1) xy(2))
    moreover show ?thesis
      by (meson add_mono assms calculation le_cases order_trans util_def xy(1) xy(2))
  qed
next
  case (2 x y)
  then show ?case
    using not_outside by blast
next
  case (3 x y)
  then show ?case
    using x_y_in_carrier by blast
qed

lemma add_left:
  assumes "\<And>x y. x \<succeq>[relation] y \<Longrightarrow> f x \<ge> f y"
  shows "ordinal_utility carrier relation (\<lambda>x. f x + u x)"
proof -
  have "ordinal_utility carrier relation (\<lambda>x. u x + f x)"
    by (simp add: add_right assms)
  thus ?thesis using Groups.ab_semigroup_add_class.add.commute
    by (simp add: add.commute)
qed

lemma ordinal_utility_scale_transl:
  assumes "(c::real) > 0"
  shows "ordinal_utility carrier relation (\<lambda>x. c * (u x) + d)"
proof -
  have "monotone (>) (>) (\<lambda>x. c * x + d)" (is "monotone (>) (>) ?fn" )
    by (simp add: assms monotone_def)
  with monotone_comp_is_utility have "ordinal_utility carrier relation (?fn \<circ> u)"
    by blast
  moreover have "?fn \<circ> u =  (\<lambda>x. c * (u x) + d)"
    by auto
  finally show ?thesis
    by auto
qed

lemma strict_prefernce_iff_strict_utility:
  assumes "x \<in> carrier"
  assumes "y \<in> carrier"
  shows "x \<succ>[relation] y \<longleftrightarrow> u x > u y"
  by (meson assms(1) assms(2) less_eq_real_def not_less util_def)

end

text \<open> A utility function implies a rational preference relation.
      Hence a utility function contains exactly the same amount of information as a RPR \<close>

sublocale ordinal_utility \<subseteq> rational_preference carrier relation
proof
  fix x and y
  assume xy: "x \<succeq>[relation] y"
  then show "x \<in> carrier"
    and "y \<in> carrier"
    using not_outside by (simp)
      (meson xy refl_onD2 util_imp_refl)
next
  show "preorder_on carrier relation"
  proof-
    have "trans relation" using util_imp_trans by auto
    then have "preorder_on carrier relation"
      by (simp add: preorder_on_def util_imp_refl)
    then show ?thesis .
  qed
next
  show "total_on carrier relation"
    by (simp add: util_imp_total)
qed

text \<open> Given a finite carrier set. We can guarantee that given a rational preference
       relation, there must also exist a utility function representing this relation.
       Construction of witness roughly follows from.\<close>

theorem fnt_carrier_exists_util_fun:
  assumes "finite carrier"
  assumes "rational_preference carrier relation"
  shows "\<exists>u. ordinal_utility carrier relation u"
proof-
  define f where
    f: "f = (\<lambda>x. card (no_better_than x carrier relation))"
  have "ordinal_utility carrier relation f"
  proof
    fix x y
    assume x_c: "x \<in> carrier"
    assume y_c: "y \<in> carrier"
    show "x \<succeq>[relation] y \<longleftrightarrow> (real (f y) \<le> real (f x))"
    proof
      assume asm: "x \<succeq>[relation] y"
      define yn where
        yn: "yn = no_better_than y carrier relation"
      define xn where
        xn: "xn = no_better_than x carrier relation"
      then have "yn \<subseteq> xn"
        by (simp add: asm yn assms(2) rational_preference.no_better_subset_pref)
      then have "card yn \<le> card xn"
        by (simp add: x_c y_c asm assms(1) assms(2) rational_preference.card_leq_pref xn yn)
      then show "(real (f y) \<le> real (f x))"
        using  f xn yn by simp
    next
      assume "real (f y) \<le> real (f x)"
      then show "x \<succeq>[relation] y"
        using assms(1) assms(2) f rational_preference.card_leq_pref x_c y_c by fastforce
    qed
  next
    fix x y
    assume asm: "x \<succeq>[relation] y"
    show "x \<in> carrier"
      by (meson asm assms(2) preference.not_outside rational_preference.axioms(1))
    show "y \<in> carrier"
      by (meson asm assms(2) preference_def rational_preference_def)
  qed
  then show ?thesis
    by blast
qed

corollary obt_u_fnt_carrier:
  assumes "finite carrier"
  assumes "rational_preference carrier relation"
  obtains u where "ordinal_utility carrier relation u"
  using assms(1) assms(2) fnt_carrier_exists_util_fun by blast

theorem ordinal_util_imp_rat_prefs:
  assumes "ordinal_utility carrier relation u"
  shows "rational_preference carrier relation"
  by (metis (full_types) assms order_on_defs(1) ordinal_utility.util_imp_refl
      ordinal_utility.util_imp_total ordinal_utility.util_imp_trans ordinal_utility_def
      preference.intro rational_preference.intro rational_preference_axioms_def)

subsection \<open> Utility function on  Euclidean Space \<close>

locale eucl_ordinal_utility = ordinal_utility carrier relation u
  for carrier :: "('a::euclidean_space) set"
  and relation :: "'a relation"
  and u :: "'a \<Rightarrow> real"

sublocale eucl_ordinal_utility \<subseteq> rational_preference carrier relation
  using rational_preference_axioms by blast

lemma ord_eucl_utility_imp_rpr: "eucl_ordinal_utility s rel u \<longrightarrow> real_vector_rpr s rel"
  using eucl_ordinal_utility.axioms ordinal_util_imp_rat_prefs real_vector_rpr.intro by blast

context eucl_ordinal_utility
begin

text \<open> Local non-satiation on utility functions \<close>

lemma lns_pref_lns_util [iff]:
  "local_nonsatiation carrier relation \<longleftrightarrow>
  (\<forall>x\<in>carrier. \<forall>e > 0. \<exists>y\<in>carrier.
  norm (y - x) \<le> e \<and> u y > u x)" (is "_ \<longleftrightarrow> ?alt")
proof
  assume lns: "local_nonsatiation carrier relation"
  have "\<forall>a b. a \<succ> b \<longrightarrow> u a > u b"
    by (metis less_eq_real_def util_def x_y_in_carrier)
  then show "?alt"
    by (meson lns local_nonsatiation_def)
next
  assume lns: "?alt"
  show "local_nonsatiation carrier relation"
  proof(rule lns_normI)
    fix x and e::real
    assume x_in: "x \<in> carrier"
    assume e: "e > 0"
    have "\<forall>x \<in> carrier. \<forall>e>0. \<exists>y\<in>carrier. norm (y - x) \<le> e \<and> y \<succ> x"
      by (meson less_eq_real_def linorder_not_less lns util_def)
    have "\<exists>y\<in>carrier. norm (y - x) \<le> e \<and> u y > u x"
      using e x_in lns by blast
    then show "\<exists>y\<in>carrier. norm (y - x) \<le> e \<and> y \<succ> x"
      by (meson compl not_less util_def x_in)
  qed
qed

end

lemma finite_carrier_rpr_iff_u:
  assumes "finite carrier"
    and "(relation::'a relation) \<subseteq> carrier \<times> carrier"
  shows "rational_preference carrier relation \<longleftrightarrow> (\<exists>u. ordinal_utility carrier relation u)"
proof
  assume "rational_preference carrier relation"
  then show "\<exists>u. ordinal_utility carrier relation u"
    by (simp add: assms(1) fnt_carrier_exists_util_fun)
next
  assume "\<exists>u. ordinal_utility carrier relation u"
  then show "rational_preference carrier relation"
    by (metis (full_types) order_on_defs(1) ordinal_utility.util_imp_refl
        ordinal_utility.util_imp_total ordinal_utility.util_imp_trans ordinal_utility_def
        preference.intro rational_preference_axioms_def rational_preference_def)
qed

end