(*  Author:     Steven Obua, TU Muenchen *)

section \<open>Various algebraic structures combined with a lattice\<close>

theory Lattice_Algebras
  imports Complex_Main
begin

class semilattice_inf_ab_group_add = ordered_ab_group_add + semilattice_inf
begin

lemma add_inf_distrib_left: "a + inf b c = inf (a + b) (a + c)"
  apply (rule antisym)
   apply (simp_all add: le_infI)
  apply (rule add_le_imp_le_left [of "uminus a"])
  apply (simp only: add.assoc [symmetric], simp add: diff_le_eq add.commute)
  done

lemma add_inf_distrib_right: "inf a b + c = inf (a + c) (b + c)"
proof -
  have "c + inf a b = inf (c + a) (c + b)"
    by (simp add: add_inf_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class semilattice_sup_ab_group_add = ordered_ab_group_add + semilattice_sup
begin

lemma add_sup_distrib_left: "a + sup b c = sup (a + b) (a + c)"
  apply (rule antisym)
   apply (rule add_le_imp_le_left [of "uminus a"])
   apply (simp only: add.assoc [symmetric], simp)
   apply (simp add: le_diff_eq add.commute)
  apply (rule le_supI)
   apply (rule add_le_imp_le_left [of "a"], simp only: add.assoc[symmetric], simp)+
  done

lemma add_sup_distrib_right: "sup a b + c = sup (a + c) (b + c)"
proof -
  have "c + sup a b = sup (c+a) (c+b)"
    by (simp add: add_sup_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class lattice_ab_group_add = ordered_ab_group_add + lattice
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

lemma inf_eq_neg_sup: "inf a b = - sup (- a) (- b)"
proof (rule inf_unique)
  fix a b c :: 'a
  show "- sup (- a) (- b) \<le> a"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  show "- sup (-a) (-b) \<le> b"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  assume "a \<le> b" "a \<le> c"
  then show "a \<le> - sup (-b) (-c)"
    by (subst neg_le_iff_le [symmetric]) (simp add: le_supI)
qed

lemma sup_eq_neg_inf: "sup a b = - inf (- a) (- b)"
proof (rule sup_unique)
  fix a b c :: 'a
  show "a \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "b \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "- inf (- a) (- b) \<le> c" if "a \<le> c" "b \<le> c"
    using that by (subst neg_le_iff_le [symmetric]) (simp add: le_infI)
qed

lemma neg_inf_eq_sup: "- inf a b = sup (- a) (- b)"
  by (simp add: inf_eq_neg_sup)

lemma diff_inf_eq_sup: "a - inf b c = a + sup (- b) (- c)"
  using neg_inf_eq_sup [of b c, symmetric] by simp

lemma neg_sup_eq_inf: "- sup a b = inf (- a) (- b)"
  by (simp add: sup_eq_neg_inf)

lemma diff_sup_eq_inf: "a - sup b c = a + inf (- b) (- c)"
  using neg_sup_eq_inf [of b c, symmetric] by simp

lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
proof -
  have "0 = - inf 0 (a - b) + inf (a - b) 0"
    by (simp add: inf_commute)
  then have "0 = sup 0 (b - a) + inf (a - b) 0"
    by (simp add: inf_eq_neg_sup)
  then have "0 = (- a + sup a b) + (inf a b + (- b))"
    by (simp only: add_sup_distrib_left add_inf_distrib_right) simp
  then show ?thesis
    by (simp add: algebra_simps)
qed

subsection \<open>Positive Part, Negative Part, Absolute Value\<close>

definition nprt :: "'a \<Rightarrow> 'a"
  where "nprt x = inf x 0"

definition pprt :: "'a \<Rightarrow> 'a"
  where "pprt x = sup x 0"

lemma pprt_neg: "pprt (- x) = - nprt x"
proof -
  have "sup (- x) 0 = sup (- x) (- 0)"
    by (simp only: minus_zero)
  also have "\<dots> = - inf x 0"
    by (simp only: neg_inf_eq_sup)
  finally have "sup (- x) 0 = - inf x 0" .
  then show ?thesis
    by (simp only: pprt_def nprt_def)
qed

lemma nprt_neg: "nprt (- x) = - pprt x"
proof -
  from pprt_neg have "pprt (- (- x)) = - nprt (- x)" .
  then have "pprt x = - nprt (- x)" by simp
  then show ?thesis by simp
qed

lemma prts: "a = pprt a + nprt a"
  by (simp add: pprt_def nprt_def flip: add_eq_inf_sup)

lemma zero_le_pprt[simp]: "0 \<le> pprt a"
  by (simp add: pprt_def)

lemma nprt_le_zero[simp]: "nprt a \<le> 0"
  by (simp add: nprt_def)

lemma le_eq_neg: "a \<le> - b \<longleftrightarrow> a + b \<le> 0"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  show ?rhs
    by (rule add_le_imp_le_right[of _ "uminus b" _]) (simp add: add.assoc \<open>?lhs\<close>)
next
  assume ?rhs
  show ?lhs
    by (rule add_le_imp_le_right[of _ "b" _]) (simp add: \<open>?rhs\<close>)
qed

lemma pprt_0[simp]: "pprt 0 = 0" by (simp add: pprt_def)
lemma nprt_0[simp]: "nprt 0 = 0" by (simp add: nprt_def)

lemma pprt_eq_id [simp, no_atp]: "0 \<le> x \<Longrightarrow> pprt x = x"
  by (simp add: pprt_def sup_absorb1)

lemma nprt_eq_id [simp, no_atp]: "x \<le> 0 \<Longrightarrow> nprt x = x"
  by (simp add: nprt_def inf_absorb1)

lemma pprt_eq_0 [simp, no_atp]: "x \<le> 0 \<Longrightarrow> pprt x = 0"
  by (simp add: pprt_def sup_absorb2)

lemma nprt_eq_0 [simp, no_atp]: "0 \<le> x \<Longrightarrow> nprt x = 0"
  by (simp add: nprt_def inf_absorb2)

lemma sup_0_imp_0:
  assumes "sup a (- a) = 0"
  shows "a = 0"
proof -
  have pos: "0 \<le> a" if "sup a (- a) = 0" for a :: 'a
  proof -
    from that have "sup a (- a) + a = a"
      by simp
    then have "sup (a + a) 0 = a"
      by (simp add: add_sup_distrib_right)
    then have "sup (a + a) 0 \<le> a"
      by simp
    then show ?thesis
      by (blast intro: order_trans inf_sup_ord)
  qed
  from assms have **: "sup (-a) (-(-a)) = 0"
    by (simp add: sup_commute)
  from pos[OF assms] pos[OF **] show "a = 0"
    by simp
qed

lemma inf_0_imp_0: "inf a (- a) = 0 \<Longrightarrow> a = 0"
  apply (simp add: inf_eq_neg_sup)
  apply (simp add: sup_commute)
  apply (erule sup_0_imp_0)
  done

lemma inf_0_eq_0 [simp, no_atp]: "inf a (- a) = 0 \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (erule inf_0_imp_0)
  apply simp
  done

lemma sup_0_eq_0 [simp, no_atp]: "sup a (- a) = 0 \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (erule sup_0_imp_0)
  apply simp
  done

lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that have a: "inf (a + a) 0 = 0"
      by (simp add: inf_commute inf_absorb1)
    have "inf a 0 + inf a 0 = inf (inf (a + a) 0) a"  (is "?l = _")
      by (simp add: add_sup_inf_distribs inf_aci)
    then have "?l = 0 + inf a 0"
      by (simp add: a, simp add: inf_commute)
    then have "inf a 0 = 0"
      by (simp only: add_right_cancel)
    then show ?thesis
      unfolding le_iff_inf by (simp add: inf_commute)
  qed
  show ?lhs if ?rhs
    by (simp add: add_mono[OF that that, simplified])
qed

lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
  using add_nonneg_eq_0_iff eq_iff by auto

lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
  by (meson le_less_trans less_add_same_cancel2 less_le_not_le
      zero_le_double_add_iff_zero_le_single_add)

lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
proof -
  have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)"
    by (subst le_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a \<le> 0"
    by (simp only: minus_add_distrib zero_le_double_add_iff_zero_le_single_add) simp
  ultimately show ?thesis
    by blast
qed

lemma double_add_less_zero_iff_single_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
proof -
  have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)"
    by (subst less_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a < 0"
    by (simp only: minus_add_distrib zero_less_double_add_iff_zero_less_single_add) simp
  ultimately show ?thesis
    by blast
qed

declare neg_inf_eq_sup [simp]
  and neg_sup_eq_inf [simp]
  and diff_inf_eq_sup [simp]
  and diff_sup_eq_inf [simp]

lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
proof -
  from add_le_cancel_left [of "uminus a" "plus a a" zero]
  have "a \<le> - a \<longleftrightarrow> a + a \<le> 0"
    by (simp flip: add.assoc)
  then show ?thesis
    by simp
qed

lemma minus_le_self_iff: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
proof -
  have "- a \<le> a \<longleftrightarrow> 0 \<le> a + a"
    using add_le_cancel_left [of "uminus a" zero "plus a a"]
    by (simp flip: add.assoc)
  then show ?thesis
    by simp
qed

lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma pprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> pprt a \<le> pprt b"
  unfolding le_iff_sup by (simp add: pprt_def sup_aci sup_assoc [symmetric, of a])

lemma nprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> nprt a \<le> nprt b"
  unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])

end

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

class lattice_ab_group_add_abs = lattice_ab_group_add + abs +
  assumes abs_lattice: "\<bar>a\<bar> = sup a (- a)"
begin

lemma abs_prts: "\<bar>a\<bar> = pprt a - nprt a"
proof -
  have "0 \<le> \<bar>a\<bar>"
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show ?thesis
      by (rule add_mono [OF a b, simplified])
  qed
  then have "0 \<le> sup a (- a)"
    unfolding abs_lattice .
  then have "sup (sup a (- a)) 0 = sup a (- a)"
    by (rule sup_absorb1)
  then show ?thesis
    by (simp add: add_sup_inf_distribs ac_simps pprt_def nprt_def abs_lattice)
qed

subclass ordered_ab_group_add_abs
proof
  have abs_ge_zero [simp]: "0 \<le> \<bar>a\<bar>" for a
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show "0 \<le> \<bar>a\<bar>"
      by (rule add_mono [OF a b, simplified])
  qed
  have abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" for a b
    by (simp add: abs_lattice le_supI)
  fix a b
  show "0 \<le> \<bar>a\<bar>"
    by simp
  show "a \<le> \<bar>a\<bar>"
    by (auto simp add: abs_lattice)
  show "\<bar>-a\<bar> = \<bar>a\<bar>"
    by (simp add: abs_lattice sup_commute)
  show "- a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" if "a \<le> b"
    using that by (rule abs_leI)
  show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
  proof -
    have g: "\<bar>a\<bar> + \<bar>b\<bar> = sup (a + b) (sup (- a - b) (sup (- a + b) (a + (- b))))"
      (is "_ = sup ?m ?n")
      by (simp add: abs_lattice add_sup_inf_distribs ac_simps)
    have a: "a + b \<le> sup ?m ?n"
      by simp
    have b: "- a - b \<le> ?n"
      by simp
    have c: "?n \<le> sup ?m ?n"
      by simp
    from b c have d: "- a - b \<le> sup ?m ?n"
      by (rule order_trans)
    have e: "- a - b = - (a + b)"
      by simp
    from a d e have "\<bar>a + b\<bar> \<le> sup ?m ?n"
      apply -
      apply (drule abs_leI)
       apply (simp_all only: algebra_simps minus_add)
      apply (metis add_uminus_conv_diff d sup_commute uminus_add_conv_diff)
      done
    with g[symmetric] show ?thesis by simp
  qed
qed

end

lemma sup_eq_if:
  fixes a :: "'a::{lattice_ab_group_add,linorder}"
  shows "sup a (- a) = (if a < 0 then - a else a)"
  using add_le_cancel_right [of a a "- a", symmetric, simplified]
    and add_le_cancel_right [of "-a" a a, symmetric, simplified]
  by (auto simp: sup_max max.absorb1 max.absorb2)

lemma abs_if_lattice:
  fixes a :: "'a::{lattice_ab_group_add_abs,linorder}"
  shows "\<bar>a\<bar> = (if a < 0 then - a else a)"
  by auto

lemma estimate_by_abs:
  fixes a b c :: "'a::lattice_ab_group_add_abs"
  assumes "a + b \<le> c"
  shows "a \<le> c + \<bar>b\<bar>"
proof -
  from assms have "a \<le> c + (- b)"
    by (simp add: algebra_simps)
  have "- b \<le> \<bar>b\<bar>"
    by (rule abs_ge_minus_self)
  then have "c + (- b) \<le> c + \<bar>b\<bar>"
    by (rule add_left_mono)
  with \<open>a \<le> c + (- b)\<close> show ?thesis
    by (rule order_trans)
qed

class lattice_ring = ordered_ring + lattice_ab_group_add_abs
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

end

lemma abs_le_mult:
  fixes a b :: "'a::lattice_ring"
  shows "\<bar>a * b\<bar> \<le> \<bar>a\<bar> * \<bar>b\<bar>"
