theory Linorder_Insts imports Main
begin

(* Instances of Linorder (built-in typeclass for linear orderings with a trichotomy law)
 * for several types, intended for use with Oalist *)

instantiation prod :: (linorder, linorder) linorder
begin

definition prod_lo_leq :
"p1 \<le> p2 =
  (fst p1 < fst p2 \<or>
  (fst p1 = fst p2 \<and> snd p1 \<le> snd p2))"

definition prod_lo_lt :
"p1 < p2 =
  (fst p1 < fst p2 \<or>
  (fst p1 = fst p2 \<and> snd p1 < snd p2))"

instance proof
  fix x y :: "('a * 'b)"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by(cases x; cases y; auto simp add:prod_lo_leq prod_lo_lt)
next
  fix x :: "('a * 'b)"
  show "x \<le> x"
    by(cases x; auto simp add:prod_lo_leq)
next
  fix x y z :: "('a * 'b)"
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by(cases x; cases y; cases z; auto simp add:prod_lo_leq)
next
  fix x y :: "('a * 'b)"
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by(cases x; cases y; auto simp add:prod_lo_leq prod_lo_lt)
next
  fix x y :: "('a * 'b)"
  show "x \<le> y \<or> y \<le> x"
    by(cases x; cases y; auto simp add:prod_lo_leq prod_lo_lt)
qed
end

fun list_lo_leq' ::
  "('a :: linorder) list \<Rightarrow> ('a :: linorder) list \<Rightarrow> bool" where
"list_lo_leq' [] _ = True"
| "list_lo_leq' (h#t) [] = False"
| "list_lo_leq' (h1#t1) (h2#t2) =
   (h1 < h2 \<or>
   (h1 = h2 \<and> list_lo_leq' t1 t2))"

fun list_lo_lt' ::
  "('a :: linorder) list \<Rightarrow> ('a :: linorder) list \<Rightarrow> bool" where
"list_lo_lt' [] [] = False"
| "list_lo_lt' [] (h#t) = True"
| "list_lo_lt' (h#t) [] = False"
| "list_lo_lt' (h1#t1) (h2#t2) =
   (h1 < h2 \<or>
   (h1 = h2 \<and> list_lo_lt' t1 t2))"

lemma list_lo_lt'_imp_leq' :
"list_lo_lt' l1 l2 \<Longrightarrow> list_lo_leq' l1 l2"
proof(induction l1 arbitrary: l2)
  case Nil
  then show ?case by auto
next
  case (Cons a l1)
  then show ?case
    by(cases l2; auto)
qed

lemma list_lo_lt'_nosym :
  "list_lo_lt' l1 l2 \<Longrightarrow> list_lo_lt' l2 l1 \<Longrightarrow> False"
proof(induction l1 arbitrary: l2)
  case Nil
  then show ?case by(cases l2; auto)
next
  case (Cons a l1)
  then show ?case by(cases l2; auto)
qed

lemma list_lo_lt'_irref :
  "list_lo_lt' l l \<Longrightarrow> False"
proof(induction l)
  case Nil
  then show ?case by auto
next
  case (Cons a l)
  then show ?case by auto
qed

lemma list_lo_leq'_lt'_or_eq :
  "list_lo_leq' l1 l2 \<Longrightarrow>
   list_lo_lt' l1 l2 \<or> l1 = l2"
proof(induction l1 arbitrary: l2)
  case Nil
  then show ?case by(cases l2; auto)
next
  case (Cons a l1)
  then show ?case
    by(cases l2; auto)
qed

instantiation list :: (linorder) linorder
begin

definition list_lo_leq :
"l1 \<le> l2 = list_lo_leq' l1 l2"

definition list_lo_lt :
"l1 < l2 = list_lo_lt' l1 l2"

instance proof
  fix x y :: "'a list"

  have L2R_1 : "x < y \<Longrightarrow> x \<le> y"
    unfolding list_lo_leq list_lo_lt using list_lo_lt'_imp_leq' by auto

  have L2R_2 : "x < y \<Longrightarrow> \<not> y \<le> x"
    unfolding list_lo_leq list_lo_lt
  proof
    assume HC1 : "list_lo_lt' x y"
    assume HC2 : "list_lo_leq' y x"

    consider (1) "list_lo_lt' y x" | (2) "x = y"
      using list_lo_leq'_lt'_or_eq[OF HC2]  by auto
    then show False
    proof cases
      case 1
      then show ?thesis using list_lo_lt'_nosym[OF HC1 1] by auto
    next
      case 2
      then show ?thesis using HC1 list_lo_lt'_irref[of x] by auto
    qed
  qed

  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)" using L2R_1 L2R_2 list_lo_leq'_lt'_or_eq[of x y]
    unfolding list_lo_leq list_lo_lt
    by(blast)
next
  fix x :: "'a list"
  show "x \<le> x"
  proof(induction x)
    case Nil
    then show ?case by(auto simp add:list_lo_leq)
  next
    case (Cons a x)
    then show ?case by(auto simp add:list_lo_leq)
  qed
next
  fix x y z :: "'a list"
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
  proof(induction x arbitrary: y z)
    case Nil
    then show ?case by(auto simp add:list_lo_leq)
  next
    case (Cons a x)
    then show ?case
      by(cases y; cases z; auto simp add:list_lo_leq)
  qed
next
  fix x y :: "'a list"
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
  proof(induction x arbitrary: y)
    case Nil
    then show ?case by(cases y; auto simp add: list_lo_leq)
  next
    case (Cons a x)
    then show ?case by(cases y; auto simp add: list_lo_leq)
  qed
next
  fix x y :: "'a list"
  show "x \<le> y \<or> y \<le> x"
  proof(induction x arbitrary: y)
    case Nil
    then show ?case by(cases y; auto simp add: list_lo_leq)
  next
    case (Cons a x)
    then show ?case by(cases y; auto simp add: list_lo_leq)
  qed
qed
end

end


theory Unification
  imports Main
begin

section \<open> Assignment 1 \<close>

datatype ('f, 'v) "term" = Var 'v | Fun 'f "('f, 'v) term list"

text \<open> (a) \<close>

fun fv :: "(('f, 'v) term \<Rightarrow> 'v set)" where
  "fv (Var x) = { x }" |
  "fv (Fun f lst) = \<Union>(set (map fv lst))"

text \<open> (b) \<close>

type_synonym ('f, 'v) subst = "'v \<Rightarrow> ('f, 'v) term"

fun sapply :: "('f, 'v) subst \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) term"
  (infixr "\<cdot>" 67) where
    "sapply \<sigma> (Var x) = \<sigma> x" |
    "sapply \<sigma> (Fun f ts) = Fun f (map (sapply \<sigma>) ts)"

definition scomp :: "('f, 'v) subst \<Rightarrow> ('f, 'v) subst \<Rightarrow> ('f, 'v) subst"
  (infixr "\<circ>s" 75) where
    "(scomp \<sigma> \<tau>) x = sapply \<sigma> (\<tau> x)"

text \<open> (c) \<close>

lemma fv_sapply: "fv (\<sigma> \<cdot> t) = (\<Union> x \<in> fv t. fv (\<sigma> x))"
  apply(induction t rule: fv.induct)
  by(simp_all)

lemma sapply_cong: "\<lbrakk> \<And>x. x \<in> fv t \<Longrightarrow> \<sigma> x = \<tau> x \<rbrakk> \<Longrightarrow> \<sigma> \<cdot> t = \<tau> \<cdot> t"
  apply(induction t rule: fv.induct)
   apply(simp_all)
  by(blast)

lemma scomp_sapply: "(\<sigma> \<circ>s \<tau>)x = \<sigma> \<cdot> (\<tau> x)"
  by(simp add: scomp_def)

lemma sapply_scomp_distrib: "(\<sigma> \<circ>s \<tau>) \<cdot> t = \<sigma> \<cdot> (\<tau> \<cdot> t)"
  apply(induction t)
  by(simp_all add: scomp_def)

lemma scomp_assoc: "(\<sigma> \<circ>s \<tau>) \<circ>s \<rho> = \<sigma> \<circ>s (\<tau> \<circ>s \<rho>)"
  by(simp add: fun_eq_iff scomp_def sapply_scomp_distrib)

lemma sapply_Var[simp]: "Var \<cdot> t = t"
  apply(induction t)
  by(simp_all add: map_idI)

lemma scomp_Var[simp]: "\<sigma> \<circ>s Var = \<sigma>"
  by(simp add: fun_eq_iff scomp_def)

lemma Var_scomp[simp]: "Var \<circ>s \<sigma> = \<sigma>"
  by(simp add: fun_eq_iff scomp_def)

text \<open> (d) \<close>

definition sdom :: "('f, 'v) subst \<Rightarrow> 'v set" where
  "sdom \<sigma> = { x . (\<sigma> x) \<noteq> (Var x)}"

definition svran :: "('f, 'v) subst \<Rightarrow> 'v set" where
  "svran \<sigma> = \<Union>(fv ` (\<sigma> ` sdom \<sigma>))"

lemma sdom_Var[simp]: "sdom Var = {}"
  by(simp add: sdom_def)

lemma svran_Var[simp]: "svran Var = {}"
  by(simp add: svran_def)

lemma sdom_single_non_trivial[simp]:
  "t \<noteq> Var x \<Longrightarrow> sdom (Var( x := t )) = {x}"
  by(simp add: fun_upd_def sdom_def)

lemma svran_single_non_trivial[simp]:
  "t \<noteq> Var x \<Longrightarrow> svran (Var( x := t )) = fv t"
  by(simp add: fun_upd_def svran_def sdom_def)

lemma svapply_svdom_svran:
  "x \<in> fv (\<sigma> \<cdot> t) \<Longrightarrow> x \<in> (fv t - sdom \<sigma>) \<union> svran \<sigma>"
  apply(induction t)
   apply(simp_all add: svran_def sdom_def)
   apply(metis fv.simps(1) singletonD)
  by(blast)

lemma sdom_scomp: "sdom (\<sigma> \<circ>s \<tau>) \<subseteq> sdom \<sigma> \<union> sdom \<tau>"
  apply(simp add: sdom_def scomp_def)
  by(auto)

lemma svran_scomp: "svran (\<sigma> \<circ>s \<tau>) \<subseteq> svran \<sigma> \<union> svran \<tau>"
  apply(simp add: svran_def scomp_def fv_sapply sdom_def)
  by(force)

section \<open> Assignment 2 \<close>

text \<open> (a) \<close>

type_synonym ('f, 'v) equation = "('f, 'v) term \<times> ('f, 'v) term"
type_synonym ('f, 'v) equations = "('f, 'v) equation list"

definition fv_eq :: "('f, 'v) equation \<Rightarrow> 'v set" where
  "fv_eq eq = (fv (fst eq)) \<union> (fv (snd eq))"

fun fv_eqs :: "('f, 'v) equations \<Rightarrow> 'v set" where
  "fv_eqs [] = {}"
| "fv_eqs (eq#s) = (fv_eq eq) \<union> (fv_eqs s)"

lemma fv_eqs_U: "fv_eqs eqs = \<Union>(fv_eq ` set eqs)"
  apply(induction eqs)
  by simp_all

definition sapply_eq :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equation \<Rightarrow> ('f, 'v) equation"
  (infixr "\<cdot>e" 67) where
    "sapply_eq \<sigma> eq = (sapply \<sigma> (fst eq), sapply \<sigma> (snd eq))"

fun sapply_eqs :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equations \<Rightarrow> ('f, 'v) equations"
  (infixr "\<cdot>s" 67) where
    "sapply_eqs \<sigma> [] = []"
|   "sapply_eqs \<sigma> (eq#s) = (sapply_eq \<sigma> eq) # (sapply_eqs \<sigma> s)"

lemma sapply_eqs_map: "sapply_eqs \<sigma> eqs = map (sapply_eq \<sigma>) eqs"
  apply(induction eqs)
  by(simp_all)

lemma fv_sapply_eq: "fv_eq (\<sigma> \<cdot>e e) = (\<Union> x \<in> fv_eq e. fv (\<sigma> x))"
  by(simp add: fv_eq_def sapply_eq_def fv_sapply)

lemma fv_sapply_eqs: "fv_eqs (\<sigma> \<cdot>s s) = (\<Union> x \<in> fv_eqs s. fv (\<sigma> x))"
  apply(induction rule: sapply_eqs.induct)
   apply(simp)
  by(simp add: fv_sapply_eq)

lemma sapply_scomp_distrib_eq: "(\<sigma> \<circ>s \<tau>) \<cdot>e eq = \<sigma> \<cdot>e (\<tau> \<cdot>e eq)"
  by(simp add: sapply_eq_def sapply_scomp_distrib)

lemma sapply_scomp_distrib_eqs: "(\<sigma> \<circ>s \<tau>) \<cdot>s eqs = \<sigma> \<cdot>s (\<tau> \<cdot>s eqs)"
  apply(induction eqs)
   apply(simp)
  by(simp add: sapply_scomp_distrib_eq)

text \<open> (b) \<close>

definition unifies_eq :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equation \<Rightarrow> bool" where
  "(unifies_eq \<sigma> eq) \<longleftrightarrow> (\<sigma> \<cdot> (fst eq) = \<sigma> \<cdot> (snd eq))"

fun unifies :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equations \<Rightarrow> bool" where
  "(unifies \<sigma> []) = True"
| "(unifies \<sigma> (eq#s)) = ((unifies_eq \<sigma> eq) \<and> unifies \<sigma> s)"

lemma unifies_forall: "unifies \<sigma> lst = (\<forall>eq \<in> set lst . unifies_eq \<sigma> eq)"
  apply(induction lst)
  by(simp_all)

definition is_mgu :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equations \<Rightarrow> bool" where
  "(is_mgu \<sigma> eqs) = ((unifies \<sigma> eqs) \<and> (\<forall> \<tau>. (unifies \<tau> eqs) \<longrightarrow> (\<exists> \<rho> . \<tau> = \<rho> \<circ>s \<sigma>)))"

text \<open> (c) \<close>

lemma unifies_sapply_eq: "unifies_eq \<sigma> (\<tau> \<cdot>e eq) \<longleftrightarrow> unifies_eq (\<sigma> \<circ>s \<tau>) eq"
  by(simp add: sapply_eq_def unifies_eq_def sapply_scomp_distrib)

lemma unifies_sapply: "unifies \<sigma> (\<tau> \<cdot>s eqs) \<longleftrightarrow> unifies (\<sigma> \<circ>s \<tau>) eqs"
  apply(induction eqs)
  by(simp_all add: unifies_sapply_eq)

section \<open> Assignment 3 \<close>

text \<open> (a) \<close>

(*Termination definitions and lemmas*)
fun tsize :: "('f, 'v) term \<Rightarrow> nat" where
  "tsize (Var x) = 0"
| "tsize (Fun f l) = 1 + (fold (+) (map tsize l) 0)"

fun eqs_size_fst :: "('f, 'v) equations \<Rightarrow> nat" where
  "eqs_size_fst [] = 0"
| "eqs_size_fst ((t, _)#qs) = tsize t + eqs_size_fst qs"

(* equivalent to zip, but allows induction *)
fun term_zip :: "('f, 'v) term list \<Rightarrow> ('f, 'v) term list \<Rightarrow> (('f, 'v) term \<times> ('f, 'v) term) list" where
  "term_zip [] t1 = []"
| "term_zip t0 [] = []"
| "term_zip (h0#t0) (h1#t1) = (h0, h1) # (term_zip t0 t1)"

lemma term_swap_X1 [simp]:
  "card (fv_eq (Var x, Fun v va) \<union> fv_eqs s) = card (fv_eq (Fun v va, Var x) \<union> fv_eqs s)"
  by(simp add: fv_eq_def)

lemma fv_term_zip:
 "length l0 = length l1 \<Longrightarrow> (\<Union>x\<in>set (term_zip l0 l1). fv (fst x) \<union> fv (snd x)) = (\<Union> (fv ` set l0) \<union> \<Union> (fv ` set l1))"
  apply(induction l0 l1 rule: term_zip.induct)
    apply(simp_all)
  by blast

lemma term_fun_X1 [simp]:
  "length l0 = length l1 \<Longrightarrow> card (fv_eqs (term_zip l0 l1 @ s)) = card (fv_eq (Fun f0 l0, Fun f0 l1) \<union> fv_eqs s)"
  apply(induction l0 l1 rule: term_zip.induct)
  by(simp_all add: fv_eq_def fv_eqs_U fv_term_zip Un_assoc Un_left_commute)

lemma term_fun_X2 [simp]:
  "length l0 = length l1 \<Longrightarrow> eqs_size_fst (term_zip l0 l1 @ s) < Suc (fold (+) (map tsize l0) 0 + eqs_size_fst s)"
  apply(induction l0 l1 rule: term_zip.induct)
  by (simp_all add: fold_plus_sum_list_rev)

lemma term_simp_X1 [simp]:
  "t = Var x \<Longrightarrow> card (fv_eqs s) \<le> card (fv_eq (Var x, Var x) \<union> fv_eqs s)"
  by(simp add: fv_eq_def card_insert_le)

lemma set_elems_card:
  assumes "\<forall> v \<in> setA . v \<in> setB" and "x \<in> setB" and "x \<notin> setA" and "finite setB"
  shows "card setA < card setB"
proof-
  from assms have
    "setA \<subset> setB"
    by blast
  from this assms(4) show ?thesis by (simp add: psubset_card_mono)
qed

lemma fv_finite: "finite (fv t)"
  apply(induction t)
  by(simp_all)

lemma term_unify_X1 [simp]:
  assumes "x \<notin> fv t"
  shows "card (fv_eqs (Var(x := t) \<cdot>s s)) < card (fv_eq (Var x, t) \<union> fv_eqs s)"
proof-
  have
    "finite (fv_eq (Var x, t) \<union> fv_eqs s)"
    by(simp add: fv_eqs_U fv_eq_def fv_finite)
  moreover from assms have
    "x \<notin> fv_eqs (Var(x := t) \<cdot>s s)"
    by(simp add: fv_sapply_eqs)
  moreover have
    "x \<in> fv_eq (Var x, t) \<union> fv_eqs s"
    by(simp add: fv_eq_def)
  moreover have
    "\<forall> v \<in> fv_eqs (Var(x := t) \<cdot>s s) . v \<in> (fv_eq (Var x, t) \<union> fv_eqs s)"
    by(simp add: fv_sapply_eqs fv_eq_def)
  ultimately show ?thesis by (simp add: set_elems_card)
qed

(*Unification algorithm*)
fun scomp_opt :: "('f, 'v) subst option \<Rightarrow> ('f, 'v) subst \<Rightarrow> ('f, 'v) subst option"
  where
    "(scomp_opt None \<tau>) = None"
  | "(scomp_opt (Some \<sigma>) \<tau>) = Some (\<sigma> \<circ>s \<tau>)"

function (sequential) unify :: "('f, 'v) equations \<Rightarrow> ('f, 'v) subst option" where
  Base: "unify [] = Some Var"
| UnSi: "unify ((Var x, t)#s) = (if x \<notin> (fv t) then
        scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t))
      else
        if t = (Var x) then
          unify s
        else
          None)"