proof -
  let ?x = "pprt a * pprt b - pprt a * nprt b - nprt a * pprt b + nprt a * nprt b"
  let ?y = "pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
  have a: "\<bar>a\<bar> * \<bar>b\<bar> = ?x"
    by (simp only: abs_prts[of a] abs_prts[of b] algebra_simps)
  have bh: "u = a \<Longrightarrow> v = b \<Longrightarrow>
            u * v = pprt a * pprt b + pprt a * nprt b +
                    nprt a * pprt b + nprt a * nprt b" for u v :: 'a
    apply (subst prts[of u], subst prts[of v])
    apply (simp add: algebra_simps)
    done
  note b = this[OF refl[of a] refl[of b]]
  have xy: "- ?x \<le> ?y"
    apply simp
    apply (metis (full_types) add_increasing add_uminus_conv_diff
      lattice_ab_group_add_class.minus_le_self_iff minus_add_distrib mult_nonneg_nonneg
      mult_nonpos_nonpos nprt_le_zero zero_le_pprt)
    done
  have yx: "?y \<le> ?x"
    apply simp
    apply (metis (full_types) add_nonpos_nonpos add_uminus_conv_diff
      lattice_ab_group_add_class.le_minus_self_iff minus_add_distrib mult_nonneg_nonpos
      mult_nonpos_nonneg nprt_le_zero zero_le_pprt)
    done
  have i1: "a * b \<le> \<bar>a\<bar> * \<bar>b\<bar>"
    by (simp only: a b yx)
  have i2: "- (\<bar>a\<bar> * \<bar>b\<bar>) \<le> a * b"
    by (simp only: a b xy)
  show ?thesis
    apply (rule abs_leI)
    apply (simp add: i1)
    apply (simp add: i2[simplified minus_le_iff])
    done
qed

instance lattice_ring \<subseteq> ordered_ring_abs
proof
  fix a b :: "'a::lattice_ring"
  assume a: "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0)"
  show "\<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
  proof -
    have s: "(0 \<le> a * b) \<or> (a * b \<le> 0)"
      apply auto
      apply (rule_tac split_mult_pos_le)
      apply (rule_tac contrapos_np[of "a * b \<le> 0"])
      apply simp
      apply (rule_tac split_mult_neg_le)
      using a
      apply blast
      done
    have mulprts: "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
      by (simp flip: prts)
    show ?thesis
    proof (cases "0 \<le> a * b")
      case True
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        using a
        apply (auto simp add:
          algebra_simps
          iffD1[OF zero_le_iff_zero_nprt] iffD1[OF le_zero_iff_zero_pprt]
          iffD1[OF le_zero_iff_pprt_id] iffD1[OF zero_le_iff_nprt_id])
        apply(drule (1) mult_nonneg_nonpos[of a b], simp)
        apply(drule (1) mult_nonneg_nonpos2[of b a], simp)
        done
    next
      case False
      with s have "a * b \<le> 0"
        by simp
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        apply (insert a)
        apply (auto simp add: algebra_simps)
        apply(drule (1) mult_nonneg_nonneg[of a b],simp)
        apply(drule (1) mult_nonpos_nonpos[of a b],simp)
        done
    qed
  qed
qed

lemma mult_le_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<le>
    pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
proof -
  have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
    by (subst prts[symmetric])+ simp
  then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
    by (simp add: algebra_simps)
  moreover have "pprt a * pprt b \<le> pprt a2 * pprt b2"
    by (simp_all add: assms mult_mono)
  moreover have "pprt a * nprt b \<le> pprt a1 * nprt b2"
  proof -
    have "pprt a * nprt b \<le> pprt a * nprt b2"
      by (simp add: mult_left_mono assms)
    moreover have "pprt a * nprt b2 \<le> pprt a1 * nprt b2"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * pprt b \<le> nprt a2 * pprt b1"
  proof -
    have "nprt a * pprt b \<le> nprt a2 * pprt b"
      by (simp add: mult_right_mono assms)
    moreover have "nprt a2 * pprt b \<le> nprt a2 * pprt b1"
      by (simp add: mult_left_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * nprt b \<le> nprt a1 * nprt b1"
  proof -
    have "nprt a * nprt b \<le> nprt a * nprt b1"
      by (simp add: mult_left_mono_neg assms)
    moreover have "nprt a * nprt b1 \<le> nprt a1 * nprt b1"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by - (rule add_mono | simp)+
qed

lemma mult_ge_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<ge>
    nprt a1 * pprt b2 + nprt a2 * nprt b2 + pprt a1 * pprt b1 + pprt a2 * nprt b1"
proof -
  from assms have a1: "- a2 \<le> -a"
    by auto
  from assms have a2: "- a \<le> -a1"
    by auto
  from mult_le_prts[of "- a2" "- a" "- a1" "b1" b "b2",
    OF a1 a2 assms(3) assms(4), simplified nprt_neg pprt_neg]
  have le: "- (a * b) \<le>
    - nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
    - pprt a1 * pprt b1 + - pprt a2 * nprt b1"
    by simp
  then have "- (- nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
      - pprt a1 * pprt b1 + - pprt a2 * nprt b1) \<le> a * b"
    by (simp only: minus_le_iff)
  then show ?thesis
    by (simp add: algebra_simps)
qed

instance int :: lattice_ring
proof
  show "\<bar>k\<bar> = sup k (- k)" for k :: int
    by (auto simp add: sup_int_def)
qed

instance real :: lattice_ring
proof
  show "\<bar>a\<bar> = sup a (- a)" for a :: real
    by (auto simp add: sup_real_def)
qed

end


(*<*)
theory tut07
  imports Main "HOL-Data_Structures.Sorting"
begin
(*>*)

hide_const (open) inv

text {* \ExerciseSheet{7}{25.~5.~2018} *}

text {* \Exercise{Interval Lists}

 Sets of natural numbers can be implemented as lists of intervals, where
an interval is simply a pair of numbers.  For example the set @{term "{2, 3, 5,
7, 8, 9::nat}"} can be represented by the list @{term "[(2, 3), (5, 5),
(7::nat, 9::nat)]"}.  A typical application is the list of free blocks of
dynamically allocated memory. *}

text {* We introduce the type *}

type_synonym intervals = "(nat*nat) list"

text {* Next, define an \emph{invariant}
that characterizes valid interval lists:
For efficiency reasons intervals should be sorted in ascending order, the lower
bound of each interval should be less than or equal to the upper bound, and the
intervals should be chosen as large as possible, i.e.\ no two adjacent
intervals should overlap or even touch each other.  It turns out to be
convenient to define @{term inv} in terms of a more general function
such that the additional argument is a lower bound for the intervals in
the list:*}

fun inv' :: "nat \<Rightarrow> intervals \<Rightarrow> bool" where
  "inv' n [] \<longleftrightarrow> True"
| "inv' n ((a,b)#ivs) \<longleftrightarrow> n\<le>a \<and> a\<le>b \<and> inv' (b+2) ivs"

definition inv where "inv = inv' 0"

text {* To relate intervals back to sets define an \emph{abstraction function}*}

fun set_of :: "intervals => nat set"
where
  "set_of [] = {}"
| "set_of ((a,b)#ivs) = {a..b} \<union> set_of ivs"

text \<open>Define a function to add a single element to the interval list,
  and show its correctness\<close>

fun merge_aux where
  "merge_aux a b [] = [(a,b)]"
| "merge_aux a b ((c,d)#ivs) = (if b+1=c then (a,d)#ivs else (a,b)#(c,d)#ivs)"

fun add :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
  where
  "add i [] = [(i,i)]"
| "add i ((a,b)#ivs) = (
    if i+1 < a then (i,i)#(a,b)#ivs
    else if i+1 = a then (i,b)#ivs
    else if i\<le>b then (a,b)#ivs
    else if i=b+1 then merge_aux a i ivs
    else (a,b)#add i ivs
  )"

lemma add_pres_inv:
  "n\<le>x \<Longrightarrow> inv' n ivs \<Longrightarrow> inv' n (add x ivs)"
proof (induction ivs arbitrary: n)
  case Nil
  then show ?case by auto
next
  case (Cons a ivs)
  then show ?case
    apply (cases a)
    apply (cases ivs)
    apply auto
    done
qed

lemma set_of_add:
  assumes "n\<le>x"
  assumes "inv' n ivs"
  shows "set_of (add x ivs) = {x} \<union> set_of ivs"
  using assms
proof (induction ivs arbitrary: n)
  case Nil
  then show ?case by auto
next
  case (Cons a ivs)
  then show ?case
    apply (cases a)
    apply (cases ivs)
    apply (auto split: if_splits)
    done
qed

lemma add_correct:
  assumes "inv is"
  shows "inv (add x is)" "set_of (add x is) = {x} \<union> set_of is"
  using add_pres_inv assms tut07.inv_def apply fastforce
  using assms set_of_add tut07.inv_def by fastforce

text \<open>Hints:
  \<^item> Sketch the different cases (position of element relative to the first interval of the list)
    on paper first
  \<^item> In one case, you will also need information about the second interval of the list.
    Do this case split via an auxiliary function! Otherwise, you may end up with a recursion equation of the form
      \<open>f (x#xs) = \<dots> case xs of x'#xs' \<Rightarrow> \<dots> f (x'#xs') \<dots>\<close>
    combined with \<open>split: list.splits\<close> this will make the simplifier loop!

\<close>

text \<open>\Exercise{Optimized Mergesort}

  Import @{theory "Sorting"} for this exercise.
  The @{const msort} function recomputes the length of the list in each iteration.
  Implement an optimized version that has an additional parameter keeping track
  of the length, and show that it is equal to the original @{const msort}.
\<close>

(* Optimized mergesort *)

fun msort2 :: "nat \<Rightarrow> 'a::linorder list \<Rightarrow> 'a list" where
"msort2 n xs = (
  if n \<le> 1 then xs
  else merge (msort2 (n div 2) (take (n div 2) xs)) (msort2 (n - n div 2) (drop (n div 2) xs)))"

declare msort2.simps[simp del]

lemma "n = length xs \<Longrightarrow> msort2 n xs = msort xs"
proof (induction n xs rule: msort2.induct)
  case (1 n xs)
  then show ?case
    using msort.simps[of xs] msort2.simps[of n xs]
    apply (auto simp: )
    done

qed

text \<open>Hint:
  Use @{thm [source] msort.simps} only when instantiated to a particular \<open>xs\<close>
  (@{thm [source] msort.simps[of xs]}),
  otherwise the simplifier will loop!
\<close>