| Swap: "unify ((t, Var x)#s) = unify ((Var x, t)#s)"
| Fun:  "unify ((Fun f0 l0, Fun f1 l1)#s) = (
  if (f0 = f1) \<and> (length l0 = length l1) then
    unify ((term_zip l0 l1) @ s)
  else None)"
            apply pat_completeness
            by(simp_all)
termination
  apply(relation "measures[
    (\<lambda> eqs . card (fv_eqs eqs)),
    (\<lambda> eqs . eqs_size_fst eqs),
    (\<lambda> eqs . size eqs)
  ]")
  by(simp_all add: le_imp_less_or_eq)

text \<open> (b) \<close>

lemma fun_unifies: "\<lbrakk>length l0 = length l1; f0 = f1 \<rbrakk> \<Longrightarrow> unifies \<sigma> (term_zip l0 l1 @ s) = unifies \<sigma> ((Fun f0 l0, Fun f1 l1)#s)"
  apply(induction rule: term_zip.induct)
  by(simp_all add: unifies_eq_def)

lemma unifies_app: "unifies \<sigma> (l0 @ l1) \<Longrightarrow> unifies \<sigma> l0 \<and> unifies \<sigma> l1"
  by(simp add: unifies_forall)

lemma scomp_opt_fst: "scomp_opt (unify eqs) \<tau> = Some \<rho> \<Longrightarrow> \<exists> \<sigma> . unify eqs = Some \<sigma>"
  by(metis scomp_opt.elims)

lemma subst_redundancy: "x \<notin> fv t \<Longrightarrow> \<sigma> \<circ>s Var(x := t) \<circ>s Var(x := t) = \<sigma> \<circ>s Var(x := t)"
  by(simp only: fun_eq_iff; metis scomp_def fun_upd_apply sapply_cong scomp_Var scomp_assoc)

lemma unify_soundness_i: "unify eqs = Some \<sigma> \<Longrightarrow> unifies \<sigma> eqs"
  proof(induction arbitrary: \<sigma> rule: unify.induct)
    case 1
    then show ?case by simp
  next
    case (2 x t s)
    then show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
        case True
        then show ?thesis proof-
          from True 2(3) have opt:
            "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
            by simp
          then obtain \<sigma>p where sigp_unify:
            "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
            by fastforce
          from this opt have sig:
            "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
          moreover from sigp_unify True 2(1) have
            "unifies \<sigma>p (Var(x := t) \<cdot>s s)"
            by simp
          ultimately have
            "unifies \<sigma> s"
            by(simp add: unifies_sapply subst_redundancy scomp_assoc)
          moreover from sig True have
            "unifies_eq \<sigma> (Var x, t)"
            by (simp add: unifies_eq_def; metis fun_upd_apply sapply_cong scomp_Var scomp_sapply)
         ultimately show ?thesis by simp
        qed
      next
        case False
        then show ?thesis proof-
          from False 2(3) have
            "t = Var x"
            by fastforce
          moreover from this 2(3) have
            "unify s = Some \<sigma>"
            by simp
          ultimately show ?thesis using 2(2) by(simp add: unifies_eq_def)
        qed
      qed
    qed
  next
    case (3 v va x s)
    then show ?case by (simp add: unifies_eq_def)
  next
    case (4 f0 l0 f1 l1 s)
    then show ?case proof-
      from 4(2) have
        "(f0 = f1 \<and> length l0 = length l1) \<and> (unify (term_zip l0 l1 @ s) = Some \<sigma>)"
        by (simp; metis option.distinct(1))
      moreover from this 4(1) have
        "unifies \<sigma> (term_zip l0 l1 @ s)" by simp
      ultimately show ?thesis using 4(1) by(simp only: fun_unifies)
    qed
  qed

lemma unify_soundness_ii: "unify eqs = Some \<sigma> \<Longrightarrow>
  ((\<forall> \<tau>. (unifies \<tau> eqs) \<longrightarrow> (\<exists> \<rho> . \<tau> = \<rho> \<circ>s \<sigma>)))"
proof(induction eqs arbitrary: \<sigma> rule: unify.induct)
  case 1
  then show ?case by simp
next
    case (2 x t s)
    then show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
        case True
        then show ?thesis proof-
          from True 2(3) have
            "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
            by simp
          moreover from this obtain \<sigma>p where sigp_unify:
            "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
            by fastforce
          ultimately have sig:
            "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
          from sigp_unify True 2(1) have IS:
            "\<forall>\<tau>. unifies \<tau> (Var(x := t) \<cdot>s s) \<longrightarrow> (\<exists>\<rho>. \<tau> = \<rho> \<circ>s \<sigma>p)"
            by simp
          show ?thesis proof(rule allI)
            fix \<tau>
            show "unifies \<tau> ((Var x, t) # s) \<longrightarrow> (\<exists>\<rho>. \<tau> = \<rho> \<circ>s \<sigma>)"
            proof(rule impI)
              assume asm: "unifies \<tau> ((Var x, t) # s)"
              show "(\<exists>\<rho>. \<tau> = \<rho> \<circ>s \<sigma>)" proof-
                from asm have
                  "\<tau> x = \<tau> \<cdot> t" and "unifies \<tau> s"
                  by(simp_all add: unifies_eq_def)
                moreover from this True have t_def:
                  "\<tau> \<circ>s Var(x := t) = \<tau>"
                  by(simp add: fun_eq_iff scomp_sapply)
                ultimately have
                  "unifies \<tau> (Var(x := t) \<cdot>s s)"
                  by(simp add: unifies_sapply)
                from this IS obtain \<rho> where
                  "\<tau> = \<rho> \<circ>s \<sigma>p"
                  by blast
                hence
                  "\<tau> \<circ>s Var(x := t) = \<rho> \<circ>s \<sigma>p \<circ>s Var(x := t)"
                  by (simp add: scomp_assoc)
                from this t_def sig have
                  "\<tau> = \<rho> \<circ>s \<sigma>"
                  by auto
                then show ?thesis
                  by auto
              qed
            qed
          qed
        qed
      next
        case False
        then show ?thesis proof-
          from False 2(3) have
            "t = Var x"
            by fastforce
          moreover from this 2(3) have
            "unify s = Some \<sigma>"
            by simp
          ultimately show ?thesis using 2(2) by(simp add: unifies_eq_def)
        qed
      qed
    qed
next
  case (3 v va x s)
  then show ?case by (simp add: unifies_eq_def)
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof-
      fix \<tau>
      from 4(2) have
        "(f0 = f1 \<and> length l0 = length l1) \<and> (unify (term_zip l0 l1 @ s) = Some \<sigma>)"
        by(simp; metis option.distinct(1))
      moreover from this 4(1) have
        "\<forall>\<tau>. unifies \<tau> (term_zip l0 l1 @ s) \<longrightarrow> (\<exists>\<rho>. \<tau> = \<rho> \<circ>s \<sigma>)"
        by simp
      ultimately show ?thesis
        by (metis fun_unifies)
    qed
  qed

theorem unify_soundness: "unify eqs = Some \<sigma> \<Longrightarrow> is_mgu \<sigma> eqs"
  by(simp add: is_mgu_def unify_soundness_i unify_soundness_ii)

text \<open> (c) \<close>

(* in_term presents an alternative way to prove the lemma sapply_size *)

(*(* denotes whether the first term is contained in the second term*)
fun in_term :: "('f, 'v) term \<Rightarrow> ('f, 'v) term \<Rightarrow> bool"
  (infixr "tin" 67) where
  "in_term t (Var x) = (t = Var x)"
| "in_term t (Fun f l) = ((t = Fun f l) \<or> (\<exists> t0 \<in> set l . in_term t t0))"

lemma in_term_size: "\<lbrakk> t tin t0 \<rbrakk> \<Longrightarrow> tsize t \<le> tsize t0"
proof(induction t0 rule: in_term.induct)
  case (1 t x)
  then show ?case by simp
next
  case IS: (2 t f l)
  then show ?case proof-
    from IS(2) have "(t = Fun f l) \<or> (\<exists> t0 \<in> set l . in_term t t0)" by simp
    then consider "(t = Fun f l)" | "(\<exists> t0 \<in> set l . in_term t t0)" by blast
    then show ?case proof(cases)
      case 1
      then show ?thesis using IS by simp
    next
      case 2
      then show ?thesis proof-
        from 2 obtain t0 where t0l: "t0 \<in> set l" and tt0: "t tin t0"
          by auto
        from this IS(1) have
          "tsize t \<le> tsize t0"
          by blast
        moreover from t0l have
          "tsize t0 < tsize (Fun f l)"
          by(simp only: in_args_size)
        ultimately show ?thesis by simp
      qed
    qed
  qed
qed

lemma fv_in_term: "x \<in> fv t \<Longrightarrow> (Var x) tin t"
  by(induction t rule: term.induct; simp; auto)

lemma in_itself: "t tin t"
  apply(induction t)
  by simp_all

lemma in_term_sapply: "t tin t0 \<Longrightarrow> (\<sigma> \<cdot> t) tin (\<sigma> \<cdot> t0)"
  apply(induction t0 rule: term.induct)
   apply(simp add: in_itself)
  by(simp add: in_itself; auto)
*)

lemma fold_eq_sum_list: "(fold (+) (l :: nat list) 0) = (sum_list l)"
  apply(induction l)
  by (simp_all add: fold_plus_sum_list_rev)

lemma in_args_size:
  assumes "t0 \<in> set l"
  shows "tsize t0 < tsize (Fun f l)"
proof-
  from assms(1) have
    "tsize t0 \<in> set (map tsize l)"
    by simp
  moreover from this have
    "tsize t0 \<le> sum_list (map tsize l)"
    by(simp only: member_le_sum_list)
  moreover from this have
    "tsize t0 \<le> (fold (+) (map tsize l) 0)"
    by(simp add: fold_eq_sum_list)
  ultimately show ?thesis by simp
qed

lemma sapply_size: "\<lbrakk> x \<in> fv t; t \<noteq> Var x \<rbrakk> \<Longrightarrow> tsize (\<sigma> \<cdot> t) > tsize (\<sigma> x)"
proof(induction t)
  case (Var x)
  then show ?case by simp
next
  case (Fun x1a x2)
  then show ?case proof-
    from Fun(2) obtain x2a where
      x2a_in: "x2a \<in> set x2" and x2a_fv: "x \<in> fv x2a"
      by auto
    show ?thesis proof(cases "x2a = Var x")
      case True
      then show ?thesis proof-
        from True x2a_in have
          "\<sigma> x \<in> set (map ((\<cdot>) \<sigma>) x2)"
          by force
        from this in_args_size show ?thesis
          by fastforce
      qed
    next
      case False
      then show ?thesis proof-
        from Fun(1) x2a_in x2a_fv False have
          "tsize (\<sigma> x) < tsize (\<sigma> \<cdot> x2a)"
          by simp
        then show ?thesis
          by (metis (no_types, lifting) image_eqI in_args_size
              list.set_map order.strict_trans sapply.simps(2) x2a_in)
      qed
    qed
  qed
qed
(* Alternate proof using in_term *)
(*
proof-
  from assms(1) have
    "Var x tin t"
    by(simp only: fv_in_term)
  hence
    "(\<sigma> \<cdot> Var x) tin \<sigma> \<cdot> t"
    using in_term_sapply by fastforce
  hence sigx:
    "\<sigma> x tin \<sigma> \<cdot> t"
    by simp
  from assms obtain f l where t_def:
    "\<sigma> \<cdot> t = Fun f l"
    by (metis fv_in_term in_term.elims(2) sapply.simps(2))
  from this assms sigx obtain t0 where
    "t0 \<in> set l" and sigx_t0: "\<sigma> x tin t0"
    by (smt (z3) \<open>Var x tin t\<close> image_eqI in_term.elims(2) in_term_sapply list.set_map sapply.simps(1) sapply.simps(2) term.inject(2))
  from this t_def have
    "tsize (t0) < tsize (\<sigma> \<cdot> t)"
    by(simp only: in_args_size)
  moreover from sigx_t0 have
    "tsize (\<sigma> x) \<le> tsize t0"
    by(simp only: in_term_size)
  ultimately show ?thesis by simp
qed
*)

lemma case_occurs:
  assumes "x \<in> fv t" and "unifies \<sigma> ((Var x, t) # s)"
  shows "t = Var x"
proof(rule ccontr)
  assume cont: "t \<noteq> Var x"
  from cont assms(1) have
    "tsize (\<sigma> \<cdot> t) > tsize (\<sigma> x)"
    by (simp add: sapply_size)
  moreover from assms(2) have
    "tsize (\<sigma> \<cdot> t) = tsize (\<sigma> x)"
    by(simp add: unifies_eq_def)
  ultimately show False by simp
qed

lemma unifies_wf: "unifies_eq \<sigma> (Fun f0 l0, Fun f1 l1) \<Longrightarrow> f0 = f1 \<and> length l0 = length l1"
  by (simp add: unifies_eq_def; metis length_map)

lemma lemma2: "(\<exists> \<sigma> . unifies \<sigma> eqs) \<Longrightarrow> \<not> Option.is_none (unify eqs)"
proof(induction rule: unify.induct)
  case 1
  then show ?case by simp
next
    case (2 x t s)
    then show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
        case True
        then show ?thesis proof-
          from 2(3) obtain \<sigma> where si:
            "unifies \<sigma> ((Var x, t) # s)"
            by(rule exE)
          hence
            "\<sigma> x = \<sigma> \<cdot> t" and sig_s: "unifies \<sigma> s"
            by(simp_all add: unifies_eq_def)
          from this True have
            "\<sigma> \<circ>s Var(x := t) = \<sigma>"
            by (simp add: scomp_def ext)
          from this sig_s have
            "unifies \<sigma> (Var(x := t) \<cdot>s s)"
            by (simp add: unifies_sapply)
          from this True 2(1) have
            "\<not> Option.is_none (unify (Var(x := t) \<cdot>s s))"
            by auto
          hence
            "\<not> Option.is_none (scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)))"
            using Option.is_none_def by fastforce
          then show ?thesis using True
            by simp
        qed
      next
        case False
        then show ?thesis proof-
          from 2(3) obtain \<sigma> where si:
            "unifies \<sigma> ((Var x, t) # s)"
            by(rule exE)
          hence
            "\<exists> \<sigma> . unifies \<sigma> s"
            by(simp; blast)
          moreover from si False have
            "t = Var x"
            by(simp add: case_occurs)
          ultimately show ?thesis using 2(2) False by simp
        qed
      qed
    qed
next
  case (3 v va x s)
  then show ?case proof-
    from 3(2) obtain \<sigma> where "unifies \<sigma> ((Fun v va, Var x) # s)"
      by(rule exE)
    hence
      "unifies \<sigma> ((Var x, Fun v va) # s)"
      by(simp add: unifies_eq_def)
    hence
      "\<exists>\<sigma>. unifies \<sigma> ((Var x, Fun v va) # s)"
      by blast
    hence
      "\<not> Option.is_none (unify ((Var x, Fun v va) # s))"
      using 3(1) by simp
    then show ?thesis by simp
  qed
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof-
    from 4(2) obtain \<sigma> where "unifies \<sigma> ((Fun f0 l0, Fun f1 l1) # s)"
      by(rule exE)
    hence
      "unifies_eq \<sigma> (Fun f0 l0, Fun f1 l1)"
      by(simp)
    hence reqs:
      "f0 = f1 \<and> length l0 = length l1"
      by(simp add: unifies_wf)
    from 4(2) obtain \<sigma> where "unifies \<sigma> ((Fun f0 l0, Fun f1 l1) # s)"
      by(rule exE)
    hence
      "unifies \<sigma> (term_zip l0 l1 @ s)"
      using reqs by(simp only: fun_unifies)
    hence
      "\<exists> \<sigma> . unifies \<sigma> (term_zip l0 l1 @ s)"
      by blast
    from this reqs 4(1) have
      "\<not> Option.is_none (unify (term_zip l0 l1 @ s))"
      by simp
    moreover have
      "unify (term_zip l0 l1 @ s) = unify ((Fun f0 l0, Fun f1 l1) # s)"
      using reqs by simp
    ultimately show ?thesis by(simp)
  qed
qed

theorem unify_completeness: "(\<exists> \<sigma> . unifies \<sigma> eqs \<longrightarrow> unify eqs = Some \<sigma>)"
  by (metis is_none_simps(1) lemma2 option.exhaust_sel)

text \<open> (d) \<close>

lemma fv_swap:
  "fv_eq (t0, t1) = fv_eq (t1, t0)"
  by(simp add: fv_eq_def; blast)