text \<open> \NumHomework{Deletion from Interval Lists}{June 1}

  Implement and prove correct a delete function.

  Hints:
    \<^item> The correctness lemma is analogous to the one for add.
    \<^item> A monotonicity property on \<open>inv'\<close> may be useful, i.e.,
      @{prop \<open>inv' m is \<Longrightarrow> inv' m' is\<close>} if @{prop \<open>m'\<le>m\<close>}
    \<^item> A bounding lemma, relating \<open>m\<close> and the elements of @{term \<open>set_of is\<close>}
      if @{prop \<open>inv' m is\<close>}, may be useful.
\<close>

fun del :: "nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "del _ _ = undefined"

lemma del_correct: "Come up with a meaningful spec yourself" oops

text \<open> \NumHomework{Addition of Interval to Interval List}{June 1}
  For 3 \<^bold>\<open>bonus points\<close>, implement and prove correct a function
  to add a whole interval to an interval list. The runtime must
  not depend on the size of the interval, e.g., iterating over the
  interval and adding the elements separately is not allowed!
\<close>

fun addi :: "nat \<Rightarrow> nat \<Rightarrow> intervals \<Rightarrow> intervals"
where
  "addi i j is = undefined"

lemma addi_correct:
  assumes "inv is" "i\<le>j"
  shows "inv (addi i j is)" "set_of (addi i j is) = {i..j} \<union> (set_of is)"
  sorry

(*<*)
end
(*>*)


theory datatypes_pg
  imports Main
begin

datatype mybool = T | F

fun not :: "mybool \<Rightarrow> mybool" where
  "not T = F" |
  "not F = T"

lemma "not (not b) = b"
  apply (cases b)
  apply simp
  by simp

lemma
  shows "not (not b) = b"
proof (cases b)
case T
  then show ?thesis by simp
next
  case F
  then show ?thesis by simp
qed

(* my nat *)

value "Suc"
datatype my_nat = Zero | suc my_nat
value "Zero"
value "suc"
value "suc Zero" (* 1 *)

fun my_add :: "my_nat \<Rightarrow> my_nat \<Rightarrow> my_nat" where
"my_add Zero n = n" |
"my_add (suc m) n = suc( my_add m n)"

(* induction say for 2 constructors
 1. my_add Zero Zero = Zero
 2. \<And>m. my_add m Zero = m \<Longrightarrow> my_add (suc m) Zero = suc m

 1. my_add Zero C1  = Zero
 2. \<And>m. my_add m Zero = m \<Longrightarrow> my_add (suc m) Zero = suc m
*)
lemma "my_add_0": "my_add m Zero = m"
  apply (induction m)
   apply simp
  by simp

(* type with more than 1 argument *)

datatype tau =
C0 |
C1 tau |
C2 tau tau

end


section \<open>Fib and Gcd commute\<close>

theory Fibonacci
  imports "HOL-Computational_Algebra.Primes"
begin

text \<open>A few proofs of laws taken from Graham et al. @{cite "concrete-math"}.\<close>

subsection \<open>Fibonacci numbers\<close>

fun fib :: "nat \<Rightarrow> nat" where
    "fib 0 = 0"
  | "fib (Suc 0) = 1"
  | "fib (Suc (Suc n)) = fib n + fib (Suc n)"

lemma fib_positive: "fib (Suc n) > 0"
  by (induction n rule: fib.induct) auto

subsection \<open>Fib and gcd commute\<close>

lemma fib_add: "fib (Suc (n + k)) = fib (Suc k) * fib (Suc n) + fib k * fib n"
  by (induction n rule: fib.induct) (auto simp: distrib_left)

lemma coprime_fib_Suc: "coprime (fib n) (fib (Suc n))"
proof (induction n rule: fib.induct)
  case (3 x)
  then show ?case
    by (metis coprime_iff_gcd_eq_1 fib.simps(3) gcd.commute gcd_add1)
qed auto

lemma gcd_fib_add: "gcd (fib m) (fib (n + m)) = gcd (fib m) (fib n)"
proof (cases m)
  case 0
  then show ?thesis by simp
next
  case (Suc k)
  then have "gcd (fib m) (fib (n + m))
           = gcd (fib k * fib n) (fib (Suc k))"
    by (metis add_Suc_right fib_add gcd.commute gcd_add_mult mult.commute)
  also have "\<dots> = gcd (fib n) (fib (Suc k))"
    using coprime_commute coprime_fib_Suc gcd_mult_left_left_cancel by blast
  also have "\<dots> = gcd (fib m) (fib n)"
    using Suc by (simp add: ac_simps)
  finally show ?thesis .
qed

lemma gcd_fib_diff: "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib n)" if "m \<le> n"
proof -
  have "gcd (fib m) (fib (n - m)) = gcd (fib m) (fib (n - m + m))"
    by (simp add: gcd_fib_add)
  also from \<open>m \<le> n\<close> have "n - m + m = n"
    by simp
  finally show ?thesis .
qed

lemma gcd_fib_mod: "gcd (fib m) (fib (n mod m)) = gcd (fib m) (fib n)" if "0 < m"
proof (induction n rule: less_induct)
  case (less n)
  show ?case
  proof -
    have "n mod m = (if n < m then n else (n - m) mod m)"
      by (rule mod_if)
    also have "gcd (fib m) (fib \<dots>) = gcd (fib m) (fib n)"
      using gcd_fib_diff less.IH that by fastforce
    finally show ?thesis .
  qed
qed

theorem fib_gcd: "fib (gcd m n) = gcd (fib m) (fib n)"
proof (induction m n rule: gcd_nat_induct)
  case (step m n)
  then show ?case
    by (metis gcd.commute gcd_fib_mod gcd_red_nat)
qed auto

end


section "Arithmetic and Boolean Expressions"

theory AExp
imports Main begin

subsection "Arithmetic Expressions"

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

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

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

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

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

value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7 ,''x'':= 8))"

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

text \<open>A little syntax magic to write larger states compactly:\<close>

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 \<open>We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:\<close>
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

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

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

text \<open>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}.\<close>

subsection "Constant Folding"

text \<open>Evaluate constant subexpressions:\<close>

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

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

text \<open>Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors:\<close>

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"

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

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 \<open>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.\<close>

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 (auto)
done

end


(*<*) theory ex1_4 imports Main begin (*>*)

text {* Define a function @{text first_pos} that computes the index
of the first element in a list that satisfies a given predicate: *}

primrec first_pos :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
"first_pos f [] =0"
|"first_pos f (x#xs) = (if f x then 0 else 1+ first_pos f xs)"

text {* The smallest index is @{text 0}.  If no element in the
list satisfies the predicate, the behaviour of @{text first_pos} should
be as described below. *}

text {* Verify your definition by computing
\begin{itemize}
\item the index of the first number equal to @{text 3} in the list
  @{text "[1::nat, 3, 5, 3, 1]"},
\item the index of the first number greater than @{text 4} in the list
  @{text "[1::nat, 3, 5, 7]"},
\item the index of  the first list with more than one element in the list
  @{text "[[], [1, 2], [3]]"}.
\end{itemize}

\emph{Note:} Isabelle does not know the operators @{text ">"} and @{text
"\<ge>"}.  Use @{text "<"} and @{text "\<le>"} instead. *}
lemma "first_pos (\<lambda> x. x = 3) [1::nat, 3, 5, 3, 1] = 1"
  by auto

lemma "first_pos (\<lambda> x. 4 < x) [1::nat, 3, 5, 7] = 2"
  by auto

lemma "first_pos (\<lambda> x. 1 < length x) [[], [1, 2], [3]] = 1"
  by auto

text {* Prove that @{text first_pos} returns the length of the list if
and only if no element in the list satisfies the given predicate. *}
lemma "list_all (\<lambda> x. \<not> P x) xs = (first_pos P xs = length xs)"
  apply (induct xs)
  apply auto
done

text {* Now prove: *}

lemma "list_all (\<lambda> x. \<not> P x) (take (first_pos P xs) xs)"
  apply (induct xs)
   apply auto
  done

text {* How can @{text "first_pos (\<lambda> x. P x \<or> Q x) xs"} be computed from
@{text "first_pos P xs"} and @{text "first_pos Q xs"}?  Can something
similar be said for the conjunction of @{text P} and @{text Q}?  Prove
your statement(s). *}
lemma "first_pos (\<lambda> x. P x \<or> Q x) xs = min (first_pos P xs) (first_pos Q xs)"
  apply (induct xs)
   apply auto
  done

lemma "max (first_pos P xs) (first_pos Q xs) \<le> first_pos (\<lambda> x. P x \<and> Q x) xs "
  apply (induct xs)
   apply auto
  done

text {* Suppose @{text P} implies @{text Q}. What can be said about the
relation between @{text "first_pos P xs"} and @{text "first_pos Q xs"}?
Prove your statement. *}
lemma "(\<forall>x. P x \<longrightarrow> Q x) \<longrightarrow> first_pos Q xs \<le> first_pos P xs "
  apply (induct xs)
   apply auto
  done

text {* Define a function @{text count} that counts the number of
elements in a list that satisfy a given predicate. *}

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

text {* Show: The number of elements with a given property stays the
same when one reverses a list with @{text rev}.  The proof will require
a lemma. *}
lemma count_1: "f a \<longrightarrow> Suc( count f xs) = count f (xs@[a])"
  apply (induct xs)
   apply auto
  done

lemma "count f xs = count f (rev xs)"
  apply (induct xs)
  apply (auto simp add:count_1)
  oops

text {* Find and prove a connection between the two functions @{text filter}
and @{text count}. *}
lemma "count f xs = length ( filter f xs)"
  apply (induct xs)
   apply auto
  done

(*<*) end (*>*)


(*  Title:      HOL/Equiv_Relations.thy
    Author:     Lawrence C Paulson, 1996 Cambridge University Computer Laboratory
*)

section \<open>Equivalence Relations in Higher-Order Set Theory\<close>

theory Equiv_Relations
  imports Groups_Big Relation
begin

subsection \<open>Equivalence relations -- set version\<close>

definition equiv :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
  where "equiv A r \<longleftrightarrow> refl_on A r \<and> sym r \<and> trans r"

lemma equivI: "refl_on A r \<Longrightarrow> sym r \<Longrightarrow> trans r \<Longrightarrow> equiv A r"
  by (simp add: equiv_def)

lemma equivE:
  assumes "equiv A r"
  obtains "refl_on A r" and "sym r" and "trans r"
  using assms by (simp add: equiv_def)

text \<open>
  Suppes, Theorem 70: \<open>r\<close> is an equiv relation iff \<open>r\<inverse> O r = r\<close>.

  First half: \<open>equiv A r \<Longrightarrow> r\<inverse> O r = r\<close>.
\<close>

lemma sym_trans_comp_subset: "sym r \<Longrightarrow> trans r \<Longrightarrow> r\<inverse> O r \<subseteq> r"
  unfolding trans_def sym_def converse_unfold by blast

lemma refl_on_comp_subset: "refl_on A r \<Longrightarrow> r \<subseteq> r\<inverse> O r"
  unfolding refl_on_def by blast

lemma equiv_comp_eq: "equiv A r \<Longrightarrow> r\<inverse> O r = r"
  apply (unfold equiv_def)
  apply clarify
  apply (rule equalityI)
   apply (iprover intro: sym_trans_comp_subset refl_on_comp_subset)+
  done

text \<open>Second half.\<close>

lemma comp_equivI: "r\<inverse> O r = r \<Longrightarrow> Domain r = A \<Longrightarrow> equiv A r"
  apply (unfold equiv_def refl_on_def sym_def trans_def)
  apply (erule equalityE)
  apply (subgoal_tac "\<forall>x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r")
   apply fast
  apply fast
  done

subsection \<open>Equivalence classes\<close>

lemma equiv_class_subset: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} \<subseteq> r``{b}"
  \<comment> \<open>lemma for the next result\<close>
  unfolding equiv_def trans_def sym_def by blast

theorem equiv_class_eq: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} = r``{b}"
  apply (assumption | rule equalityI equiv_class_subset)+
  apply (unfold equiv_def sym_def)
  apply blast
  done

lemma equiv_class_self: "equiv A r \<Longrightarrow> a \<in> A \<Longrightarrow> a \<in> r``{a}"
  unfolding equiv_def refl_on_def by blast

lemma subset_equiv_class: "equiv A r \<Longrightarrow> r``{b} \<subseteq> r``{a} \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
  \<comment> \<open>lemma for the next result\<close>
  unfolding equiv_def refl_on_def by blast

lemma eq_equiv_class: "r``{a} = r``{b} \<Longrightarrow> equiv A r \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
  by (iprover intro: equalityD2 subset_equiv_class)

lemma equiv_class_nondisjoint: "equiv A r \<Longrightarrow> x \<in> (r``{a} \<inter> r``{b}) \<Longrightarrow> (a, b) \<in> r"
  unfolding equiv_def trans_def sym_def by blast

lemma equiv_type: "equiv A r \<Longrightarrow> r \<subseteq> A \<times> A"
  unfolding equiv_def refl_on_def by blast

lemma equiv_class_eq_iff: "equiv A r \<Longrightarrow> (x, y) \<in> r \<longleftrightarrow> r``{x} = r``{y} \<and> x \<in> A \<and> y \<in> A"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

lemma eq_equiv_class_iff: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> r``{x} = r``{y} \<longleftrightarrow> (x, y) \<in> r"
  by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)

subsection \<open>Quotients\<close>

definition quotient :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set set"  (infixl "'/'/" 90)
  where "A//r = (\<Union>x \<in> A. {r``{x}})"  \<comment> \<open>set of equiv classes\<close>

lemma quotientI: "x \<in> A ==> r``{x} \<in> A//r"
  unfolding quotient_def by blast

lemma quotientE: "X \<in> A//r \<Longrightarrow> (\<And>x. X = r``{x} \<Longrightarrow> x \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
  unfolding quotient_def by blast

lemma Union_quotient: "equiv A r \<Longrightarrow> \<Union>(A//r) = A"
  unfolding equiv_def refl_on_def quotient_def by blast

lemma quotient_disj: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> X = Y \<or> X \<inter> Y = {}"
  apply (unfold quotient_def)
  apply clarify
  apply (rule equiv_class_eq)
   apply assumption
  apply (unfold equiv_def trans_def sym_def)
  apply blast
  done

lemma quotient_eqI:
  "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> X = Y"
  apply (clarify elim!: quotientE)
  apply (rule equiv_class_eq)
   apply assumption
  apply (unfold equiv_def sym_def trans_def)
  apply blast
  done

lemma quotient_eq_iff:
  "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> X = Y \<longleftrightarrow> (x, y) \<in> r"
  apply (rule iffI)
   prefer 2
   apply (blast del: equalityI intro: quotient_eqI)
  apply (clarify elim!: quotientE)
  apply (unfold equiv_def sym_def trans_def)
  apply blast
  done

lemma eq_equiv_class_iff2: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> {x}//r = {y}//r \<longleftrightarrow> (x, y) \<in> r"
  by (simp add: quotient_def eq_equiv_class_iff)

lemma quotient_empty [simp]: "{}//r = {}"
  by (simp add: quotient_def)

lemma quotient_is_empty [iff]: "A//r = {} \<longleftrightarrow> A = {}"
  by (simp add: quotient_def)

lemma quotient_is_empty2 [iff]: "{} = A//r \<longleftrightarrow> A = {}"
  by (simp add: quotient_def)

lemma singleton_quotient: "{x}//r = {r `` {x}}"
  by (simp add: quotient_def)

lemma quotient_diff1: "inj_on (\<lambda>a. {a}//r) A \<Longrightarrow> a \<in> A \<Longrightarrow> (A - {a})//r = A//r - {a}//r"
  unfolding quotient_def inj_on_def by blast

subsection \<open>Refinement of one equivalence relation WRT another\<close>