lemma fv_fun:
  "length l0 = length l1 \<Longrightarrow> fv_eqs ((Fun f0 l0, Fun f1 l1) # s) = fv_eqs ((term_zip l0 l1) @ s)"
proof(induction rule: term_zip.induct)
  case (1 t1)
  then show ?case by (simp add: fv_eq_def)
next
  case (2 v va)
  then show ?case by simp
next
  case (3 h0 t0 h1 t1)
  then show ?case proof-
    from 3(2) have lens:
      "length t0 = length t1"
      by simp
    have
      "fv_eqs ((Fun f0 (h0 # t0), Fun f1 (h1 # t1)) # s) = fv h0 \<union> fv h1 \<union> fv_eqs ((Fun f0 t0, Fun f1 t1) # s)"
      by(simp add: fv_eq_def; auto)
    moreover have
      "... = fv h0 \<union> fv h1 \<union> fv_eqs (term_zip t0 t1 @ s)"
      using 3(1) lens by simp
    moreover have
      "... = fv_eqs (term_zip (h0 # t0) (h1 # t1) @ s)"
      by(simp add: fv_eq_def)
    ultimately show ?thesis by simp
  qed
qed

lemma lemma1: "fv (\<sigma> \<cdot> t) \<subseteq> (fv t - sdom \<sigma>) \<union> svran \<sigma>"
  apply(induction t)
   apply(meson subsetI svapply_svdom_svran)
  by auto

lemma lemma1_eq: "fv_eq (\<sigma> \<cdot>e eq) \<subseteq> (fv_eq eq - sdom \<sigma>) \<union> svran \<sigma>"
  apply(induction eq)
  apply(simp add: fv_eq_def sapply_eq_def)
  by (smt (verit) Diff_subset_conv Un_Diff inf_sup_aci(5) le_supI1 lemma1)

lemma lemma1_eqs: "fv_eqs (\<sigma> \<cdot>s eqs) \<subseteq> (fv_eqs eqs - sdom \<sigma>) \<union> svran \<sigma>"
proof(induction eqs rule: fv_eqs.induct)
  case 1
  then show ?case by simp
next
  case (2 eq s)
  then show ?case proof-
    have
      "fv_eqs (\<sigma> \<cdot>s (eq # s)) = fv_eq (\<sigma> \<cdot>e eq) \<union> fv_eqs (\<sigma> \<cdot>s s)"
      by simp
    moreover have
      "fv_eq (\<sigma> \<cdot>e eq) \<subseteq> (fv_eq eq - sdom \<sigma>) \<union> svran \<sigma>"
      by (simp only: lemma1_eq)
    ultimately show ?thesis
      using 2 by auto
  qed
qed

(* Useful subcase of lemma1_eqs *)
lemma lemma1_eqs_single: "x \<notin> fv t \<Longrightarrow> fv_eqs (Var(x := t) \<cdot>s s) \<subseteq> fv t \<union> fv_eqs s"
using lemma1_eqs by(smt (verit, del_insts) Diff_iff Diff_insert_absorb Un_Diff Un_commute fv.simps(1)
                                  insert_Diff1 sdom_single_non_trivial singletonI subset_eq svran_single_non_trivial)

lemma unify_svran_fv: "unify eqs = Some \<sigma> \<Longrightarrow> svran \<sigma> \<subseteq> fv_eqs eqs"
proof(induction arbitrary: \<sigma> rule: unify.induct)
  case 1
  then show ?case by simp
next
    case (2 x t s)
    then show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
      case True
      then show ?thesis proof-
        from True 2(3) have opt:
          "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
          by simp
        then obtain \<sigma>p where sigp_unify:
          "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
          by fastforce
        from this opt have sig:
          "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
        from sigp_unify True 2(1) have IS:
          "svran \<sigma>p \<subseteq> fv_eqs (Var(x := t) \<cdot>s s)"
          by simp
        from this sig have
          "svran \<sigma> \<subseteq> fv t \<union> fv_eqs (Var(x := t) \<cdot>s s)"
          by (smt (verit) Un_assoc Un_commute fun_upd_triv le_supI2 scomp_Var sup.orderE svran_scomp svran_single_non_trivial)
        moreover have
          "fv_eqs ((Var x, t) # s) = { x } \<union> fv t \<union> fv_eqs s"
          by (simp add: fv_eq_def)
        moreover from True lemma1_eqs_single have
          "fv_eqs (Var(x := t) \<cdot>s s) \<subseteq> fv t \<union> fv_eqs s"
          by metis
        ultimately show ?thesis
          by blast
      qed
    next
      case False
      then show ?thesis proof-
        from False 2(3) have
          " t = Var x"
          by fastforce
        moreover from 2(3) have
          "unify s = Some \<sigma>"
          by (simp add: calculation)
        ultimately show ?thesis using 2(2) False by auto
      qed
    qed
  qed
next
  case (3 v va x s)
  then show ?case by(simp add: fv_swap)
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof-
    from 4(2) have
      "f0 = f1 \<and> length l0 = length l1"
      by (metis Fun option.discI)
    moreover from 4(2) have
      "unify (term_zip l0 l1 @ s) = Some \<sigma>"
      by (simp add: calculation)
    ultimately show ?thesis using 4(1) by(simp only: fv_fun)
  qed
qed

lemma unify_fv_sapply: "unify eqs = Some \<sigma> \<Longrightarrow> fv_eqs (\<sigma> \<cdot>s eqs) \<subseteq> fv_eqs eqs"
proof(induction eqs arbitrary: \<sigma> rule: unify.induct)
  case 1
  then show ?case by simp
next
    case (2 x t s)
    show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
      case True
      then show ?thesis proof-
        from True 2(3) have opt:
          "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
          by simp
        then obtain \<sigma>p where sigp_unify:
          "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
          by fastforce
        from this opt have sig:
          "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
        from sigp_unify True 2(1) have IS:
          "fv_eqs (\<sigma>p \<cdot>s Var(x := t) \<cdot>s s) \<subseteq> fv_eqs (Var(x := t) \<cdot>s s)"
          by simp
        from this sig have
          "fv_eqs (\<sigma> \<cdot>s s) \<subseteq> fv_eqs (Var(x := t) \<cdot>s s)"
          by(simp only: sapply_scomp_distrib_eqs)
        moreover from this True have
          "svran \<sigma> \<subseteq> fv t \<union> fv_eqs s"
          by (smt (verit, ccfv_threshold) Un_absorb2 fun_upd_triv inf_sup_ord(3) lemma1_eqs_single order_trans
              scomp_Var sig sigp_unify sup.mono svran_scomp svran_single_non_trivial unify_svran_fv)
        ultimately show ?thesis using 2
          by (meson Diff_subset dual_order.trans le_supI lemma1_eqs unify_svran_fv)
      qed
    next
      case False
      then show ?thesis proof-
        from False 2(3) have t:
          " t = Var x"
          by fastforce
        moreover from 2(3) have unify_s:
          "unify s = Some \<sigma>"
          by (simp add: calculation)
        ultimately have
          "fv_eqs (\<sigma> \<cdot>s s) \<subseteq> fv_eqs s"
          using 2(2) by simp
        moreover have
          "fv_eqs (\<sigma> \<cdot>s ((Var x, t) # s)) = fv (\<sigma> x) \<union> fv_eqs (\<sigma> \<cdot>s s)"
          by (simp add: fv_eq_def sapply_eq_def t)
        moreover from t have
          "fv_eqs ((Var x, t) # s) = { x } \<union> fv_eqs s"
          by(simp add: fv_eq_def)
        moreover have
          "fv (\<sigma> x) \<subseteq> { x } \<union> fv_eqs s"
        proof-
          from lemma1 have
            "fv (\<sigma> x) \<subseteq> { x } - sdom \<sigma> \<union> svran \<sigma>"
            by (metis fv.simps(1) sapply.simps(1))
          moreover from unify_s unify_svran_fv have
            "svran \<sigma> \<subseteq> fv_eqs s"
            by blast
          ultimately show ?thesis by blast
        qed
        ultimately show ?thesis
          by blast
      qed
    qed
  qed
next
  case (3 v va x s)
  then show ?case by(simp add: fv_sapply_eqs sapply_eq_def fv_swap)
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof-
    from 4(2) have
      "f0 = f1 \<and> length l0 = length l1"
      by (simp; metis option.distinct(1))
    moreover from 4(2) have
      "unify (term_zip l0 l1 @ s) = Some \<sigma>"
      by (simp add: calculation)
    ultimately have
      "fv_eqs (\<sigma> \<cdot>s (term_zip l0 l1 @ s)) \<subseteq> fv_eqs (term_zip l0 l1 @ s)"
      using 4(1) by simp
    from this 4 show ?thesis by(simp only: fv_sapply_eqs fv_fun; metis Fun fv_fun option.simps(3))
  qed
qed

lemma unify_sdom_fv: "unify eqs = Some \<sigma> \<Longrightarrow> sdom \<sigma> \<subseteq> fv_eqs eqs"
proof(induction eqs arbitrary: \<sigma> rule: unify.induct)
  case 1
  then show ?case by simp
next
    case (2 x t s)
    show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
      case True
      then show ?thesis proof-
        from True 2(3) have opt:
          "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
          by simp
        then obtain \<sigma>p where sigp_unify:
          "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
          by fastforce
        from this opt have sig:
          "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
        from this have
          "sdom \<sigma> \<subseteq> sdom \<sigma>p \<union> { x }"
          by (metis Un_commute fun_upd_idem_iff insert_is_Un scomp_Var sdom_scomp sdom_single_non_trivial subset_insertI)
        moreover from 2(1) True sigp_unify have IS:
          "sdom \<sigma>p \<subseteq> fv_eqs (Var(x := t) \<cdot>s s)"
          by simp
        moreover from True have
          "fv_eqs (Var(x := t) \<cdot>s s) \<union> { x } \<subseteq> fv t \<union> fv_eqs s \<union> { x }"
          by (simp add: lemma1_eqs_single subset_insertI2)
        moreover have
          "fv t \<union> fv_eqs s \<union> { x } = fv_eqs ((Var x, t) # s)"
          by (simp add: fv_eq_def)
        ultimately show ?thesis
          by auto
      qed
    next
      case False
      then show ?thesis proof-
        from False 2(3) have t:
          " t = Var x"
          by fastforce
        moreover from 2(3) have
          "unify s = Some \<sigma>"
          by (simp add: calculation)
        ultimately show ?thesis using 2(2) False by auto
      qed
    qed
  qed
next
  case (3 v va x s)
  then show ?case by(simp add: fv_swap)
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof-
    from 4(2) have
      "f0 = f1 \<and> length l0 = length l1"
      by (metis Fun option.discI)
    moreover from 4(2) have
      "unify (term_zip l0 l1 @ s) = Some \<sigma>"
      by (simp add: calculation)
    ultimately show ?thesis using 4(1) by(simp only: fv_fun)
  qed
qed

lemma unify_sdom_svran: "unify eqs = Some \<sigma> \<Longrightarrow> sdom \<sigma> \<inter> svran \<sigma> = {}"
proof(induction arbitrary: \<sigma> rule: unify.induct)
  case 1
  then show ?case by simp
next
    case (2 x t s)
    then show ?case proof-
      show ?case proof(cases "x \<notin> fv t")
      case True
      then show ?thesis proof-
        from True 2(3) have opt:
          "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
          by simp
        then obtain \<sigma>p where sigp_unify:
          "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
          by fastforce
        from this opt have sig:
          "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
        from 2(1) True sigp_unify have IS:
          "sdom \<sigma>p \<inter> svran \<sigma>p = {}"
          by simp
        from sig True sigp_unify have
          "svran \<sigma>p \<subseteq> fv_eqs (Var(x := t) \<cdot>s s)"
          using unify_svran_fv by blast
        from this True have x_svran_sigp:
          "x \<notin> svran \<sigma>p"
          by (metis (no_types, lifting) Diff_iff Diff_insert_absorb Un_Diff fv.simps(1) lemma1_eqs
              sdom_single_non_trivial singletonI subsetD svran_single_non_trivial)
        have
          "\<not> (\<exists> z . z \<in> sdom \<sigma> \<and> z \<in> svran \<sigma>)"
        proof(rule notI)
          assume "\<exists>z. z \<in> sdom \<sigma> \<and> z \<in> svran \<sigma>"
          then obtain z where z_sdom:
            "z \<in> sdom \<sigma>" and z_svran: "z \<in> svran \<sigma>"
            by blast
          from True z_sdom sig have
            "z \<in> sdom \<sigma>p \<union> { x }"
            by (metis fv.simps(1) insertI1 insert_absorb insert_subset sdom_scomp sdom_single_non_trivial)
          moreover from True z_svran sig have
            "z \<in> svran \<sigma>p \<union> fv t"
            by (metis fv.simps(1) insertI1 insert_absorb insert_subset svran_scomp svran_single_non_trivial)
          ultimately have z_sdom_sigp:
            "z \<in> sdom \<sigma>p"
            using x_svran_sigp True by blast
          from svran_def z_svran obtain y where
            y_sdom_sig: "y \<in> sdom \<sigma>" and z_fv_sig_y: "z \<in> fv (\<sigma> y)"
            by fast
          then show False proof(cases "x = y")
            case True
            then show ?thesis proof-
              from True sig have
                "\<sigma> y = \<sigma>p \<cdot> t"
                by (simp add: scomp_sapply)
              from this z_fv_sig_y have
                "z \<in> fv (\<sigma>p \<cdot> t)"
                by simp
              from this lemma1 have
                "z \<in> (fv t) - sdom \<sigma>p \<union> svran \<sigma>p"
                by fast
              from this z_sdom_sigp have
                "z \<in> svran \<sigma>p"
                by simp
              from this IS z_sdom_sigp show ?thesis
                by auto
            qed
          next
            case False
            then show ?thesis proof-
              from False sig have
                "\<sigma> y = \<sigma>p y"
                by (simp add: scomp_sapply)
              from this z_fv_sig_y z_sdom_sigp have
                "z \<in> svran \<sigma>p"
                by (metis Diff_iff Un_commute Un_iff sapply.simps(1) svapply_svdom_svran)
              from this IS z_sdom_sigp show ?thesis
                by auto
            qed
          qed
        qed
        then show ?thesis
          by auto
        qed
    next
      case False
      then show ?thesis proof-
        from False 2(3) have t:
          " t = Var x"
          by fastforce
        moreover from 2(3) have
          "unify s = Some \<sigma>"
          by (simp add: calculation)
        ultimately show ?thesis using 2(2) False by simp
      qed
    qed
  qed
next
  case (3 v va x s)
  then show ?case by simp
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof-
    from 4(2) have
      "f0 = f1 \<and> length l0 = length l1"
      by (metis Fun option.discI)
    moreover from 4(2) have
      "unify (term_zip l0 l1 @ s) = Some \<sigma>"
      by (simp add: calculation)
    ultimately show ?thesis using 4(1) by simp
  qed
qed

section \<open> Assignment 4 \<close>

text \<open> (a) \<close>

fun wf_term :: "('f \<Rightarrow> nat) \<Rightarrow> ('f, 'v) term \<Rightarrow> bool" where
  "wf_term arity (Var _) = True"
| "wf_term arity (Fun f lst) = (((length lst) = (arity f)) \<and> (\<forall> t \<in> set lst. (wf_term arity t)))"

definition wf_subst :: "('f \<Rightarrow> nat) \<Rightarrow> ('f, 'v) subst \<Rightarrow> bool" where
  "wf_subst arity \<sigma> = (\<forall> x. wf_term arity (\<sigma> x))"

fun wf_eq :: "('f \<Rightarrow> nat) \<Rightarrow> ('f, 'v) equation \<Rightarrow> bool" where
  "wf_eq arity (t0, t1) = ((wf_term arity t0) \<and> (wf_term arity t1))"

lemma wf_eq_terms_wf: "wf_eq arity eq \<longleftrightarrow> wf_term arity (fst eq) \<and> wf_term arity (snd eq)"
  by (metis surjective_pairing wf_eq.simps)

definition wf_eqs :: "('f \<Rightarrow> nat) \<Rightarrow> ('f, 'v) equations \<Rightarrow> bool" where
  "wf_eqs arity eqs = (\<forall> eq \<in> (set eqs). wf_eq arity eq)"

text \<open> (b) \<close>

lemma wf_term_sapply:
  "\<lbrakk> wf_term arity t; wf_subst arity \<sigma> \<rbrakk> \<Longrightarrow> wf_term arity (\<sigma> \<cdot> t)"
  apply(induction t)
  by(simp_all add: wf_subst_def)

lemma wf_subst_scomp:
  "\<lbrakk> wf_subst arity \<sigma>; wf_subst arity \<tau> \<rbrakk> \<Longrightarrow> wf_subst arity (\<sigma> \<circ>s \<tau>)"
  by(simp add: wf_subst_def scomp_def wf_term_sapply)

lemma wf_zip: "\<lbrakk>length l0 = length l1;
    \<forall>t\<in>set l0. wf_term arity t;
    \<forall>t\<in>set l1. wf_term arity t;
    wf_eqs arity s\<rbrakk> \<Longrightarrow> wf_eqs arity ((term_zip l0 l1)@s)"
  apply(induction rule: term_zip.induct)
  by(simp_all add: wf_eqs_def)

lemma wf_single_subst: "\<lbrakk> x \<notin> fv t; wf_term arity t\<rbrakk> \<Longrightarrow> wf_subst arity (Var(x := t))"
  by(simp add: wf_subst_def)

lemma wf_Var: "wf_subst arity Var"
  by(simp add: wf_subst_def)

lemma wf_eq_sapply:
  "\<lbrakk> wf_subst arity \<sigma>; wf_term arity t;  wf_eq arity eq \<rbrakk> \<Longrightarrow> wf_eq arity (\<sigma> \<cdot>e eq)"
  by(simp add: sapply_eq_def wf_eq_terms_wf wf_term_sapply)

lemma wf_eqs_sapply: "\<lbrakk> wf_subst arity \<sigma>; wf_term arity t;  wf_eqs arity s \<rbrakk> \<Longrightarrow> wf_eqs arity (\<sigma> \<cdot>s s)"
  apply(induction s)
   apply(simp)
  by(simp add: wf_eqs_def wf_eq_sapply)

lemma wf_subst_unify:
  "\<lbrakk> unify eqs = Some \<sigma>; wf_eqs arity eqs \<rbrakk> \<Longrightarrow> wf_subst arity \<sigma>"
proof(induction arbitrary: \<sigma> rule: unify.induct)
  case 1
  then show ?case by(simp add: wf_subst_def)
next
  case (2 x t s)
    from 2(4)have s_wf:
      "wf_eqs arity s"
      by (simp add: wf_eqs_def)
    show ?case proof(cases "x \<notin> fv t")
      case True
      then show ?thesis proof-
          from 2(4) have t_wf:
            "wf_term arity t"
            by(simp add: wf_eqs_def)
          from this True s_wf have up_wf:
            "wf_eqs arity (Var(x := t) \<cdot>s s)"
            by(simp add: wf_single_subst wf_eqs_sapply)
          from True 2(3) have opt:
            "scomp_opt (unify (Var(x := t) \<cdot>s s)) (Var(x := t)) = Some \<sigma>"
            by simp
          then obtain \<sigma>p where sigp_unify:
            "unify (Var(x := t) \<cdot>s s) = Some \<sigma>p"
            by fastforce
          from this opt have sig:
            "\<sigma> = \<sigma>p \<circ>s Var(x := t)" by simp
          moreover from 2(1) True sigp_unify up_wf have
            "wf_subst arity \<sigma>p"
            by simp
          ultimately show ?thesis using True
            by(simp add: t_wf wf_single_subst  wf_subst_scomp)
        qed
    next
      case False
      then show ?thesis proof-
        from False 2(3) have
          "t = Var x"
          by fastforce
        moreover from 2(3) have
          "unify s = Some \<sigma>"
          by (simp add: calculation)
        ultimately show ?thesis using 2(2) s_wf by simp
      qed
    qed
next
  case (3 v va x s)
  then show ?case by(simp add: wf_eqs_def wf_subst_def)
next
  case (4 f0 l0 f1 l1 s)
  then show ?case proof -
    from 4(2) have s0:
      "f0 = f1 \<and> length l0 = length l1"
      by (simp; metis option.distinct(1))
    from 4(2) have s1:
      "unify (term_zip l0 l1 @ s) = Some \<sigma>"
      by (simp; metis option.distinct(1))
    from 4(3) have s2:
      "(\<forall> t \<in> set l0 . wf_term arity t) \<and> (\<forall> t \<in> set l1 . wf_term arity t)"
      by(simp add: wf_eqs_def)
    from 4(3) have s3:
      "wf_eqs arity s"
      by(simp add: wf_eqs_def)
    from s0 s2 s3 have s4:
      "wf_eqs arity ((term_zip l0 l1)@s)"
      by(simp add: wf_zip)
    from 4(1) s0 s1 s4 show ?thesis by simp
  qed
qed

end


section \<open>Specification\<close>

theory Goodstein_Lambda2
  imports Main "../Eval_Base/Eval_Base"
begin

subsection \<open>Hereditary base representation\<close>

text \<open>We define a data type of trees and an evaluation function that sums siblings and
  exponentiates with respect to the given base on nesting.\<close>

datatype C = C (unC: "C list")

fun evalC where
  "evalC b (C []) = 0"
| "evalC b (C (x # xs)) = b^evalC b x + evalC b (C xs)"

value "evalC 2 (C [])" \<comment> \<open>$0$\<close>
value "evalC 2 (C [C []])" \<comment> \<open>$2^0 = 1$\<close>
value "evalC 2 (C [C [C []]])" \<comment> \<open>$2^1 = 2$\<close>
value "evalC 2 (C [C [], C []])" \<comment> \<open>$2^0 + 2^0 = 2^0 \cdot 2 = 2$; not in hereditary base $2$\<close>

text \<open>The hereditary base representation is characterized as trees (i.e., nested lists) whose
  lists have monotonically increasing evaluations, with fewer than @{term "b"} repetitions for
  each value. We will show later that this representation is unique.\<close>

inductive_set hbase for b where
  "C [] \<in> hbase b"
| "i \<noteq> 0 \<Longrightarrow> i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow>
   C ms \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
   C (replicate i n @ ms) \<in> hbase b"

text \<open>We can convert to and from natural numbers as follows.\<close>

definition H2N where
  "H2N b n = evalC b n"

text \<open>As we will show later, @{term "H2N b"} restricted to @{term "hbase n"} is bijective
  if @{prop "b \<ge> (2 :: nat)"}, so we can convert from natural numbers by taking the inverse.\<close>

definition N2H where
  "N2H b n = inv_into (hbase b) (H2N b) n"

subsection \<open>The Goodstein function\<close>

text \<open>We define a function that computes the length of the Goodstein sequence whose $c$-th element
  is $g_c = n$. Termination will be shown later, thereby establishing Goodstein's theorem.\<close>

function (sequential) goodstein :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "goodstein 0 n = 0"
  \<comment> \<open>we start counting at 1; also note that the initial base is @{term "c+1 :: nat"} and\<close>
  \<comment> \<open>hereditary base 1 makes no sense, so we have to avoid this case\<close>
| "goodstein c 0 = c"
| "goodstein c n = goodstein (c+1) (H2N (c+2) (N2H (c+1) n) - 1)"
  by pat_completeness auto

abbreviation \<G> where
  "\<G> n \<equiv> goodstein (Suc 0) n"

section \<open>Ordinals\<close>

text \<open>The following type contains countable ordinals, by the usual case distinction into 0,
  successor ordinal, or limit ordinal; limit ordinals are given by their fundamental sequence.
  Hereditary base @{term "b"} representations carry over to such ordinals by replacing each
  occurrence of the base by @{term "\<omega>"}.\<close>