lemma refines_equiv_class_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> R``(S``{a}) = S``{a}"
  by (auto simp: equiv_class_eq_iff)

lemma refines_equiv_class_eq2: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> S``(R``{a}) = S``{a}"
  by (auto simp: equiv_class_eq_iff)

lemma refines_equiv_image_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> (\<lambda>X. S``X) ` (A//R) = A//S"
   by (auto simp: quotient_def image_UN refines_equiv_class_eq2)

lemma finite_refines_finite:
  "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> finite (A//S)"
  by (erule finite_surj [where f = "\<lambda>X. S``X"]) (simp add: refines_equiv_image_eq)

lemma finite_refines_card_le:
  "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> card (A//S) \<le> card (A//R)"
  by (subst refines_equiv_image_eq [of R S A, symmetric])
    (auto simp: card_image_le [where f = "\<lambda>X. S``X"])

subsection \<open>Defining unary operations upon equivalence classes\<close>

text \<open>A congruence-preserving function.\<close>

definition congruent :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "congruent r f \<longleftrightarrow> (\<forall>(y, z) \<in> r. f y = f z)"

lemma congruentI: "(\<And>y z. (y, z) \<in> r \<Longrightarrow> f y = f z) \<Longrightarrow> congruent r f"
  by (auto simp add: congruent_def)

lemma congruentD: "congruent r f \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> f y = f z"
  by (auto simp add: congruent_def)

abbreviation RESPECTS :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects" 80)
  where "f respects r \<equiv> congruent r f"

lemma UN_constant_eq: "a \<in> A \<Longrightarrow> \<forall>y \<in> A. f y = c \<Longrightarrow> (\<Union>y \<in> A. f y) = c"
  \<comment> \<open>lemma required to prove \<open>UN_equiv_class\<close>\<close>
  by auto

lemma UN_equiv_class: "equiv A r \<Longrightarrow> f respects r \<Longrightarrow> a \<in> A \<Longrightarrow> (\<Union>x \<in> r``{a}. f x) = f a"
  \<comment> \<open>Conversion rule\<close>
  apply (rule equiv_class_self [THEN UN_constant_eq])
    apply assumption
   apply assumption
  apply (unfold equiv_def congruent_def sym_def)
  apply (blast del: equalityI)
  done

lemma UN_equiv_class_type:
  "equiv A r \<Longrightarrow> f respects r \<Longrightarrow> X \<in> A//r \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> (\<Union>x \<in> X. f x) \<in> B"
  apply (unfold quotient_def)
  apply clarify
  apply (subst UN_equiv_class)
     apply auto
  done

text \<open>
  Sufficient conditions for injectiveness.  Could weaken premises!
  major premise could be an inclusion; \<open>bcong\<close> could be
  \<open>\<And>y. y \<in> A \<Longrightarrow> f y \<in> B\<close>.
\<close>

lemma UN_equiv_class_inject:
  "equiv A r \<Longrightarrow> f respects r \<Longrightarrow>
    (\<Union>x \<in> X. f x) = (\<Union>y \<in> Y. f y) \<Longrightarrow> X \<in> A//r ==> Y \<in> A//r
    \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> (x, y) \<in> r)
    \<Longrightarrow> X = Y"
  apply (unfold quotient_def)
  apply clarify
  apply (rule equiv_class_eq)
   apply assumption
  apply (subgoal_tac "f x = f xa")
   apply blast
  apply (erule box_equals)
   apply (assumption | rule UN_equiv_class)+
  done

subsection \<open>Defining binary operations upon equivalence classes\<close>

text \<open>A congruence-preserving function of two arguments.\<close>

definition congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool"
  where "congruent2 r1 r2 f \<longleftrightarrow> (\<forall>(y1, z1) \<in> r1. \<forall>(y2, z2) \<in> r2. f y1 y2 = f z1 z2)"

lemma congruent2I':
  assumes "\<And>y1 z1 y2 z2. (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  shows "congruent2 r1 r2 f"
  using assms by (auto simp add: congruent2_def)

lemma congruent2D: "congruent2 r1 r2 f \<Longrightarrow> (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
  by (auto simp add: congruent2_def)

text \<open>Abbreviation for the common case where the relations are identical.\<close>
abbreviation RESPECTS2:: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects2" 80)
  where "f respects2 r \<equiv> congruent2 r r f"

lemma congruent2_implies_congruent:
  "equiv A r1 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A \<Longrightarrow> congruent r2 (f a)"
  unfolding congruent_def congruent2_def equiv_def refl_on_def by blast

lemma congruent2_implies_congruent_UN:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A2 \<Longrightarrow>
    congruent r1 (\<lambda>x1. \<Union>x2 \<in> r2``{a}. f x1 x2)"
  apply (unfold congruent_def)
  apply clarify
  apply (rule equiv_type [THEN subsetD, THEN SigmaE2], assumption+)
  apply (simp add: UN_equiv_class congruent2_implies_congruent)
  apply (unfold congruent2_def equiv_def refl_on_def)
  apply (blast del: equalityI)
  done

lemma UN_equiv_class2:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a1 \<in> A1 \<Longrightarrow> a2 \<in> A2 \<Longrightarrow>
    (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. f x1 x2) = f a1 a2"
  by (simp add: UN_equiv_class congruent2_implies_congruent congruent2_implies_congruent_UN)

lemma UN_equiv_class_type2:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f
    \<Longrightarrow> X1 \<in> A1//r1 \<Longrightarrow> X2 \<in> A2//r2
    \<Longrightarrow> (\<And>x1 x2. x1 \<in> A1 \<Longrightarrow> x2 \<in> A2 \<Longrightarrow> f x1 x2 \<in> B)
    \<Longrightarrow> (\<Union>x1 \<in> X1. \<Union>x2 \<in> X2. f x1 x2) \<in> B"
  apply (unfold quotient_def)
  apply clarify
  apply (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
      congruent2_implies_congruent quotientI)
  done

lemma UN_UN_split_split_eq:
  "(\<Union>(x1, x2) \<in> X. \<Union>(y1, y2) \<in> Y. A x1 x2 y1 y2) =
    (\<Union>x \<in> X. \<Union>y \<in> Y. (\<lambda>(x1, x2). (\<lambda>(y1, y2). A x1 x2 y1 y2) y) x)"
  \<comment> \<open>Allows a natural expression of binary operators,\<close>
  \<comment> \<open>without explicit calls to \<open>split\<close>\<close>
  by auto

lemma congruent2I:
  "equiv A1 r1 \<Longrightarrow> equiv A2 r2
    \<Longrightarrow> (\<And>y z w. w \<in> A2 \<Longrightarrow> (y,z) \<in> r1 \<Longrightarrow> f y w = f z w)
    \<Longrightarrow> (\<And>y z w. w \<in> A1 \<Longrightarrow> (y,z) \<in> r2 \<Longrightarrow> f w y = f w z)
    \<Longrightarrow> congruent2 r1 r2 f"
  \<comment> \<open>Suggested by John Harrison -- the two subproofs may be\<close>
  \<comment> \<open>\<^emph>\<open>much\<close> simpler than the direct proof.\<close>
  apply (unfold congruent2_def equiv_def refl_on_def)
  apply clarify
  apply (blast intro: trans)
  done

lemma congruent2_commuteI:
  assumes equivA: "equiv A r"
    and commute: "\<And>y z. y \<in> A \<Longrightarrow> z \<in> A \<Longrightarrow> f y z = f z y"
    and congt: "\<And>y z w. w \<in> A \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> f w y = f w z"
  shows "f respects2 r"
  apply (rule congruent2I [OF equivA equivA])
   apply (rule commute [THEN trans])
     apply (rule_tac [3] commute [THEN trans, symmetric])
       apply (rule_tac [5] sym)
       apply (rule congt | assumption |
         erule equivA [THEN equiv_type, THEN subsetD, THEN SigmaE2])+
  done

subsection \<open>Quotients and finiteness\<close>

text \<open>Suggested by Florian Kammüller\<close>

lemma finite_quotient: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> finite (A//r)"
  \<comment> \<open>recall @{thm equiv_type}\<close>
  apply (rule finite_subset)
   apply (erule_tac [2] finite_Pow_iff [THEN iffD2])
  apply (unfold quotient_def)
  apply blast
  done

lemma finite_equiv_class: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> X \<in> A//r \<Longrightarrow> finite X"
  apply (unfold quotient_def)
  apply (rule finite_subset)
   prefer 2 apply assumption
  apply blast
  done

lemma equiv_imp_dvd_card: "finite A \<Longrightarrow> equiv A r \<Longrightarrow> \<forall>X \<in> A//r. k dvd card X \<Longrightarrow> k dvd card A"
  apply (rule Union_quotient [THEN subst [where P="\<lambda>A. k dvd card A"]])
   apply assumption
  apply (rule dvd_partition)
    prefer 3 apply (blast dest: quotient_disj)
   apply (simp_all add: Union_quotient equiv_type)
  done

lemma card_quotient_disjoint: "finite A \<Longrightarrow> inj_on (\<lambda>x. {x} // r) A \<Longrightarrow> card (A//r) = card A"
  apply (simp add:quotient_def)
  apply (subst card_UN_disjoint)
     apply assumption
    apply simp
   apply (fastforce simp add:inj_on_def)
  apply simp
  done

subsection \<open>Projection\<close>

definition proj :: "('b \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'a set"
  where "proj r x = r `` {x}"

lemma proj_preserves: "x \<in> A \<Longrightarrow> proj r x \<in> A//r"
  unfolding proj_def by (rule quotientI)

lemma proj_in_iff:
  assumes "equiv A r"
  shows "proj r x \<in> A//r \<longleftrightarrow> x \<in> A"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?rhs
  then show ?lhs by (simp add: proj_preserves)
next
  assume ?lhs
  then show ?rhs
    unfolding proj_def quotient_def
  proof clarsimp
    fix y
    assume y: "y \<in> A" and "r `` {x} = r `` {y}"
    moreover have "y \<in> r `` {y}"
      using assms y unfolding equiv_def refl_on_def by blast
    ultimately have "(x, y) \<in> r" by blast
    then show "x \<in> A"
      using assms unfolding equiv_def refl_on_def by blast
  qed
qed

lemma proj_iff: "equiv A r \<Longrightarrow> {x, y} \<subseteq> A \<Longrightarrow> proj r x = proj r y \<longleftrightarrow> (x, y) \<in> r"
  by (simp add: proj_def eq_equiv_class_iff)

(*
lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
unfolding proj_def equiv_def refl_on_def by blast
*)

lemma proj_image: "proj r ` A = A//r"
  unfolding proj_def[abs_def] quotient_def by blast

lemma in_quotient_imp_non_empty: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<noteq> {}"
  unfolding quotient_def using equiv_class_self by fast

lemma in_quotient_imp_in_rel: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> {x, y} \<subseteq> X \<Longrightarrow> (x, y) \<in> r"
  using quotient_eq_iff[THEN iffD1] by fastforce

lemma in_quotient_imp_closed: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> X"
  unfolding quotient_def equiv_def trans_def by blast

lemma in_quotient_imp_subset: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<subseteq> A"
  using in_quotient_imp_in_rel equiv_type by fastforce

subsection \<open>Equivalence relations -- predicate version\<close>

text \<open>Partial equivalences.\<close>

definition part_equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> (\<forall>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y)"
    \<comment> \<open>John-Harrison-style characterization\<close>

lemma part_equivpI: "\<exists>x. R x x \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> part_equivp R"
  by (auto simp add: part_equivp_def) (auto elim: sympE transpE)

lemma part_equivpE:
  assumes "part_equivp R"
  obtains x where "R x x" and "symp R" and "transp R"
proof -
  from assms have 1: "\<exists>x. R x x"
    and 2: "\<And>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y"
    unfolding part_equivp_def by blast+
  from 1 obtain x where "R x x" ..
  moreover have "symp R"
  proof (rule sympI)
    fix x y
    assume "R x y"
    with 2 [of x y] show "R y x" by auto
  qed
  moreover have "transp R"
  proof (rule transpI)
    fix x y z
    assume "R x y" and "R y z"
    with 2 [of x y] 2 [of y z] show "R x z" by auto
  qed
  ultimately show thesis by (rule that)
qed

lemma part_equivp_refl_symp_transp: "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> symp R \<and> transp R"
  by (auto intro: part_equivpI elim: part_equivpE)

lemma part_equivp_symp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule part_equivpE, erule sympE)

lemma part_equivp_transp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule part_equivpE, erule transpE)

lemma part_equivp_typedef: "part_equivp R \<Longrightarrow> \<exists>d. d \<in> {c. \<exists>x. R x x \<and> c = Collect (R x)}"
  by (auto elim: part_equivpE)

text \<open>Total equivalences.\<close>

definition equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
  where "equivp R \<longleftrightarrow> (\<forall>x y. R x y = (R x = R y))" \<comment> \<open>John-Harrison-style characterization\<close>

lemma equivpI: "reflp R \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> equivp R"
  by (auto elim: reflpE sympE transpE simp add: equivp_def)

lemma equivpE:
  assumes "equivp R"
  obtains "reflp R" and "symp R" and "transp R"
  using assms by (auto intro!: that reflpI sympI transpI simp add: equivp_def)

lemma equivp_implies_part_equivp: "equivp R \<Longrightarrow> part_equivp R"
  by (auto intro: part_equivpI elim: equivpE reflpE)

lemma equivp_equiv: "equiv UNIV A \<longleftrightarrow> equivp (\<lambda>x y. (x, y) \<in> A)"
  by (auto intro!: equivI equivpI [to_set] elim!: equivE equivpE [to_set])

lemma equivp_reflp_symp_transp: "equivp R \<longleftrightarrow> reflp R \<and> symp R \<and> transp R"
  by (auto intro: equivpI elim: equivpE)

lemma identity_equivp: "equivp (op =)"
  by (auto intro: equivpI reflpI sympI transpI)

lemma equivp_reflp: "equivp R \<Longrightarrow> R x x"
  by (erule equivpE, erule reflpE)

lemma equivp_symp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
  by (erule equivpE, erule sympE)

lemma equivp_transp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
  by (erule equivpE, erule transpE)

hide_const (open) proj

end


theory Replace
  imports Main
begin

text\<open>
Define a function @{term replace}, such that @{term"replace x y zs"}
yields @{term zs} with every occurrence of @{term x} replaced by @{term y}.\<close>

fun replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
  "replace _ _ [] = []" |
  "replace x y (z#zs) = (if x = z
                         then (y #(replace x y zs))
                         else (z # (replace x y zs)))"

lemma replace_app:"replace x y (zs1 @ zs2) = replace x y zs1 @ replace x y zs2"
  apply (induction zs1)
  by auto

text \<open>
Prove or disprove (by counterexample) the following theorems.
You may have to prove some lemmas first.
\<close>

theorem "rev(replace x y zs) = replace x y (rev zs)"
  apply (induction zs)
  by (auto simp add: replace_app)

theorem "replace x y (replace u v zs) = replace u v (replace x y zs)"
  oops
(*
Found by quickcheck
  x = a\<^sub>1
  y = a\<^sub>2
  u = a\<^sub>2
  v = a\<^sub>1
  zs = [a\<^sub>1]
*)

theorem "replace y z (replace x y zs) = replace x z zs"
  oops
(*
Found by quickcheck
  y = a\<^sub>1
  z = a\<^sub>2
  x = a\<^sub>2
  zs = [a\<^sub>1]
*)

text\<open>Define two functions for removing elements from a list:
@{term"del1 x xs"} deletes the first occurrence (from the left) of
@{term x} in @{term xs}, @{term"delall x xs"} all of them.\<close>

consts del1'   :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
       delall' :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"

fun del1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
"del1 _ []     = []" |
"del1 x (y#ys) = (if x = y
                  then ys
                  else y#del1 x ys)"

value "del1 1 [1, 11, 43, 0] :: nat list"

fun delall :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
  where
"delall _ []     = []" |
"delall x (y#ys) = (if x = y
                    then delall x ys
                    else y#delall x ys)"

lemma delall_app:"delall a (xs @ ys) = delall a xs @ delall a ys"
  apply (induction xs)
  by auto

text\<open>Prove or disprove (by counterexample) the following theorems.\<close>

theorem [simp]:"del1 x (delall x xs) = delall x xs"
  apply (induction xs)
  by (auto simp add: delall_app)

theorem "delall x (delall x xs) = delall x xs"
  apply (induction xs)
  by (auto simp add: delall_app)

theorem "delall x (del1 x xs) = delall x xs"
  apply (induction xs)
  by (auto simp add: delall_app)

theorem "del1 x (del1 y zs) = del1 y (del1 x zs)"
  apply (induction zs)
  by auto

theorem "delall x (del1 y zs) = del1 y (delall x zs)"
  apply (induction zs)
   apply simp
  apply simp
  apply (case_tac "y=a")
   apply (case_tac "x=a")
  by (auto simp add: delall_app)

theorem "delall x (delall y zs) = delall y (delall x zs)"
  apply (induction zs)
  by (auto simp add: delall_app)

theorem "del1 y (replace x y xs) = del1 x xs"
(*
Found by quickcheck
  y = a\<^sub>1
  x = a\<^sub>2
  xs = [a\<^sub>1]
*)
  oops

theorem "delall y (replace x y xs) = delall x xs"
(*
Found by quickcheck
  y = a\<^sub>1
  x = a\<^sub>2
  xs = [a\<^sub>1]
*)
  oops

theorem "replace x y (delall x zs) = delall x zs"
  apply (induction zs)
  by (auto simp add: delall_app)

theorem "replace x y (delall z zs) = delall z (replace x y zs)"
(*
Found by quickcheck:
  x = a\<^sub>1
  y = a\<^sub>2
  z = a\<^sub>1
  zs = [a\<^sub>1]
*)
  oops

theorem "rev(del1 x xs) = del1 x (rev xs)"
(*
Auto Quickcheck found a counterexample:
  x = a\<^sub>1
  xs = [a\<^sub>1, a\<^sub>2, a\<^sub>1]
*)
  oops

theorem "rev(delall x xs) = delall x (rev xs)"
  apply (induction xs)
  by (auto simp add: delall_app)

end


(*
    $Id: sol.thy,v 1.5 2012/01/04 14:35:44 webertj Exp $
    Author: Farhad Mehta
*)

header {* Recursive Functions and Induction: Zip *}

(*<*) theory sol imports Main begin (*>*)

text {*
Read the chapter about total recursive functions in the ``Tutorial on
Isabelle/HOL'' (@{text fun}, Chapter 3.5).
*}

text {*
In this exercise you will define a function @{text Zip} that merges two lists
by interleaving.
 Examples:
@{text "Zip [a1, a2, a3]  [b1, b2, b3] = [a1, b1, a2, b2, a3, b3]"}
 and
@{text "Zip [a1] [b1, b2, b3] = [a1, b1, b2, b3]"}.

Use three different approaches to define @{text Zip}:
\begin{enumerate}
\item by primitive recursion on the first list,
\item by primitive recursion on the second list,
\item by total recursion (using @{text fun}).
\end{enumerate}
*}

primrec zip1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "zip1 []     ys = ys"
| "zip1 (x#xs) ys = (case ys of [] \<Rightarrow> x#xs | z#zs \<Rightarrow> x # z # zip1 xs zs)"

primrec zip2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "zip2 xs []     = xs"
| "zip2 xs (y#ys) = (case xs of [] => y#ys | z#zs => z # y # zip2 zs ys)"

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

text {*
Show that all three versions of @{text Zip} are equivalent.
*}

lemma zip1_zip2: "zip1 xs ys = zip2 xs ys"
  apply (induct xs arbitrary: ys)
    apply (case_tac ys)
    apply auto
  apply (case_tac ys)
  apply auto
done

lemma zip2_zipr: "zip2 xs ys = zipr xs ys"
  apply (induct ys arbitrary: xs)
    apply (case_tac xs)
    apply auto
  apply (case_tac xs)
  apply auto
done

lemma "zipr xs ys = zip1 xs ys"
by (simp add: zip1_zip2 zip2_zipr)

text {*
Show that @{text zipr} distributes over @{text append}.
*}

lemma "\<lbrakk>length p = length u; length q = length v\<rbrakk> \<Longrightarrow>
  zipr (p@q) (u@v) = zipr p u @ zipr q v"
  apply (induct p arbitrary: q u v)
    apply auto
  apply (case_tac u)
    apply auto
done

text {*
{\bf Note:} For @{text fun}, the order of your equations is relevant.
If equations overlap, they will be disambiguated before they are added
to the logic.  You can have a look at these equations using @{text
"thm zipr.simps"}.
*}

(*<*) end (*>*)


(*  Title:       InitialTerminal
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter InitialTerminal

theory InitialTerminal
imports EpiMonoIso
begin

  text\<open>
    This theory defines the notions of initial and terminal object in a category
    and establishes some properties of these notions, including that when they exist
    they are unique up to isomorphism.
\<close>

  context category
  begin

    definition initial
    where "initial a \<equiv> ide a \<and> (\<forall>b. ide b \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>))"

    definition terminal
    where "terminal b \<equiv> ide b \<and> (\<forall>a. ide a \<longrightarrow> (\<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>))"

    abbreviation initial_arr
    where "initial_arr f \<equiv> arr f \<and> initial (dom f)"

    abbreviation terminal_arr
    where "terminal_arr f \<equiv> arr f \<and> terminal (cod f)"

    abbreviation point
    where "point f \<equiv> arr f \<and> terminal (dom f)"

    lemma initial_arr_unique:
    assumes "par f f'" and "initial_arr f" and "initial_arr f'"
    shows "f = f'"
      using assms in_homI initial_def ide_cod by blast

    lemma initialI [intro]:
    assumes "ide a" and "\<And>b. ide b \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    shows "initial a"
      using assms initial_def by auto

    lemma initialE [elim]:
    assumes "initial a" and "ide b"
    obtains f where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<And>f'. \<guillemotleft>f' : a \<rightarrow> b\<guillemotright> \<Longrightarrow> f' = f"
      using assms initial_def initial_arr_unique by meson

    lemma terminal_arr_unique:
    assumes "par f f'" and "terminal_arr f" and "terminal_arr f'"
    shows "f = f'"
      using assms in_homI terminal_def ide_dom by blast

    lemma terminalI [intro]:
    assumes "ide b" and "\<And>a. ide a \<Longrightarrow> \<exists>!f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    shows "terminal b"
      using assms terminal_def by auto

    lemma terminalE [elim]:
    assumes "terminal b" and "ide a"
    obtains f where "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "\<And>f'. \<guillemotleft>f' : a \<rightarrow> b\<guillemotright> \<Longrightarrow> f' = f"
      using assms terminal_def terminal_arr_unique by meson

    theorem terminal_objs_isomorphic:
    assumes "terminal a" and "terminal b"
    shows "isomorphic a b"
    proof -
      from assms obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
        using terminal_def by meson
      from assms obtain g where g: "\<guillemotleft>g : b \<rightarrow> a\<guillemotright>"
        using terminal_def by meson
      have "iso f"
        using assms f g
        by (metis arr_iff_in_hom cod_comp retractionI sectionI seqI' terminal_def
            dom_comp in_homE iso_iff_section_and_retraction ide_in_hom)
      thus ?thesis using f by auto
    qed

    theorem initial_objs_isomorphic:
    assumes "initial a" and "initial b"
    shows "isomorphic a b"
    proof -
      from assms obtain f where f: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" using initial_def by auto
      from assms obtain g where g: "\<guillemotleft>g : b \<rightarrow> a\<guillemotright>" using initial_def by auto
      have "iso f"
        using assms f g
        by (metis (no_types, lifting) arr_iff_in_hom cod_comp in_homE initial_def
            retractionI sectionI dom_comp iso_iff_section_and_retraction ide_in_hom seqI')
      thus ?thesis
        using f by auto
    qed

    lemma point_is_mono:
    assumes "point f"
    shows "mono f"
    proof -
      have "ide (cod f)" using assms by auto
      from this obtain t where t: "\<guillemotleft>t: cod f \<rightarrow> dom f\<guillemotright>"
        using assms terminal_def by blast
      thus ?thesis
        using assms terminal_def monoI
        by (metis seqE in_homI dom_comp ide_dom terminal_def)
    qed

  end

end


theory special_exp_day2
  imports Main
begin

fun sum :: "nat => nat"
  where "sum 0 = 0"
  | "sum (Suc n) = Suc n + sum n"

value "sum 2"
value "sum (Suc (Suc 0))"
value "sum (Suc (Suc (Suc 0)))"
value "sum 3"

theorem "\<forall>n  :: nat. 2 * sum n = n * ( n + 1 )"
proof
  fix n :: nat
  show "2 * special_exp_day2.sum n = n * ( n + 1 )"
  proof (induction n)
    case 0
    then show "2 * special_exp_day2.sum 0 = 0 * ( 0 + 1 )" by simp
  next
  case (Suc n)
  then show "2 *special_exp_day2.sum (Suc n) = Suc n * ( (Suc n) + 1 )"
    by (smt Suc_eq_plus1 add_mult_distrib2 crossproduct_noteq mult_2 nat_mult_1_right semiring_normalization_rules(22) semiring_normalization_rules(3) special_exp_day2.sum.simps(2))
qed
qed

  export_code special_exp_day2.sum in Scala

end


(*
    $Id: sol.thy,v 1.3 2011/06/28 18:11:39 webertj Exp $
    Author: Tobias Nipkow
*)

header {* Complete Binary Trees *}

(*<*) theory sol imports Main begin (*>*)

text {* Let's work with skeletons of binary trees where neither the leaves
(``tip'') nor the nodes contain any information: *}

datatype tree = Tp | Nd tree tree

text {* Define a function @{term tips} that counts the tips of a tree, and a
function @{term height} that computes the height of a tree. *}

primrec tips :: "tree => nat" where
  "tips Tp       = 1"
| "tips (Nd l r) = tips l + tips r"

primrec height :: "tree => nat" where
  "height Tp       = 0"
| "height (Nd l r) = max (height l) (height r) + 1"

text {* Complete binary trees of a given height are generated as follows: *}

primrec cbt :: "nat \<Rightarrow> tree" where
  "cbt 0       = Tp"
| "cbt (Suc n) = Nd (cbt n) (cbt n)"

text {* We will now focus on these complete binary trees.

Instead of generating complete binary trees, we can also \emph{test} if a
binary tree is complete.  Define a function @{term "iscbt f"} (where @{term f}
is a function on trees) that checks for completeness:  @{term Tp} is complete,
and @{term"Nd l r"} is complete iff @{term l} and @{term r} are complete and
@{prop"f l = f r"}. *}

primrec iscbt :: "(tree => 'a) => tree => bool" where
  "iscbt f Tp       = True"
| "iscbt f (Nd l r) = (iscbt f l \<and> iscbt f r \<and> f l = f r)"

text {* We now have 3 functions on trees, namely @{term tips}, @{term height}
and @{term size}.  The latter is defined automatically -- look it up in the
tutorial.  Thus we also have 3 kinds of completeness:  complete wrt.\ @{term
tips}, complete wrt.\ @{term height} and complete wrt.\ @{term size}.  Show
that
\begin{itemize}
\item the 3 notions are the same (e.g.\ @{prop "iscbt tips t = iscbt size t"}),
      and
\item the 3 notions describe exactly the trees generated by @{term cbt}:  the
      result of @{term cbt} is complete (in the sense of @{term iscbt}, wrt.\
      any function on trees), and if a tree is complete in the sense of @{term
      iscbt}, it is the result of @{term cbt} (applied to a suitable number~--
      which one?).
\end{itemize}

Hints:
\begin{itemize}
\item Work out and prove suitable relationships between @{term tips}, @{term
      height} und @{term size}.

\item If you need lemmas dealing only with the basic arithmetic operations
      (@{text"+"}, @{text"*"}, @{text"^"} etc), you may ``prove'' them with the
      command @{text sorry}, if neither @{text arith} nor you can find a proof.
      Not @{text "apply sorry"}, just @{text sorry}.

\item You do not need to show that every notion is equal to every other notion.
      It suffices to show that $A = C$ und $B = C$ -- $A = B$ is a trivial
      consequence.  However, the difficulty of the proof will depend on which
      of the equivalences you prove.

\item There is @{text"\<and>"} and @{text"\<longrightarrow>"}.
\end{itemize} *}

text {* The three notions are the same: *}

theorem iscbt_height_tips: "iscbt height t = iscbt tips t"
  apply (induct t)
  apply auto
done

lemma [simp]: "tips t = size t + 1"
  apply (induct t)
  apply auto
done

theorem iscbt_tips_size: "iscbt tips t = iscbt size t"
  apply (induct t)
  apply auto
done

theorem iscbt_size_height: "iscbt size t = iscbt height t"
  by (simp add: iscbt_height_tips iscbt_tips_size)

text {* The 3 notions describe exactly the trees generated by @{term cbt}: *}

theorem "iscbt f (cbt n)"
  apply (induct n)
  apply auto
done

theorem "iscbt height t --> t = cbt (height t)"
  apply (induct t)
  apply auto
done

text {* Find a function @{term f} such that @{term "iscbt f"} is different from
@{term "iscbt size"}. *}

lemma "iscbt (\<lambda>t. 0) \<noteq> iscbt size"
  apply (rule notI)
  apply (drule_tac x="Nd Tp (Nd Tp Tp)" in cong)
    apply (rule refl)
  apply simp
done

(*<*) end (*>*)


section "Concrete Semantics Chapter 3"

theory ConcreteSemantics3
  imports Main
begin

subsection "3.1 Arithmetic Expressions"

subsubsection "3.1.1 Syntax"
(*
Concrete syntax: strings.
    e.g., 2 + (z + 3)

convert the string into a tree for further processing

abstract syntax (tree): the nested structure of the object (two-dimensional trees),
    e.g., Plus (N 2) (Plus (V ''z'') (N 3))
*)

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

(* Isabelle strings require two single quotes on both ends, for example ''abc'' *)

(*
They are not same:
- Semantically Equivalece,
- Syncatically Equivalenct,
*)

subsubsection "3.1.2 Semantics"

(*
The value of all variables is recorded in the (program) state
The state is a function from variable names to values
*)

type_synonym val = int
type_synonym state = "vname => val"

fun aval :: "aexp => state => val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x.0)"
value "aval (Plus (N 3) (V ''x''))((\<lambda>x.  0) (''x'' := 7)) "

(*
the generic function update notation f (a := b) is used:
    the result is the same as f, except that it maps a to b:
        f (a := b) = (\<lambda>x. if x = a then b else f x )

"((\<lambda>x.0) (''x'' := 7))(''y'' := 3)" maps ''x'' to 7, ''y'' to 3
<''x'' := 7; ''y'' := 3>: which works for any number of variables, even for none: <> is syntactic sugar for \<lambda>x : 0.
*)

subsubsection "3.1.3 Constant Folding"

(*
constant folding:
- One of Program Optimization
- the replacement of constant subexpressions by their value.
*)

fun asimp_const :: "aexp => aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a1 a2) =
    (case (asimp_const a1, asimp_const a2) of
        (N n1, N n2) => N (n1 + n2) |
        (b1, b2) => Plus b1 b2)"

(* In the above declaration of function "asimp_const",
'b1' and 'b2' are simplified as 'asimp_const a1' and 'asimp_const a2' *)

(* `asimp_const` is correct, does not change the semantics, does not change the value of its argument *)
lemma "aval (asimp_const a) s = aval a s"
apply(induction a)
apply(auto split: aexp.split)
(* The split modifier is the hint to auto to perform a case split whenever it sees a case expression over aexp. *)
done

(* Plus (N 0) a and Plus a (N 0) should be replaced by a. *)
(*
Instead of extending asimp_const
we split the optimization process into two functions:
- one performs the local optimizations,
- the other traverses the term.
*)

fun plus :: "aexp => aexp => aexp" where
"plus (N i1) (N i2) = N(i1 + i2)" |
"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 a1 a2 = Plus a1 a2"

lemma aval_plus: "aval (plus a1 a2) s = aval a1 s + aval a2 s"
(* The proof is by induction on a1 and a2 using the computation induction rule for plus (plus:induct) *)
apply(induction rule: plus.induct)
apply(auto split: aexp.split)
done

(* Now we replace Plus by plus in a bottom-up manner throughout an expression *)
fun asimp:: "aexp => aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

(*
The new lemma is different from the previous lemma:
    lemma "aval (asimp_const a) s = aval a s"
, because this performs in bottom-up manner.
*)
lemma "aval (asimp a) s = aval a s"
apply(induction a)
apply(auto split: aexp.split)
(* sledgehammer *)
by (simp add: aval_plus)

subsubsection "3_1_Exercise"

(* Exercise 3.1 *)

(* checks that its argument does not contain a subexpression of the form Plus (N i) (N j ). *)
fun optimal :: "aexp => bool" where
"optimal (N n) = True" |
"optimal (V x) = True" |
"optimal (Plus (N i) (N j)) = False" |
"optimal (Plus a b) = ((optimal a) \<and> (optimal b))"

lemma "optimal (asimp_const a)"
apply(induction a)
apply(auto split: aexp.split)
done

(* Exercise 3.2 *)

(* datatype classedAexp = Natural aexp | OnlyVariables aexp | Operation aexp aexp *)
(* From the following definitions, I produce the unexpected cases in the below convertClassedAexpToAexp.
To exclude OnlyVariables and Operation from `Natural {hoge}`.
 *)

 datatype classedAexp = Natural int | OnlyVariables aexp | Operation aexp int

(* Fundamental View:
- collect (N n) to separate from (V x)
- Set it is not needed to change the fomula in the Plus A B when A and B are consists of Variables
*)
(* to set (N n) at the latest of the formula *)
fun convertClassedAexpToAexp :: "classedAexp => aexp" where
"convertClassedAexpToAexp (Natural n) = N n" |
"convertClassedAexpToAexp (OnlyVariables x) = x" |
"convertClassedAexpToAexp (Operation e1 n) = Plus e1 (N n)"

fun fullPlusNatural :: "int => classedAexp => classedAexp" where
"fullPlusNatural n cexp =
 (if n = 0
  then cexp
  else case cexp of
    Natural m => Natural (n + m) |
    OnlyVariables e => Operation e n |
    Operation e1 m => Operation e1 (n + m)
  )"
    (*
    In order to prove lemma aval_fullPlusNatural
    To exclude some of V cases from `OnlyVariables {hoge}`
    OnlyVariables (V x) => Operation (V x) n | *)

fun full_asimp2 :: "aexp => classedAexp" where
"full_asimp2 (N n) = Natural n" |
"full_asimp2 (V x) = OnlyVariables (V x)" |
"full_asimp2 (Plus a b) =
    (case (full_asimp2 a, full_asimp2 b) of
        (Natural n, e) => fullPlusNatural n e |
        (e, Natural m) => fullPlusNatural m e |
        (OnlyVariables x, OnlyVariables y) => OnlyVariables (Plus x y) |
        (OnlyVariables x, (Operation e2 n)) => Operation (Plus x e2) n |
        ((Operation e1 n), OnlyVariables y) => Operation (Plus e1 y) n |
        ((Operation e1 n), (Operation e2 m)) => Operation (Plus e1 e2) (n + m)
    )"

fun full_asimp1 :: "aexp => aexp" where
"full_asimp1 exp = convertClassedAexpToAexp (full_asimp2 exp)"

lemma aval_fullPlusNatural: "aval (convertClassedAexpToAexp(fullPlusNatural n e)) s = n + (aval (convertClassedAexpToAexp e) s)"
apply(induction e)
apply(auto split: classedAexp.split)
done

lemma "aval (full_asimp1 e) s = aval e s"
(* apply(induction rule: full_asimp1.induct) *)
apply(induction e)
apply(auto split: classedAexp.split)
done

(* From the following stash, I implement the above the classified datatype*)
(* The following texts are stash. It produces only insane subgols *)
(* to set (N n) at the latest of the formula *)
(* fun fullPlusNatural :: "int => aexp => aexp" where
"fullPlusNatural n e =
 (if n = 0
  then e
  else case e of
    N m => N (n + m) |
    V x => Plus (V x) (N n) |
    Plus (V x) (V y) => Plus (Plus (V x) (V y)) (N n) |
    Plus e1 (N m) => Plus e1 (N (n + m)) |
    Plus e1 e2 => Plus (Plus e1 e2) (N n)
  )"

value "fullPlusNatural 3 (Plus (N 2) (V x))"

fun full_asimp2 :: "aexp => aexp" where
"full_asimp2 (N n) = N n" |
"full_asimp2 (V x) = V x" |
"full_asimp2 (Plus a b) =
    (case (full_asimp2 a, full_asimp2 b) of
        (N n, e) => fullPlusNatural n e |
        (e, N m) => fullPlusNatural m e |
        (V x, V y) => Plus (V x) (V y)|
        (V x, (Plus e2 (N n))) => Plus (Plus (V x) e2) (N n)|
        ((Plus e1 (N n)), V y) => Plus (Plus e1 (V y)) (N n) |
        ((Plus e1 (N n)), (Plus e2 (N m))) => Plus (Plus e1 e2) (N(n + m)) |
        (e1, Plus e2 (V y)) => Plus (V y) (Plus e1 e2)|
        (e1, Plus (V x) e2) => Plus (V x) (Plus e1 e2) |
        (Plus e2 (V y), e1) => Plus (V y) (Plus e1 e2)|
        (Plus (V x) e2, e1) => Plus (V x) (Plus e1 e2)
    )" *)
(* Critical Problem is the following only contains variables:
e.g., Plus (V x) (Plus (V z) (V y)) *)
(* value "full_asimp2 (Plus (V x) (Plus (V z) (V y)))"
value "full_asimp2 (Plus (Plus (V z) (V y)) (V x) ) "

value "full_asimp2 (Plus(N 1) (Plus (V x ) (N 2)))"
value "full_asimp2 (Plus (N 1) (N 2))"
value "full_asimp2 (Plus (N 1) (Plus (V x) (N 2)))"
value "full_asimp2 (Plus (N 2) (Plus (V y) (V x)))"
(* "fullPlusNatural 2 (Plus (V y) (V x))" *)
(*  *)

value "full_asimp2 (Plus (V y) (Plus (V x) (N 2)))"
value "full_asimp2 (Plus (Plus(N 3)(V y)) (Plus (V x) (N 2)))"
value "full_asimp2 (Plus (N 3) (Plus (Plus (V x) (Plus (V y) (N 2) )) (V z)))"
value "full_asimp2 (Plus (N 1) (Plus (Plus (N 2) (V x)) (V y)))"

value "full_asimp2 (Plus (N 1) (Plus (Plus (V y) (V x)) (N 2)))"
(* value "full_asimp2 (Plus (N 1) (Plus (Plus (Plus (V x) (V y)) (N 3)) (N 2)))" *)
(* "fullPlusNatural 1 (fullPlusNatural 2 (Plus (V y) (V x)))" *)
value "full_asimp2 (Plus (Plus (Plus (V y) (V x)) (N 2)) (N 1))"
(* "full_asimp2 (Plus (Plus (Plus (V y) (V x)) (N 2)) (N 1))" *)
 *)

(* lemma aval_fullPlusNatural: "aval (fullPlusNatural n e) s = n + (aval e s)"
apply(induction rule: fullPlusNatural.induct)
sledgehammer *)

 (* 2.

       aval x31 s + s x2 = aval a s \<Longrightarrow>
       s x2a = aval b s \<Longrightarrow>
       full_asimp2 b = V x2a \<Longrightarrow>
       full_asimp2 a = Plus x31 (V x2) \<Longrightarrow> aval undefined s = aval a s + aval b s

 *)

fun subst :: "vname => aexp => aexp => aexp" where
"subst x a (N n) = N n" |
"subst x a (V y) = (if (x = y) then a else (V y))" |
"subst x a (Plus e1 e2) = Plus (subst x a e1) (subst x a e2)"

value "subst ''x'' (N 3) (Plus (V ''x'') (V ''y'')) = Plus (N 3) (V ''y'')"

lemma substitution_lemma: "aval (subst x a e) s = aval e (s (x := aval a s))"
apply(induction e)
apply(auto)
done

lemma aval_uniq: "aval a1 s = aval a2 s ==> aval (subst x a1 e) s = aval (subst x a2 e) s "
apply(induction e)
apply(auto)
done

(* Exercise 3.5. *)
datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | PIncr vname | Division aexp2 aexp2

fun get_first :: "val \<times> state \<Rightarrow> val" where
"get_first (a, s) = a"

fun get_first_withOption :: "(val \<times> state)option \<Rightarrow> val option" where
"get_first_withOption None = None" |
"get_first_withOption (Some x) = Some(get_first(x))"

fun get_last :: "val \<times> state \<Rightarrow> state" where
"get_last (a, s) = s"

(* operationPlusWithNoneとoperationDivWithNoneとは共通化できそう
-> operationWithOptionを作った *)
fun operationPlusWithNone :: "(val \<times> state) option => (val \<times> state) option => (val \<times> state) option" where
"operationPlusWithNone a None = None" |
"operationPlusWithNone None b = None" |
"operationPlusWithNone (Some x) (Some y) = Some (get_first(x) + get_first(y), get_last(y))"

fun operationDivWithNone :: "(val \<times> state) option => (val \<times> state) option => (val \<times> state) option" where
"operationDivWithNone a None = None" |
"operationDivWithNone None b = None" |
"operationDivWithNone (Some x) (Some y) = Some (get_first(x) div get_first(y), get_last(y))"
(*
fun aval2 :: "aexp2 => state => (val \<times> state) option" where
"aval2 (N n) s = (n, s)" |
"aval2 (V x) s = (s x, s)" |
"aval2 (PIncr x) s = (s x, s(x := (s x + 1)))" |
"aval2 (Plus a b) s = ((get_first(aval2 a s) + get_first(aval2 b s)), get_last(aval2 b s)) "

    (* (if (aval2 a s) = None then (if (aval2 b s) = None then None else get_first())) *)
*)
fun aval2 :: "aexp2 => state => (val \<times> state) option" where
"aval2 (N2 n) s = Some(n, s)" |
"aval2 (V2 x) s = Some(s x, s)" |
"aval2 (PIncr x) s = Some(s x, s(x := (s x + 1)))" |
"aval2 (Plus2 a b) s = operationPlusWithNone (aval2 a s) (aval2 b s)" |
"aval2 (Division a b) s = (if (get_first_withOption(aval2 b s) = Some(0)) then None else (operationDivWithNone (aval2 a s) (aval2 b s)))"
(*
Type unification failed: Clash of types "_ option" and "_ \<times> _"

Type error in application: incompatible operand type

Operator:  get_first :: int \<times> (char list \<Rightarrow> int) \<Rightarrow> int
Operand:   aval2 a s :: (int \<times> (char list \<Rightarrow> int)) option
*)

value "aval2 (N2 2) (\<lambda> x. 1)"
value "aval2
  (Plus2
    (N2 2) (N2 1))
   (\<lambda> x. 1)"

value "aval2
  (Plus2
    (PIncr ''x'')
    (Plus2
      (PIncr ''x'')
      (Division
        (PIncr ''x'')
        (N2 2))))
  (\<lambda> x. 2)"

value "aval2
  (Plus2
    (PIncr ''x'')
    (Plus2
      (PIncr ''x'')
      (Division
        (PIncr ''x'')
        (N2 0))))
  (\<lambda> x. 2)"

fun operationWithOption ::  "(int => int => int) => (val \<times> state) option => (val \<times> state) option => (val \<times> state) option" where
"operationWithOption f a None = None" |
"operationWithOption f None b = None" |
"operationWithOption f (Some x) (Some y)  = Some (f (get_first x) (get_first y), get_last(y))"

fun aval2WithOption :: "aexp2 => state => (val \<times> state) option" where
"aval2WithOption (N2 n) s = Some(n, s)" |
"aval2WithOption (V2 x) s = Some(s x, s)" |
"aval2WithOption (PIncr x) s = Some(s x, s(x := (s x + 1)))" |
"aval2WithOption (Plus2 a b) s = operationWithOption (+) (aval2 a s) (aval2 b s)" |
"aval2WithOption (Division a b) s = (if (get_first_withOption(aval2 b s) = Some(0)) then None else (operationWithOption (div) (aval2 a s) (aval2 b s)))"

value "aval2WithOption
  (Plus2
    (PIncr ''x'')
    (Plus2
      (PIncr ''x'')
      (Division
        (PIncr ''x'')
        (N2 2))))
  (\<lambda> x. 2)"

value "aval2WithOption
  (Plus2
    (PIncr ''x'')
    (Plus2
      (PIncr ''x'')
      (Division
        (PIncr ''x'')
        (N2 0))))
  (\<lambda> x. 2)"

(* Exercise 3.6. *)

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp => state => int" where
"lval (Nl n) s = n" |
"lval (Vl x) s = s x" |
"lval (Plusl la lb) s = (lval la s) + (lval lb s)" |
"lval (LET x la lb) s = lval lb (s(x := (lval la s)))"
(* かっこの数の問題だった *)

(*
これまでのNに対して、適切に名前を変えてやらないといけない
Operator:  (=) (inline (Nl n)) :: aexp \<Rightarrow> bool
Operand:   aexp2.N n :: aexp2

as same as V
Operator:  (=) (inline (Vl x)) :: aexp \<Rightarrow> bool
Operand:   aexp2.V x :: aexp2
*)
fun inline :: "lexp => aexp" where
"inline (Nl n) = (N n)" |
"inline (Vl x) = (V x)" |
"inline (Plusl la lb) = (Plus (inline la) (inline lb))" |
"inline (LET x la lb) = subst x (inline la) (inline lb)"

(* HINT: arbitrary:sを付けると、sledgehammerが通る *)
lemma "aval (inline e) s = lval e s"
apply(induction e arbitrary: s)
apply(auto split:lexp.split)
(* sledgehammer *)
by (simp add: substitution_lemma)

subsection "3.2 Boolean Expressions"

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

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

subsubsection "3.2.1 Constant Folding"

(* define optimizing versions of the constructors *)

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

(* Outer syntax error\<^here>: name expected,
but keyword and\<^here> was found *)
fun "and" :: "bexp => bexp => bexp" where
"and (Bc True) b = b" |
"and b (Bc True) = b" |
"and (Bc False) b = Bc False" |
"and b (Bc False) = Bc False" |
"and b1 b2 = And b1 b2"

fun less :: "aexp => aexp => bexp" where
"less (N n1) (N n2) = Bc (n1 < n2)" |
"less a1 a2 = Less a1 a2"

(* replace the constructors in a bottom-up manner: *)

fun bsimp :: "bexp => bexp" where
"bsimp (Bc v) = Bc v" |
"bsimp (Not b) = not (bsimp b)" |
"bsimp (And b1 b2) = and (bsimp b1) (bsimp b2)" |
"bsimp (Less a1 a2) = less (asimp a1) (asimp a2)"

subsubsection "Exercises"

(* Exercise 3.7. *)

fun Eq :: "aexp => aexp => bexp" where
"Eq a1 a2 = And (Not (Less a1 a2)) (Not (Less a2 a1))"

lemma "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
apply(auto)
done

fun Le :: "aexp => aexp => bexp" where
"Le a1 a2 = Not (Less a2 a1)"

lemma "bval (Le a1 a2) s = (aval a1 s \<le> aval a2 s)"
apply(auto)
done

(* Exercise 3.8. *)

(* an alternative type of boolean expressions *)

datatype ifexp = Bc2 bool | If ifexp ifexp ifexp | Less2 aexp aexp

(* First define an evaluation function *)
fun ifval :: "ifexp => state => bool" where
"ifval (Bc2 v) s = v" |
"ifval (If i1 i2 i3) s = (if (ifval i1 s) then (ifval i2 s) else (ifval i3 s))" |
"ifval (Less2 a1 a2) s = (aval a1 s < aval a2 s)"

(* A \land B \equiv A \supset B /\ \neg A \supset \bottom *)
fun b2ifexp :: "bexp => ifexp" where
"b2ifexp (Bc v) = Bc2 v" |
"b2ifexp (Not b) = (If (b2ifexp b) (Bc2 False) (Bc2 True))" |
"b2ifexp (And b1 b2) = (If (b2ifexp b1) (b2ifexp b2) (Bc2 False) )" |
"b2ifexp (Less a1 a2) = Less2 a1 a2"

fun if2bexp :: "ifexp => bexp" where
"if2bexp (Bc2 v) = Bc v" |
"if2bexp (If i1 i2 i3) = And (Not (And (if2bexp i1) (Not (if2bexp i2)))) (Not (And (Not (if2bexp i1)) (Not (if2bexp i3))))" |
"if2bexp (Less2 a1 a2) = Less a1 a2"

lemma "bval b s = ifval (b2ifexp b) s"
apply(induction b)
apply(auto)
done

lemma "ifval b s = bval (if2bexp b) s"
apply(induction b)
apply(auto)
done

(* Exercise 3.9. *)

datatype pbexp = VAR vname | NOT pbexp | AND pbexp pbexp | OR pbexp pbexp

fun pbval :: "pbexp => (vname => bool) => bool" where
"pbval (VAR x ) s = s x" |
"pbval (NOT b) s = (\<not> pbval b s)" |
"pbval (AND b1 b2) s = (pbval b1 s \<and> pbval b2 s)" |
"pbval (OR b1 b2) s = (pbval b1 s \<or> pbval b2 s)"

(* expression is in NNF (negation normal form)
if NOT is only applied directly to VARs
*)
fun is_nnf :: "pbexp => bool" where
"is_nnf (VAR X) = True" |
"is_nnf (NOT (VAR X)) = True" |
"is_nnf (NOT y) = False" |
"is_nnf (AND b1 b2) = (is_nnf b1 \<and> is_nnf b2)" |
"is_nnf (OR b1 b2) = (is_nnf b1 \<and> is_nnf b2)"

 (* that converts a pbexp into NNF by pushing NOT inwards as much as possible. *)
fun nnf :: "pbexp => pbexp" where
"nnf (VAR x) = VAR x" |
"nnf (NOT (VAR x)) = NOT (VAR x)" |
"nnf (NOT (NOT a)) = nnf a" |
"nnf (NOT (OR a b)) = AND (nnf (NOT a)) (nnf(NOT b))" |
"nnf (NOT (AND a b)) = OR (nnf (NOT a)) (nnf(NOT b))" |
"nnf (AND a b) = AND (nnf a) (nnf b)" |
"nnf (OR a b) = OR (nnf a) (nnf b)"

(* Prove that nnf preserves the value (pbval (nnf b) s = pbval b s) and
nnfが保存するのだから、nnfに関するinductでいいやろ。

returns an NNF (is_nnf (nnf b)) *)
lemma "pbval (nnf b) s = pbval b s"
apply(induction b rule: nnf.induct)
apply(auto)
done

lemma "is_nnf (nnf b)"
apply(induction b rule: nnf.induct)
apply(auto)
done

(*
DNF (disjunctive normal form)
if it is in NNF and
if no OR occurs below an AND.
*)

(* Define a corresponding test is_dnf :: pbexp => bool. *)
(*
"is_not_the_form_and_or (AND (OR a b) c) = False" |
"is_not_the_form_and_or (AND a (OR b c)) = False" |
この部分は共通化させたいですね。
*)

fun is_not_the_form_and_or :: "pbexp => bool" where
"is_not_the_form_and_or (VAR x) = True"|
"is_not_the_form_and_or (NOT y) = True" |
"is_not_the_form_and_or (OR a b) = (is_not_the_form_and_or a \<and> is_not_the_form_and_or b)" |
"is_not_the_form_and_or (AND (OR a b) c) = False" |
"is_not_the_form_and_or (AND a (OR b c)) = False" |
"is_not_the_form_and_or (AND a b) =  (is_not_the_form_and_or a \<and> is_not_the_form_and_or b)"

fun is_dnf :: "pbexp => bool" where
"is_dnf e = (is_nnf e \<and> is_not_the_form_and_or e)"

(* Define a conversion function dnf_of_nnf :: pbexp => pbexp from NNF to DNF. *)

(* converts an NNF into a DNF (is_nnf b => is_dnf (dnf_of_nnf b)).の証明でとんでもないケースになったので、
単純化のためにmk_dnf_conjを導入 *)
fun mk_dnf_conj :: "pbexp \<Rightarrow> pbexp \<Rightarrow> pbexp" where
"mk_dnf_conj e (OR a b) = OR (mk_dnf_conj e a) (mk_dnf_conj e b)" |
"mk_dnf_conj (OR a b) e  = OR (mk_dnf_conj a e) (mk_dnf_conj b e)" |
"mk_dnf_conj x  y  = AND x y"

lemma mk_dnf_preserv : "pbval (mk_dnf_conj a b) s = (pbval a s \<and> pbval b s)"
  apply(induction a b rule: mk_dnf_conj.induct)
  apply(auto)
  done

lemma mk_dnf_is_nnf: "is_nnf a ==>
           is_nnf b ==>
           is_nnf (mk_dnf_conj  a  b)"
  apply(induction a b rule:  mk_dnf_conj.induct)
  apply(auto)
  done

fun dnf_of_nnf :: "pbexp => pbexp" where
"dnf_of_nnf (VAR x) = VAR x" |
"dnf_of_nnf (NOT a) = NOT a" |
"dnf_of_nnf (OR a b) = OR (dnf_of_nnf a) (dnf_of_nnf b)" |
"dnf_of_nnf (AND a b) =  mk_dnf_conj (dnf_of_nnf a) (dnf_of_nnf b)"
(* "dnf_of_nnf (AND (OR a b) c) =  AND (OR (dnf_of_nnf a) (dnf_of_nnf b)) c" |
"dnf_of_nnf (AND a (OR b c)) =  AND a (OR (dnf_of_nnf b) (dnf_of_nnf c))" |
"dnf_of_nnf (AND a b) =  AND (dnf_of_nnf a) (dnf_of_nnf b)"   *)

(* Prove that your function preserves the
value (pbval (dnf_of_nnf b) s = pbval b s)  *)

lemma dnf_preserv_pbval:"pbval (dnf_of_nnf b) s = pbval b s"
apply(induction b rule:dnf_of_nnf.induct)
apply(auto)
(* sledgehammer *)
(* apply (simp add: mk_dnf_preserv)
(* sledgehammer *)
using mk_dnf_preserv apply blast
sledgehammer *)
apply (simp_all add: mk_dnf_preserv)
done

(* and converts an NNF into a DNF (is_nnf b => is_dnf (dnf_of_nnf b)). *)

lemma mk_dnf_is_dnf: "is_dnf a ==>
           is_dnf b ==>
           is_dnf (mk_dnf_conj a  b)"
  apply(induction a b rule:  mk_dnf_conj.induct)
  apply(auto)
  (* sledgehammer *)
  (* apply (simp_all add: mk_dnf_is_nnf)
  sledgehammer *)
  done

lemma "is_nnf b ==> is_dnf (dnf_of_nnf b)"
apply(induction b rule:dnf_of_nnf.induct)
apply(auto)
(* sledgehammer *)
apply (simp_all add: mk_dnf_is_nnf)
(* sledgehammer *)
using mk_dnf_is_dnf by auto

subsubsection "3.3 Stack Machine and Compilation"
(* a simple stack machine and compiler for arithmetic expressions. *)
datatype instr = LOADI val | LOAD vname | ADD

(*
- LOADI n : (Load Immediate) puts n on top of the stack,
- LOAD x : puts the value of x on top of the stack, and
- ADD : replaces the two topmost elements of the stack by their sum
*)

type_synonym stack = "val list"
(* The top of the stack is its first element, the head of the list. *)

(* Addで、
stackが空の場合と、要素が1つの場合のみの場合についての定義はなされていないが
大丈夫だろうか？
Missing patterns in function definition:
\<And>b. exec1 ADD b [] = undefined
\<And>b v. exec1 ADD b [v] = undefined

-> A stack underflow
*)
fun exec1 :: "instr => state => stack => stack" where
"exec1 (LOADI n) _ stk = n # stk" |
"exec1 (LOAD x) s stk = s(x) # stk" |
"exec1 ADD _ (j # i # sdk) = (i + j) # sdk"

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

(* The simplicity of this definition is due to the absence of jump instructions. *)
(* Forward jumps could still be accommodated, but backward jumps would cause a serious problem:
execution might not terminate.
*)

(* Compilation of arithmetic expressions *)
fun comp :: "aexp => instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e1 e2) = comp e1 @ comp e2 @ [ADD]"

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

lemma "exec (comp a) s stk = aval a s # stk"
apply(induction a arbitrary:stk)
apply(auto)
(*  1. \<And>e1 e2.
       exec (ConcreteSemantics3.comp e1) s stk = aval e1 s # stk \<Longrightarrow>
       exec (ConcreteSemantics3.comp e2) s stk = aval e2 s # stk \<Longrightarrow>
       exec (ConcreteSemantics3.comp e1 @ ConcreteSemantics3.comp e2 @ [ADD]) s
        stk =
       (aval e1 s + aval e2 s) # stk *)
(* sledgehammer *)
 by (simp add: exec_division)

subsubsection "Exercises"

(* Exercise 3.10. *)
(* A stack underflow *)
fun exec2 :: "instr => state => stack => stack option" where
"exec2 (LOADI n) _ stk = Some (n # stk)" |
"exec2 (LOAD x) s stk = Some (s(x) # stk)" |
"exec2 ADD _ (j # i # sdk) = Some ((i + j) # sdk)" |
"exec2 Add _ _ = None"

fun mexec:: "instr list => state => stack => stack option " where
"mexec [] _ stk = Some(stk)" |
"mexec (i#is) s stk =
          (case (exec2 i s stk) of Some stk' => mexec is s stk' |
                                  None => None)"

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

(*
mexec (mcomp a1 @ mcomp a2 @ [ADD]) s stk = Some ((aval a1 s + aval a2 s) # stk)
Some ((aval a11 s + aval a2 s) # stk)) \<Longrightarrow>
       (\<And>stk. mexec (mcomp a12 @ mcomp a2 @ [ADD]) s stk =
              Some ((aval a12 s + aval a2 s) # stk)) \<Longrightarrow>
       mexec (mcomp a11 @ mcomp a12 @ ADD # mcomp a2 @ [ADD]) s stk =
       Some ((aval a11 s + aval a12 s + aval a2 s) # stk)
*)
(*
"mexec (mcomp a1) s stk = Some (aval a1 s # stk) ==> mexec (mcomp a1 @ mcomp a2 @ [ADD]) s stk = Some ((aval a1 s + aval a2 s) # stk)"
*)
lemma mexec_division: "mexec a1 s stk = Some stk' ==> mexec (a1 @ a2) s stk = mexec a2 s stk'"
apply(induction a1 arbitrary: stk)
apply(auto)
(* sledgehammer *)
by (metis option.case_eq_if option.discI)

(*
 1. \<And>a1 a2 stk.
       (\<And>stk. mexec (mcomp a1) s stk = Some (aval a1 s # stk)) \<Longrightarrow>
       (\<And>stk. mexec (mcomp a2) s stk = Some (aval a2 s # stk)) \<Longrightarrow>
       mexec (mcomp a1 @ mcomp a2 @ [ADD]) s stk =
       Some ((aval a1 s + aval a2 s) # stk)
*)
lemma "mexec (mcomp a) s stk = Some(aval a s # stk)"
apply(induction a arbitrary:stk)
apply(auto)
 by (simp add: mexec_division)

(* Exercise 3.11. *)

type_synonym reg = nat

datatype Rinstr = LDI int reg | LD vname reg | ADD reg reg
(* Instruction LDI i r loads i into register r, *)
(* LD x r loads the value of x into register r *)
(* ADD r 1 r 2 adds register r 2 to register r 1. *)

(* Define the execution of an instruction given a state and a register state *)
fun Rexec1 :: "Rinstr => state => (reg => int) => reg => int" where
"Rexec1 (LDI i r) _ f = f(r := i)" |
"Rexec1 (LD x r) s f = f(r := s(x))" |
"Rexec1 (ADD r1 r2) _ f = f(r1 := (f r1) + (f r2))"

(* Define the execution exec of a list of instructions as for the stack machine *)
fun Rexec :: "Rinstr list => state => (reg => int) => reg => int" where
"Rexec [] _ f = f" |
"Rexec (r#rs) s f = Rexec rs s (Rexec1 r s f)"

(*
大体、リストを扱うんだったら、部分リストに対しての証明をしたほうがいいと思う
*)

lemma Rexec_division : "Rexec (rs1 @ rs2) s f r = Rexec rs2 s (Rexec rs1 s f) r"
apply(induction rs1 arbitrary: s f)
apply(auto)
done

(* The compiler takes an arithmetic expression `a` and a register `r` and produces
a list of instructions whose execution places the value of a into `r` *)
(* The registers > r should be used in a stack-like fashion for intermediate results,
the ones < r should be left alone. *)
(* Define the compiler and prove it correct:
exec (comp a r ) s rs r = aval a s. *)

fun Rcomp :: "aexp => reg => Rinstr list" where
"Rcomp (N n) r = [LDI n r]" |
"Rcomp (V x) r = [LD x r]" |
"Rcomp (Plus e1 e2) r = (Rcomp e1 r) @ (Rcomp e2 (r + 1)) @ [ADD r (r + 1)]"
(* "Rcomp (Plus e1 e2) r = (Rcomp e1 r) @ (Rcomp e2 r) @ [ADD r r]"
e1とe2のregister先は異なることが望まれる
なぜなら、"Rexec1 (ADD r1 r2) _ f = f(r1 := (f r1) + (f r2))"
そして、和はStack Likeであるから
The registers > r should be used in a stack-like fashion for intermediate results,
*)

(* 感覚でやってるとarbitraryの取り方すらわからなくなるから、先に証明のイメージを掴もう *)
lemma register_should_be_left_alone: "r1 < r2 ==> Rexec (Rcomp a r2) s f r1 = f r1"
apply(induction a arbitrary: f r2)
apply(auto simp add: Rexec_division)
(* sledgehammer *)
done

(*
 1. \<And>a1 a2 r rs.
       (\<And>r rs. Rexec (Rcomp a1 r) s rs r = aval a1 s) \<Longrightarrow>
       (\<And>r rs. Rexec (Rcomp a2 r) s rs r = aval a2 s) \<Longrightarrow>
       Rexec (Rcomp a1 r @ Rcomp a2 (Suc r) @ [Rinstr.ADD r (Suc r)]) s rs r =
       aval a1 s + aval a2 s
*)

lemma "Rexec (Rcomp a r) s rs r = aval a s"
apply(induction a arbitrary: r rs)
apply(auto simp add: Rexec_division)
(* sledgehammer *)
by (simp add: register_should_be_left_alone)

(* Exercise 3.12. *)

datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg

(* All instructions refer implicitly to register 0 as the source (MV0) or target (all others) *)
(* 継続っぽい感じの実装だな *)
fun Mexec1 :: "instr0 => state => (reg => int) => reg => int" where
"Mexec1 (LDI0 i) _ f = f(0 := i)" |
"Mexec1 (LD0 x) s f = f(0 := s(x))" |
"Mexec1 (MV0 r) _ f = f(r := f 0)" |
"Mexec1 (ADD0 r) _ f = f(0 := (f 0) + (f r))"

(* Define the execution exec of a list of instructions as for the stack machine *)
fun Mexec :: "instr0 list => state => (reg => int) => reg => int" where
"Mexec [] _ f = f" |
"Mexec (r#rs) s f = Mexec rs s (Mexec1 r s f)"

(* Define a compiler pretty much as explained above except that
the compiled code leaves the value of the expression in register 0 *)

(* リストを扱うので慣習としてdivisionの証明 *)

lemma Mexec_division : "Mexec (rs1 @ rs2) s f r = Mexec rs2 s (Mexec rs1 s f) r"
apply(induction rs1 arbitrary: s f)
apply(auto)
done

(* 足し算は、結構面倒
rに結果が突っ込まれることを考えて
r + 1でe1のCommpileしたら、
それは0に入っているから
それをr に移して、
r + 2でe2のCommpileをしたら、
それは0に入っているから
それをr と合わせたら、結果が得られる。
*)
fun Mcomp :: "aexp => reg => instr0 list" where
"Mcomp (N n) _ = [LDI0 n]" |
"Mcomp (V x) _ = [LD0 x]" |
"Mcomp (Plus e1 e2) r = Mcomp e1 (r + 1) @ [MV0 (r + 1)] @ Mcomp e2 (r + 2) @ [ADD0 (r + 1)]"

(* The registers > r should be used in a stack-like fashion for intermediate results,
the ones < r should be left alone. *)
lemma register_should_be_left_alone_exec0 : "0 < r1 ==> r1 < r2 ==> Mexec (Mcomp a r2) s f r1 = f r1"
apply(induction a arbitrary: r2 f)
apply(auto simp add: Mexec_division)
done

lemma "Mexec (Mcomp a r) s f 0 = aval a s"
apply(induction a arbitrary: r s f)
apply(auto simp add: Mexec_division )
(* sledgehammer *)
by (simp add: register_should_be_left_alone_exec0)

end