datatype Ord = Z | S Ord | L "nat \<Rightarrow> Ord"

text \<open>Note that the following arithmetic operations are not correct for all ordinals. However, they
  will only be used in cases where they actually correspond to the ordinal arithmetic operations.\<close>

primrec addO where
  "addO n Z = n"
| "addO n (S m) = S (addO n m)"
| "addO n (L f) = L (\<lambda>i. addO n (f i))"

primrec mulO where
  "mulO n Z = Z"
| "mulO n (S m) = addO (mulO n m) n"
| "mulO n (L f) = L (\<lambda>i. mulO n (f i))"

definition \<omega> where
  "\<omega> = L (\<lambda>n. (S ^^ n) Z)"

primrec exp\<omega> where
  "exp\<omega> Z = S Z"
| "exp\<omega> (S n) = mulO (exp\<omega> n) \<omega>"
| "exp\<omega> (L f) = L (\<lambda>i. exp\<omega> (f i))"

subsection \<open>Evaluation\<close>

text \<open>Evaluating an ordinal number at base $b$ is accomplished by taking the $b$-th element of
  all fundamental sequences and interpreting zero and successor over the natural numbers.\<close>

primrec evalO where
  "evalO b Z = 0"
| "evalO b (S n) = Suc (evalO b n)"
| "evalO b (L f) = evalO b (f b)"

subsection \<open>Goodstein function and sequence\<close>

text \<open>We can define the Goodstein function very easily, but proving correctness will take a while.\<close>

primrec goodsteinO where
  "goodsteinO c Z = c"
| "goodsteinO c (S n) = goodsteinO (c+1) n"
| "goodsteinO c (L f) = goodsteinO c (f (c+2))"

primrec stepO where
  "stepO c Z = Z"
| "stepO c (S n) = n"
| "stepO c (L f) = stepO c (f (c+2))"

text \<open>We can compute a few values of the Goodstein sequence starting at $4$.\<close>

definition g4O where
  "g4O n = fold stepO [1..<Suc n] ((exp\<omega> ^^ 3) Z)"

value "map (\<lambda>n. evalO (n+2) (g4O n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties of evaluation\<close>

lemma evalO_addO [simp]:
  "evalO b (addO n m) = evalO b n + evalO b m"
  apply (induct m) by auto

lemma evalO_mulO [simp]:
  "evalO b (mulO n m) = evalO b n * evalO b m"
  apply (induct m) by auto

lemma evalO_n [simp]:
  "evalO b ((S ^^ n) Z) = n"
  apply (induct n) by auto

lemma evalO_\<omega> [simp]:
  "evalO b \<omega> = b"
  by (auto simp: \<omega>_def)

lemma evalO_exp\<omega> [simp]:
  "evalO b (exp\<omega> n) = b^(evalO b n)"
  apply (induct n) by auto

text \<open>Note that evaluation is useful for proving that @{type "Ord"} values are distinct:\<close>
notepad begin
  have "addO n (exp\<omega> m) \<noteq> n" for n m by (auto dest: arg_cong[of _ _ "evalO 1"])
end

subsection \<open>Arithmetic properties\<close>

lemma addO_Z [simp]:
  "addO Z n = n"
  apply (induct n) by auto

lemma addO_assoc [simp]:
  "addO n (addO m p) = addO (addO n m) p"
  apply (induct p) by auto

lemma mul0_distrib [simp]:
  "mulO n (addO p q) = addO (mulO n p) (mulO n q)"
  apply (induct q) by auto

lemma mulO_assoc [simp]:
  "mulO n (mulO m p) = mulO (mulO n m) p"
  apply (induct p) by auto

section \<open>Cantor normal form\<close>

text \<open>The previously introduced tree type @{type C} can be used to represent Cantor normal forms;
  they are trees (evaluated at base @{term \<omega>}) such that siblings are in non-decreasing order.
  One can think of this as hereditary base @{term \<omega>}. The plan is to mirror selected operations on
  ordinals in Cantor normal forms.\<close>

subsection \<open>Conversion to and from the ordinal type @{type Ord}\<close>

fun C2O where
  "C2O (C []) = Z"
| "C2O (C (n # ns)) = addO (C2O (C ns)) (exp\<omega> (C2O n))"

definition O2C where
  "O2C = inv C2O"

text \<open>We show that @{term C2O} is injective, meaning the inverse is unique.\<close>

lemma addO_exp\<omega>_inj:
  assumes "addO n (exp\<omega> m) = addO n' (exp\<omega> m')"
  shows "n = n'" and "m = m'"
proof -
  have "addO n (exp\<omega> m) = addO n' (exp\<omega> m') \<Longrightarrow> n = n'"
    apply (induct m arbitrary: m') by(case_tac m';
      force simp: \<omega>_def dest!: fun_cong[of _ _ 1])+
  moreover have "addO n (exp\<omega> m) = addO n (exp\<omega> m') \<Longrightarrow> m = m'"
    apply (induct m arbitrary: n m'; case_tac m')
    apply (auto 0 3 simp: \<omega>_def intro: rangeI
      dest: arg_cong[of _ _ "evalO 1"] fun_cong[of _ _ 0] fun_cong[of _ _ 1])[8] (* 1 left *)
    by simp (meson ext rangeI)
  ultimately show "n = n'" and "m = m'" using assms by simp_all
qed

lemma C2O_inj:
  "C2O n = C2O m \<Longrightarrow> n = m"
  apply (induct n arbitrary: m rule: C2O.induct; case_tac m rule: C2O.cases)
    by (auto dest: addO_exp\<omega>_inj arg_cong[of _ _ "evalO 1"])

lemma O2C_C2O [simp]:
  "O2C (C2O n) = n"
  by (auto intro!: inv_f_f simp: O2C_def inj_def C2O_inj)

lemma O2C_Z [simp]:
  "O2C Z = C []"
  using O2C_C2O[of "C []", unfolded C2O.simps] .

lemma C2O_replicate:
  "C2O (C (replicate i n)) = mulO (exp\<omega> (C2O n)) ((S ^^ i) Z)"
  apply (induct i) by auto

lemma C2O_app:
  "C2O (C (xs @ ys)) = addO (C2O (C ys)) (C2O (C xs))"
  apply (induct xs arbitrary: ys) by auto

subsection \<open>Evaluation\<close>

lemma evalC_def':
  "evalC b n = evalO b (C2O n)"
  apply (induct n rule: C2O.induct) by auto

lemma evalC_app [simp]:
  "evalC b (C (ns @ ms)) = evalC b (C ns) + evalC b (C ms)"
  apply (induct ns) by auto

lemma evalC_replicate [simp]:
  "evalC b (C (replicate c n)) = c * evalC b (C [n])"
  apply (induct c) by auto

subsection \<open>Transfer of the @{type Ord} induction principle to @{type C}\<close>

fun funC where \<comment> \<open>@{term funC} computes the fundamental sequence on @{type C}\<close>
  "funC (C []) = (\<lambda>i. [C []])"
| "funC (C (C [] # ns)) = (\<lambda>i. replicate i (C ns))"
| "funC (C (n # ns)) = (\<lambda>i. [C (funC n i @ ns)])"

lemma C2O_cons:
  "C2O (C (n # ns)) =
    (if n = C [] then S (C2O (C ns)) else L (\<lambda>i. C2O (C (funC n i @ ns))))"
  apply (induct n arbitrary: ns rule: funC.induct)
  by (simp_all add: \<omega>_def C2O_replicate C2O_app flip: exp\<omega>_addO)

lemma C_Ord_induct:
  assumes "P (C [])"
  and "\<And>ns. P (C ns) \<Longrightarrow> P (C (C [] # ns))"
  and "\<And>n ns ms. (\<And>i. P (C (funC (C (n # ns)) i @ ms))) \<Longrightarrow>
    P (C (C (n # ns) # ms))"
  shows "P n"
proof -
  have "\<forall>n. C2O n = m \<longrightarrow> P n" for m
    apply (induct m; intro allI; case_tac n rule: funC.cases)
  by (auto simp: C2O_cons simp del: C2O.simps(2) intro: assms)
  then show ?thesis by simp
qed

subsection \<open>Goodstein function and sequence on @{type C}\<close>

function (domintros) goodsteinC where
  "goodsteinC c (C []) = c"
| "goodsteinC c (C (C [] # ns)) = goodsteinC (c+1) (C ns)"
| "goodsteinC c (C (C (n # ns) # ms)) =
    goodsteinC c (C (funC (C (n # ns)) (c+2) @ ms))"
  by pat_completeness auto

termination
proof -
  have "goodsteinC_dom (c, n)" for c n
    apply (induct n arbitrary: c rule: C_Ord_induct) by(auto intro: goodsteinC.domintros)
  then show ?thesis by simp
qed

lemma goodsteinC_def':
  "goodsteinC c n = goodsteinO c (C2O n)"
  apply (induct c n rule: goodsteinC.induct) by(simp_all add: C2O_cons del: C2O.simps(2))

function (domintros) stepC where
  "stepC c (C []) = C []"
| "stepC c (C (C [] # ns)) = C ns"
| "stepC c (C (C (n # ns) # ms)) =
    stepC c (C (funC (C (n # ns)) (Suc (Suc c)) @ ms))"
  by pat_completeness auto

termination
proof -
  have "stepC_dom (c, n)" for c n
    apply (induct n arbitrary: c rule: C_Ord_induct) by(auto intro: stepC.domintros)
  then show ?thesis by simp
qed

definition g4C where
  "g4C n = fold stepC [1..<Suc n] (C [C [C [C []]]])"

value "map (\<lambda>n. evalC (n+2) (g4C n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties\<close>

lemma stepC_def':
  "stepC c n = O2C (stepO c (C2O n))"
  apply (induct c n rule: stepC.induct) by(simp_all add: C2O_cons del: C2O.simps(2))

lemma funC_ne [simp]:
  "funC m (Suc n) \<noteq> []"
  by (cases m rule: funC.cases) simp_all

lemma evalC_funC [simp]:
  "evalC b (C (funC n b)) = evalC b (C [n])"
  apply (induct n rule: funC.induct) by simp_all

lemma stepC_app [simp]:
  "n \<noteq> C [] \<Longrightarrow> stepC c (C (unC n @ ns)) = C (unC (stepC c n) @ ns)"
  apply (induct n arbitrary: ns rule: stepC.induct) by simp_all

lemma stepC_cons [simp]:
  "ns \<noteq> [] \<Longrightarrow> stepC c (C (n # ns)) = C (unC (stepC c (C [n])) @ ns)"
  using stepC_app[of "C[n]" c ns] by simp

lemma stepC_dec:
  "n \<noteq> C [] \<Longrightarrow> Suc (evalC (Suc (Suc c)) (stepC c n)) = evalC (Suc (Suc c)) n"
  apply (induct c n rule: stepC.induct) by simp_all

lemma stepC_dec':
  "n \<noteq> C [] \<Longrightarrow> evalC (c+3) (stepC c n) < evalC (c+3) n"
proof (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  have "evalC (c+3) (C (funC (C (n # ns)) (Suc (Suc c)))) \<le>
      (c+3) ^ ((c+3) ^ evalC (c+3) n + evalC (c+3) (C ns))"
    apply (induct n rule: funC.induct) by(simp_all add: distrib_right)
  then show ?case using 3 by simp
qed simp_all

section \<open>Hereditary base @{term b} representation\<close>

text \<open>We now turn to properties of the @{term "hbase b"} subset of trees.\<close>

subsection \<open>Uniqueness\<close>

text \<open>We show uniqueness of the hereditary base representation by showing that @{term "evalC b"}
  restricted to @{term "hbase b"} is injective.\<close>

lemma hbaseI2:
  "i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow> C m \<in> hbase b \<Longrightarrow>
    (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
    C (replicate i n @ m) \<in> hbase b"
  by (cases i) (auto intro: hbase.intros simp del: replicate.simps(2))

lemmas hbase_singletonI =
  hbase.intros(2)[of 1 "Suc (Suc b)" for b, OF _ _ _ hbase.intros(1), simplified]

lemma hbase_hd:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> hd ns \<in> hbase b"
  by (cases rule: hbase.cases) auto

lemmas hbase_hd' [dest] = hbase_hd[of "n # ns" for n ns, simplified]

lemma hbase_tl:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase.cases) (auto intro: hbaseI2)

lemmas hbase_tl' [dest] = hbase_tl[of "n # ns" for n ns, simplified]

lemma hbase_elt [dest]:
  "C ns \<in> hbase b \<Longrightarrow> n \<in> set ns \<Longrightarrow> n \<in> hbase b"
  apply (induct ns) by auto

lemma evalC_sum_list:
  "evalC b (C ns) = sum_list (map (\<lambda>n. b^evalC b n) ns)"
  apply (induct ns) by auto

lemma sum_list_replicate:
  "sum_list (replicate n x) = n * x"
  apply (induct n) by auto

lemma base_red:
  fixes b :: nat
  assumes n: "\<And>n'. n' \<in> set ns \<Longrightarrow> n < n'" "i < b" "i \<noteq> 0"
  and m: "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
  and s: "i * b^n + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
  shows "i = j \<and> n = m"
  using n(1) m(1) s
proof (induct n arbitrary: m ns ms)
  { fix ns ms :: "nat list" and i j m :: nat
    assume n': "\<And>n'. n' \<in> set ns \<Longrightarrow> 0 < n'" "i < b" "i \<noteq> 0"
    assume m': "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
    assume s': "i * b^0 + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
    obtain x where [simp]: "sum_list (map ((^) b) ns) = x*b"
      using n'(1)
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ns)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    obtain y where [simp]: "sum_list (map ((^) b) ms) = y*b"
      using order.strict_trans1[OF le0 m'(1)]
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ms)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    have [simp]: "m = 0"
      using s' n'(2,3)
      by (cases m, simp_all)
        (metis Groups.mult_ac(2) Groups.mult_ac(3) Suc_pred div_less mod_div_mult_eq
          mod_mult_self2 mod_mult_self2_is_0 mult_zero_right nat.simps(3))
    have "i = j \<and> 0 = m" using s' n'(2,3) m'(2,3)
      by simp (metis div_less mod_div_mult_eq mod_mult_self1)
  } note BASE = this
  {
    case 0 show ?case by (rule BASE; fact)
  next
    case (Suc n m')
    have "j = i \<and> 0 = Suc n" if "m' = 0" using Suc(2-4)
      by (intro BASE[of ms j ns "Suc n" i]) (simp_all add: ac_simps that n(2,3) m(2,3))
    then obtain m where m' [simp]: "m' = Suc m"
      by (cases m') auto
    obtain ns' where [simp]: "ns = map Suc ns'" "\<And>n'. n' \<in> set ns' \<Longrightarrow> n < n'"
      using Suc(2) less_trans[OF zero_less_Suc Suc(2)]
      by (intro that[of "map (\<lambda>n. n-1) ns"]; force cong: map_cong)
    obtain ms' where [simp]: "ms = map Suc ms'" "\<And>m'. m' \<in> set ms' \<Longrightarrow> m < m'"
      using Suc(3)[unfolded m'] less_trans[OF zero_less_Suc Suc(3)[unfolded m']]
      by (intro that[of "map (\<lambda>n. n-1) ms"]; force cong: map_cong)
    have *: "b * x = b * y \<Longrightarrow> x = y" for x y using n(2) by simp
    have "i = j \<and> n = m"
    proof (rule Suc(1)[of "map (\<lambda>n. n-1) ns" "map (\<lambda>n. n-1) ms" m, OF _ _ *], goal_cases)
      case 3 show ?case using Suc(4) unfolding add_mult_distrib2
        by (simp add: comp_def ac_simps flip: sum_list_const_mult)
    qed simp_all
    then show ?case by simp
  }
qed

lemma evalC_inj_on_hbase:
  "n \<in> hbase b \<Longrightarrow> m \<in> hbase b \<Longrightarrow> evalC b n = evalC b m \<Longrightarrow> n = m"
proof (induct n arbitrary: m rule: hbase.induct)
  case 1
  then show ?case by (cases m rule: hbase.cases) simp_all
next
  case (2 i n ns m')
  obtain j m ms where [simp]: "m' = C (replicate j m @ ms)" and
    m: "j \<noteq> 0" "j < b" "m \<in> hbase b" "C ms \<in> hbase b" "\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b m < evalC b m'"
    using 2(8,1,2,9) by (cases m' rule: hbase.cases) simp_all
  have "i = j \<and> evalC b n = evalC b m" using 2(1,2,7,9) m(1,2,5)
    by (intro base_red[of "map (evalC b) ns" _ _ b "map (evalC b) ms"])
      (auto simp: comp_def evalC_sum_list sum_list_replicate)
  then show ?case
    using 2(4)[OF m(3)] 2(6)[OF m(4)] 2(9) by simp
qed

subsection \<open>Correctness of @{const stepC}\<close>

text \<open>We show that @{term "stepC c"} preserves hereditary base @{term "c + 2 :: nat"}
  representations. In order to cover intermediate results produced by @{const stepC}, we extend
  the hereditary base representation to allow the least significant digit to be equal to @{term b},
  which essentially means that we may have an extra sibling in front on every level.\<close>

inductive_set hbase_ext for b where
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase_ext b"
| "n \<in> hbase_ext b \<Longrightarrow>
   C m \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n \<le> evalC b m') \<Longrightarrow>
   C (n # m) \<in> hbase_ext b"

lemma hbase_ext_hd' [dest]:
  "C (n # ns) \<in> hbase_ext b \<Longrightarrow> n \<in> hbase_ext b"
  by (cases rule: hbase_ext.cases) (auto intro: hbase_ext.intros(1))

lemma hbase_ext_tl:
  "C ns \<in> hbase_ext b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase_ext.cases; cases ns) (simp_all add: hbase_tl')

lemmas hbase_ext_tl' [dest] = hbase_ext_tl[of "n # ns" for n ns, simplified]

lemma hbase_funC:
  "c \<noteq> 0 \<Longrightarrow> C (n # ns) \<in> hbase_ext (Suc c) \<Longrightarrow>
    C (funC n (Suc c) @ ns) \<in> hbase_ext (Suc c)"
proof (induct n arbitrary: ns rule: funC.induct)
  case (2 ms)
  have [simp]: "evalC (Suc c) (C ms) < evalC (Suc c) m'" if "m' \<in> set ns" for m'
    using 2(2)
  proof (cases rule: hbase_ext.cases)
    case 1 then show ?thesis using that
      by (cases rule: hbase.cases, case_tac i) (auto intro: Suc_lessD)
  qed (auto simp: Suc_le_eq that)
  show ?case using 2
    by (auto 0 4 intro: hbase_ext.intros hbase.intros(2) order.strict_implies_order)
next
  case (3 m ms ms')
  show ?case
    unfolding funC.simps append_Cons append_Nil
  proof (rule hbase_ext.intros(2), goal_cases 31 32 33)
    case (33 m')
    show ?case using 3(3)
    proof (cases rule: hbase_ext.cases)
      case 1 show ?thesis using 1 3(1,2) 33
        by (cases rule: hbase.cases, case_tac i) (auto intro: less_or_eq_imp_le)
    qed (insert 33, simp)
  qed (insert 3, blast+)
qed auto

lemma stepC_sound:
  "n \<in> hbase_ext (Suc (Suc c)) \<Longrightarrow> stepC c n \<in> hbase (Suc (Suc c))"
proof (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  show ?case using 3(2,1)
    by (cases rule: hbase_ext.cases; unfold stepC.simps) (auto intro: hbase_funC)
qed (auto intro: hbase.intros)

subsection \<open>Surjectivity of @{const evalC}\<close>

text \<open>Note that the base must be at least @{term "2 :: nat"}.\<close>

lemma evalC_surjective:
  "\<exists>n' \<in> hbase (Suc (Suc b)). evalC (Suc (Suc b)) n' = n"
proof (induct n)
  case 0 then show ?case by (auto intro: bexI[of _ "C []"] hbase.intros)
next
  have [simp]: "Suc x \<le> Suc (Suc b)^x" for x apply (induct x) by auto
  case (Suc n)
  then guess n' by (rule bexE)
  then obtain n' j where n': "Suc n \<le> j" "j = evalC (Suc (Suc b)) n'" "n' \<in> hbase (Suc (Suc b))"
    by (intro that[of _ "C [n']"])
      (auto intro!: intro: hbase.intros(1) dest!: hbaseI2[of 1 "b+2" n' "[]", simplified])
  then show ?case
  proof (induct rule: inc_induct)
    case (step m)
    guess n' using step(3)[OF step(4,5)] by (rule bexE)
    then show ?case using stepC_dec[of n' "b"]
      by (cases n' rule: C2O.cases) (auto intro: stepC_sound hbase_ext.intros(1))
  qed blast
qed

subsection \<open>Monotonicity of @{const hbase}\<close>

text \<open>Here we show that every hereditary base @{term "b :: nat"} number is also a valid hereditary
  base @{term "b+1 :: nat"} number. This is not immediate because we have to show that monotonicity
  of siblings is preserved.\<close>

lemma hbase_evalC_mono:
  assumes "n \<in> hbase b" "m \<in> hbase b" "evalC b n < evalC b m"
  shows "evalC (Suc b) n < evalC (Suc b) m"
proof (cases "b < 2")
  case True show ?thesis using assms(2,3) True by (cases rule: hbase.cases) simp_all
next
  case False
  then obtain b' where [simp]: "b = Suc (Suc b')"
    by (auto simp: numeral_2_eq_2 not_less_eq dest: less_imp_Suc_add)
  show ?thesis using assms(3,1,2)
  proof (induct "evalC b n" "evalC b m" arbitrary: n m rule: less_Suc_induct)
    case 1 then show ?case using stepC_sound[of m b', OF hbase_ext.intros(1)]
      stepC_dec[of m b'] stepC_dec'[of m b'] evalC_inj_on_hbase
      by (cases m rule: C2O.cases) (fastforce simp: eval_nat_numeral)+
  next
    case (2 j) then show ?case
      using evalC_surjective[of b' j] less_trans by fastforce
  qed
qed

lemma hbase_mono:
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase (Suc b)"
  apply (induct n rule: hbase.induct) by(auto 0 3 intro: hbase.intros hbase_evalC_mono)

subsection \<open>Conversion to and from @{type nat}\<close>

text \<open>We have previously defined @{term "H2N b = evalC b"} and @{term "N2H b"} as its inverse.
  So we can use the injectivity and surjectivity of @{term "evalC b"} for simplification.\<close>

lemma N2H_inv:
  "n \<in> hbase b \<Longrightarrow> N2H b (H2N b n) = n"
  using evalC_inj_on_hbase
  by (auto simp: N2H_def H2N_def[abs_def] inj_on_def intro!: inv_into_f_f)

lemma N2H_eqI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n = m \<Longrightarrow> N2H (Suc (Suc b)) m = n"
  using N2H_inv by blast

lemma N2H_neI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n \<noteq> m \<Longrightarrow> N2H (Suc (Suc b)) m \<noteq> n"
  using H2N_inv by blast

lemma N2H_0 [simp]:
  "N2H (Suc (Suc c)) 0 = C []"
  using H2N_def N2H_inv hbase.intros(1) by fastforce

lemma N2H_nz [simp]:
  "0 < n \<Longrightarrow> N2H (Suc (Suc c)) n \<noteq> C []"
  by (metis N2H_0 H2N_inv neq0_conv)

section \<open>The Goodstein function revisited\<close>

text \<open>We are now ready to prove termination of the Goodstein function @{const goodstein} as well
  as its relation to @{const goodsteinC} and @{const goodsteinO}.\<close>

lemma goodstein_aux:
  "goodsteinC (Suc c) (N2H (Suc (Suc c)) (Suc n)) =
    goodsteinC (c+2) (N2H (c+3) (H2N (c+3) (N2H (c+2) (n+1)) - 1))"
proof -
  have [simp]: "n \<noteq> C [] \<Longrightarrow> goodsteinC c n = goodsteinC (c+1) (stepC c n)" for c n
    apply (induct c n rule: stepC.induct) by simp_all
  have [simp]: "stepC (Suc c) (N2H (Suc (Suc c)) (Suc n)) \<in> hbase (Suc (Suc (Suc c)))"
    by (metis H2N_def N2H_inv evalC_surjective hbase_ext.intros(1) hbase_mono stepC_sound)
  show ?thesis
    using arg_cong[OF stepC_dec[of "N2H (c+2) (n+1)" "c+1", folded H2N_def], of "\<lambda>n. N2H (c+3) (n-1)"]
    by (simp add: eval_nat_numeral N2H_inv)
qed

termination goodstein
proof (relation "measure (\<lambda>(c, n). goodsteinC c (N2H (c+1) n) - c)", goal_cases _ 1)
  case (1 c n)
  have *: "goodsteinC c n \<ge> c" for c n
    apply (induct c n rule: goodsteinC.induct) by simp_all
  show ?case by (simp add: goodstein_aux eval_nat_numeral) (meson Suc_le_eq diff_less_mono2 lessI *)
qed simp

lemma goodstein_def':
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinC c (N2H (c+1) n)"
  apply (induct c n rule: goodstein.induct) by(simp_all add: goodstein_aux eval_nat_numeral)

lemma goodstein_impl:
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinO c (C2O (N2H (c+1) n))"
  \<comment> \<open>but note that @{term N2H} is not executable as currently defined\<close>
  using goodstein_def'[unfolded goodsteinC_def'] .

lemma goodstein_16:
  "\<G> 16 = goodsteinO 1 (exp\<omega> (exp\<omega> (exp\<omega> (exp\<omega> Z))))"
proof -
  have "N2H (Suc (Suc 0)) 16 = C [C [C [C [C []]]]]"
    by (auto simp: H2N_def intro!: N2H_eqI hbase_singletonI hbase.intros(1))
  then show ?thesis by (simp add: goodstein_impl)
qed

section \<open>Translation to $\lambda$-calculus\<close>

text \<open>We define Church encodings for @{type nat} and @{type Ord}. Note that we are basically in a
  Hindley-Milner type system, so we cannot use a proper polymorphic type. We can still express
  Church encodings as folds over values of the original type.\<close>

abbreviation Z\<^sub>N where "Z\<^sub>N \<equiv> (\<lambda>s z. z)"
abbreviation S\<^sub>N where "S\<^sub>N \<equiv> (\<lambda>n s z. s (n s z))"

primrec fold_nat ("\<langle>_\<rangle>\<^sub>N") where
  "\<langle>0\<rangle>\<^sub>N = Z\<^sub>N"
| "\<langle>Suc n\<rangle>\<^sub>N = S\<^sub>N \<langle>n\<rangle>\<^sub>N"

lemma one\<^sub>N:
  "\<langle>1\<rangle>\<^sub>N = (\<lambda>x. x)"
  by simp

abbreviation Z\<^sub>O where "Z\<^sub>O \<equiv> (\<lambda>z s l. z)"
abbreviation S\<^sub>O where "S\<^sub>O \<equiv> (\<lambda>n z s l. s (n z s l))"
abbreviation L\<^sub>O where "L\<^sub>O \<equiv> (\<lambda>f z s l. l (\<lambda>i. f i z s l))"

primrec fold_Ord ("\<langle>_\<rangle>\<^sub>O") where
  "\<langle>Z\<rangle>\<^sub>O = Z\<^sub>O"
| "\<langle>S n\<rangle>\<^sub>O = S\<^sub>O \<langle>n\<rangle>\<^sub>O"
| "\<langle>L f\<rangle>\<^sub>O = L\<^sub>O (\<lambda>i. \<langle>f i\<rangle>\<^sub>O)"

text \<open>The following abbreviations and lemmas show how to implement the arithmetic functions and
  the Goodstein function on a Church-encoded @{type Ord} in lambda calculus.\<close>

abbreviation (input) add\<^sub>O where
  "add\<^sub>O n m \<equiv> (\<lambda>z s l. m (n z s l) s l)"

lemma add\<^sub>O:
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  apply (induct m) by simp_all

abbreviation (input) mul\<^sub>O where
  "mul\<^sub>O n m \<equiv> (\<lambda>z s l. m z (\<lambda>m. n m s l) l)"

lemma mul\<^sub>O:
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
  apply (induct m) by(simp_all add: add\<^sub>O)

abbreviation (input) \<omega>\<^sub>O where
  "\<omega>\<^sub>O \<equiv> (\<lambda>z s l. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N s z))"

lemma \<omega>\<^sub>O:
  "\<langle>\<omega>\<rangle>\<^sub>O = \<omega>\<^sub>O"
proof -
  have [simp]: "\<langle>(S ^^ i) Z\<rangle>\<^sub>O z s l = \<langle>i\<rangle>\<^sub>N s z" for i z s l apply (induct i) by simp_all
  show ?thesis by (simp add: \<omega>_def)
qed

abbreviation (input) exp\<omega>\<^sub>O where
  "exp\<omega>\<^sub>O n \<equiv> (\<lambda>z s l. n s (\<lambda>x z. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N x z)) (\<lambda>f z. l (\<lambda>n. f n z)) z)"

lemma exp\<omega>\<^sub>O:
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
  apply (induct n) by (simp_all add: mul\<^sub>O \<omega>\<^sub>O)

abbreviation (input) goodstein\<^sub>O where
  "goodstein\<^sub>O \<equiv> (\<lambda>c n. n (\<lambda>x. x) (\<lambda>n m. n (m + 1)) (\<lambda>f m. f (m + 2) m) c)"

lemma goodstein\<^sub>O:
  "goodsteinO c n = goodstein\<^sub>O c \<langle>n\<rangle>\<^sub>O"
  apply (induct n arbitrary: c) by simp_all

text \<open>Note that modeling Church encodings with folds is still limited. For example, the meaningful
  expression @{text "\<langle>n\<rangle>\<^sub>N exp\<omega>\<^sub>O Z\<^sub>O"} cannot be typed in Isabelle/HOL, as that would require rank-2
  polymorphism.\<close>

subsection \<open>Alternative: free theorems\<close>

text \<open>The following is essentially the free theorem for Church-encoded @{type Ord} values.\<close>
ML\<open>
(*
fun func x = fn z => func x z;
Isabelle_Utils.timeout_apply (seconds 3.0) (func) 3 2
*)
\<close>
lemma freeOrd:
  assumes "\<And>n. h (s n) = s' (h n)" and "\<And>f. h (l f) = l' (\<lambda>i. h (f i))"
  shows "h (\<langle>n\<rangle>\<^sub>O z s l) = \<langle>n\<rangle>\<^sub>O (h z) s' l'"
  apply (induct n)
  by(simp_all add: assms)

text \<open>Each of the following proofs first states a naive definition of the corresponding function
  (which is proved correct by induction), from which we then derive the optimized version using
  the free theorem, by (conditional) rewriting (without induction).\<close>

lemma add\<^sub>O':
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>addO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O \<langle>n\<rangle>\<^sub>O S\<^sub>O L\<^sub>O"
    apply (induct m) by simp_all
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma mul\<^sub>O':
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>mulO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O Z\<^sub>O (\<lambda>m. add\<^sub>O m \<langle>n\<rangle>\<^sub>O) L\<^sub>O"
    apply (induct m) by(simp_all add: add\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma exp\<omega>\<^sub>O':
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>exp\<omega> n\<rangle>\<^sub>O = \<langle>n\<rangle>\<^sub>O (S\<^sub>O Z\<^sub>O) (\<lambda>m. mul\<^sub>O m \<omega>\<^sub>O) L\<^sub>O"
    apply (induct n) by(simp_all add: mul\<^sub>O \<omega>\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: fun_cong[OF freeOrd[where h = "\<lambda>n z. n z _ _"]])
qed

end


(* Title: Program Store
   Author: Peixin You
*)

section \<open>Program Store\<close>

theory Store
  imports KA

begin

subsection \<open>Function update\<close>

text \<open> Isabelle provides such a function, but its type doesn't suit our needs well enough.\<close>

definition fup :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" ("\<Delta>") where
  "\<Delta> x a f = (\<lambda>y. if x = y then a else f y)"

lemma fun_update_simp1 [simp]: "\<Delta> x a f x = a"
  by (simp add: fup_def)

lemma fun_update_simp2 [simp]: "x \<noteq> y \<Longrightarrow> \<Delta> x a f y = f y"
  by (simp add: fup_def)

lemma fun_update_absorb [simp]: "\<Delta> x a (\<Delta> x b f) = \<Delta> x a f"
  unfolding fup_def by force

lemma fun_update_absorb2 [simp]: "\<Delta> x a \<circ> \<Delta> x b = \<Delta> x a"
  unfolding fup_def by force

lemma fun_update_comm: "x \<noteq> y \<Longrightarrow> \<Delta> x a (\<Delta> y b f) = \<Delta> y b (\<Delta> x a f)"
  unfolding fup_def by force

lemma fun_update_comm2: "x \<noteq> y \<Longrightarrow> \<Delta> x a \<circ> \<Delta> y b = \<Delta> y b \<circ> \<Delta> x a"
  unfolding fup_def by force

lemma fun_update_triv [simp]: "\<Delta> x (f x) f = f"
  unfolding fup_def by force

abbreviation set :: "'a \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)" where
  "set x e s \<equiv> \<Delta> x (e s) s"

subsection \<open>Program Store and Semantics of Assignments\<close>

type_synonym 'a store = "string \<Rightarrow> 'a"

definition rel_assign :: "'a \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) rel" ("_ :=\<^sub>r _" [70, 65] 61) where
  "v :=\<^sub>r e = {(s, set v e s) |s. True}"

lemma rel_assign_iff: "((s,s') \<in> v :=\<^sub>r e) = (s' = set v e s)"
  by (simp add: rel_assign_def)

definition sta_assign :: "'a \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) sta" ("_ :=\<^sub>s _" [70, 65] 61) where
  "v :=\<^sub>s e = \<eta> \<circ> set v e"

lemma sta_assign_eq: "(v :=\<^sub>s e) s = {set v e s}"
  by (simp add: sta_assign_def)

lemma sta_assign_iff: "(s' \<in> (v :=\<^sub>s e) s) = (s' = set v e s)"
  by (simp add: sta_assign_def)

end


theory Exercise6
  imports Main
begin

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

fun contents :: "'a tree \<Rightarrow> 'a list" where
  "contents Tip = Nil"
  | "contents (Node l a r) = (contents l) @ [a] @ (contents r)"

fun treesum :: "nat tree \<Rightarrow> nat" where
  "treesum Tip = 0"
  | "treesum (Node l a r) = (treesum l) + a + (treesum r)"

fun listsum :: "nat list \<Rightarrow> nat" where
  "listsum Nil = 0"
  | "listsum (Cons x xs) = x + (listsum xs)"

lemma shallow_treesum [simp]: "treesum (Node Tip a Tip) = a"
  apply (induction a)
  apply (auto)
done

lemma zero_treesum [simp]: "treesum (Node l 0 r) = (treesum l) + (treesum r)"
  apply (induction l)
  apply (auto)
done

lemma suc_treesum [simp]: "treesum (Node l (Suc a) r) = Suc (treesum (Node l a r))"
  apply (induction a)
  apply (auto)
done

lemma listsum_app_distributivity [simp]: "listsum (xs @ ys) = (listsum xs) + (listsum ys)"
  apply (induction xs)
  apply (auto)
done

theorem treesum_is_contents_sum [simp]: "treesum t = listsum (contents t)"
  apply (induction t rule: treesum.induct)
  apply (auto)
done

end