section\<open>Pointermap\<close>
theory Pointer_Map
imports Main
begin

text\<open>
  We need a datastructure that supports the following two operations:
  \begin{itemize}
    \item Given an element, it can construct a pointer (i.e., a small representation) of that element. It will always construct the same pointer for equal elements.
    \item Given a pointer, we can retrieve the element
  \end{itemize}
\<close>

record 'a pointermap =
  entries :: "'a list"
  getentry :: "'a \<Rightarrow> nat option"

definition "pointermap_sane m \<equiv> (distinct (entries m) \<and>
  (\<forall>n \<in> {..<length (entries m)}. getentry m (entries m ! n) = Some n) \<and>
  (\<forall>p i. getentry m p = Some i \<longrightarrow> entries m ! i = p \<and> i < length (entries m)))"

definition "empty_pointermap \<equiv> \<lparr>entries = [], getentry = \<lambda>p. None \<rparr>"
lemma pointermap_empty_sane[simp, intro!]: "pointermap_sane empty_pointermap" unfolding empty_pointermap_def pointermap_sane_def by simp

definition "pointermap_insert a m \<equiv> \<lparr>entries = (entries m)@[a], getentry = (getentry m)(a \<mapsto> length (entries m))\<rparr>"

definition "pm_pth m p \<equiv> entries m ! p"

definition "pointermap_p_valid p m \<equiv> p < length (entries m)"

definition "pointermap_getmk a m \<equiv> (case getentry m a of Some p \<Rightarrow> (p,m) | None \<Rightarrow> let u = pointermap_insert a m in (the (getentry u a), u))"

lemma pointermap_sane_appendD: "pointermap_sane s \<Longrightarrow> m \<notin> set (entries s) \<Longrightarrow> pointermap_sane (pointermap_insert m s)"
unfolding pointermap_sane_def pointermap_insert_def
proof(intro conjI[rotated],goal_cases)
  case 3 thus ?case by simp
next
  case 2
  {
    fix n
    have " \<lbrakk>distinct (entries s) \<and> (\<forall>x. x \<in> {..<length (entries s)} \<longrightarrow> getentry s (entries s ! x) = Some x) \<and> (\<forall>p i. getentry s p = Some i \<longrightarrow> entries s ! i = p \<and> i < length (entries s)); m \<notin> set (entries s);
          n \<in> {..<length (entries \<lparr>entries = entries s @ [m], getentry = getentry s(m \<mapsto> length (entries s))\<rparr>)}; n < length (entries s)\<rbrakk>
         \<Longrightarrow> getentry \<lparr>entries = entries s @ [m], getentry = getentry s(m \<mapsto> length (entries s))\<rparr> (entries \<lparr>entries = entries s @ [m], getentry = getentry s(m \<mapsto> length (entries s))\<rparr> ! n) = Some n"
         "\<lbrakk>distinct (entries s) \<and> (\<forall>x. x \<in> {..<length (entries s)} \<longrightarrow> getentry s (entries s ! x) = Some x) \<and> (\<forall>p i. getentry s p = Some i \<longrightarrow> entries s ! i = p \<and> i < length (entries s)); m \<notin> set (entries s);
          n \<in> {..<length (entries \<lparr>entries = entries s @ [m], getentry = getentry s(m \<mapsto> length (entries s))\<rparr>)}; \<not> n < length (entries s)\<rbrakk>
         \<Longrightarrow> getentry \<lparr>entries = entries s @ [m], getentry = getentry s(m \<mapsto> length (entries s))\<rparr> (entries \<lparr>entries = entries s @ [m], getentry = getentry s(m \<mapsto> length (entries s))\<rparr> ! n) = Some n"
      proof(goal_cases)
        case 1 note goal1 = 1
        from goal1(4) have sa: "\<And>a. (entries s @ a) ! n = entries s ! n" by (simp add: nth_append)
        from goal1(1,4) have ih: "getentry s (entries s ! n) = Some n" by simp
        from goal1(2,4) have ne: "entries s ! n \<noteq> m" using nth_mem by fastforce
        from sa ih ne show ?case by simp
      next
        case 2 note goal2 = 2
        from goal2(3,4) have ln: "n = length (entries s)" by simp
        hence sa: "\<And>a. (entries s @ [a]) ! n = a" by simp
        from sa ln show ?case by simp
      qed
  } note h = this
  with 2 show ?case by blast
    (*apply(unfold Ball_def)
    apply(rule)
    apply(rule)
    apply(rename_tac n)
    apply(case_tac "n < length (entries s)")
  by(fact h)+*)
next
  case 1 thus ?case
    by(clarsimp simp add: nth_append fun_upd_same Ball_def) force
qed

lemma luentries_noneD: "getentry s a = None \<Longrightarrow> pointermap_sane s \<Longrightarrow> a \<notin> set (entries s)"
unfolding pointermap_sane_def
proof(rule ccontr, goal_cases)
  case 1
  from 1(3) obtain n where "n < length (entries s)" "entries s ! n = a" unfolding in_set_conv_nth by blast
  with 1(2,1) show False by force
qed

lemma pm_pth_append: "pointermap_p_valid p m \<Longrightarrow> pm_pth (pointermap_insert a m) p = pm_pth m p"
  unfolding pointermap_p_valid_def pm_pth_def pointermap_insert_def
  by(simp add: nth_append)

lemma pointermap_insert_in: "u = (pointermap_insert a m) \<Longrightarrow> pm_pth u (the (getentry u a)) = a"
unfolding pointermap_insert_def pm_pth_def
by(simp)

lemma pointermap_insert_p_validI: "pointermap_p_valid p m \<Longrightarrow> pointermap_p_valid p (pointermap_insert a m)"
  unfolding pointermap_insert_def pointermap_p_valid_def
  by simp

thm nth_eq_iff_index_eq
lemma pth_eq_iff_index_eq: "pointermap_sane m \<Longrightarrow> pointermap_p_valid p1 m \<Longrightarrow> pointermap_p_valid p2 m \<Longrightarrow> (pm_pth m p1 = pm_pth m p2) \<longleftrightarrow> (p1 = p2)"
  unfolding pointermap_sane_def pointermap_p_valid_def pm_pth_def
  using nth_eq_iff_index_eq by blast

lemma pointermap_p_valid_updateI: "pointermap_sane m \<Longrightarrow> getentry m a = None \<Longrightarrow> u = pointermap_insert a m \<Longrightarrow> p = the (getentry u a) \<Longrightarrow> pointermap_p_valid p u"
by(simp add: pointermap_sane_def pointermap_p_valid_def pointermap_insert_def)

lemma pointermap_get_validI: "pointermap_sane m \<Longrightarrow> getentry m a = Some p \<Longrightarrow> pointermap_p_valid p m"
by(simp add: pointermap_sane_def pointermap_p_valid_def)

lemma pointermap_sane_getmkD:
  assumes sn: "pointermap_sane m"
  assumes res: "pointermap_getmk a m = (p,u)"
  shows "pointermap_sane u \<and> pointermap_p_valid p u"
using sn res[symmetric]
  apply(cases "getentry m a")
   apply(simp_all add: pointermap_getmk_def Let_def split: option.split)
   apply(rule)
    apply(rule pointermap_sane_appendD)
     apply(clarify;fail)+
    apply(rule luentries_noneD)
     apply(clarify;fail)+
   apply(rule pointermap_p_valid_updateI[OF _ _ refl refl])
    apply(clarify;fail)+
  apply(erule pointermap_get_validI)
  by simp

lemma pointermap_update_pthI:
  assumes sn: "pointermap_sane m"
  assumes res: "pointermap_getmk a m = (p,u)"
  shows "pm_pth u p = a"
using assms
  apply(simp add: pointermap_getmk_def Let_def split: option.splits)
   apply(meson pointermap_insert_in)
  apply(clarsimp simp: pointermap_sane_def pm_pth_def)
done

lemma pointermap_p_valid_inv:
  assumes "pointermap_p_valid p m"
  assumes "pointermap_getmk a m = (x,u)"
  shows "pointermap_p_valid p u"
using assms
by(simp add: pointermap_getmk_def Let_def split: option.splits) (meson pointermap_insert_p_validI)

lemma pointermap_p_pth_inv:
  assumes pv: "pointermap_p_valid p m"
  assumes u: "pointermap_getmk a m = (x,u)"
  shows "pm_pth u p = pm_pth m p"
using pm_pth_append[OF pv] u
by(clarsimp simp: pointermap_getmk_def Let_def split: option.splits)

lemma pointermap_backward_valid:
  assumes puv: "pointermap_p_valid p u"
  assumes u: "pointermap_getmk a m = (x,u)"
  assumes ne: "x \<noteq> p"
  shows "pointermap_p_valid p m"
(*using u
unfolding pointermap_getmk_def
apply(simp add: Let_def split: option.splits)
prefer 2 using puv apply(simp)
apply(clarify)
apply(simp add: pointermap_insert_def)
using puv apply(clarify)
apply(simp add: pointermap_p_valid_def)
using ne by linarith
*)
using assms
by (auto simp: Let_def pointermap_getmk_def pointermap_p_valid_def pointermap_insert_def split: option.splits)

end


(*  Title:      HOL/Nominal/Examples/Standardization.thy
    Author:     Stefan Berghofer and Tobias Nipkow
    Copyright   2005, 2008 TU Muenchen
*)

section \<open>Standardization\<close>

theory Standardization
imports "../Nominal"
begin

text \<open>
The proof of the standardization theorem, as well as most of the theorems about
lambda calculus in the following sections, are taken from \<open>HOL/Lambda\<close>.
\<close>

subsection \<open>Lambda terms\<close>

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam" (infixl "\<degree>" 200)
| Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [0, 10] 10)

instantiation lam :: size
begin

nominal_primrec size_lam
where
  "size (Var n) = 0"
| "size (t \<degree> u) = size t + size u + 1"
| "size (Lam [x].t) = size t + 1"
  apply finite_guess+
  apply (rule TrueI)+
  apply (simp add: fresh_nat)
  apply fresh_guess+
  done

instance ..

end

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [300, 0, 0] 300)
where
  subst_Var: "(Var x)[y::=s] = (if x=y then s else (Var x))"
| subst_App: "(t\<^sub>1 \<degree> t\<^sub>2)[y::=s] = t\<^sub>1[y::=s] \<degree> t\<^sub>2[y::=s]"
| subst_Lam: "x \<sharp> (y, s) \<Longrightarrow> (Lam [x].t)[y::=s] = (Lam [x].(t[y::=s]))"
  apply(finite_guess)+
  apply(rule TrueI)+
  apply(simp add: abs_fresh)
  apply(fresh_guess)+
  done

lemma subst_eqvt [eqvt]:
  "(pi::name prm) \<bullet> (t[x::=u]) = (pi \<bullet> t)[(pi \<bullet> x)::=(pi \<bullet> u)]"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (perm_simp add: fresh_bij)+

lemma subst_rename:
  "y \<sharp> t \<Longrightarrow> ([(y, x)] \<bullet> t)[y::=u] = t[x::=u]"
  by (nominal_induct t avoiding: x y u rule: lam.strong_induct)
    (simp_all add: fresh_atm calc_atm abs_fresh)

lemma fresh_subst:
  "(x::name) \<sharp> t \<Longrightarrow> x \<sharp> u \<Longrightarrow> x \<sharp> t[y::=u]"
  by (nominal_induct t avoiding: x y u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma fresh_subst':
  "(x::name) \<sharp> u \<Longrightarrow> x \<sharp> t[x::=u]"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma subst_forget: "(x::name) \<sharp> t \<Longrightarrow> t[x::=u] = t"
  by (nominal_induct t avoiding: x u rule: lam.strong_induct)
    (auto simp add: abs_fresh fresh_atm)

lemma subst_subst:
  "x \<noteq> y \<Longrightarrow> x \<sharp> v \<Longrightarrow> t[y::=v][x::=u[y::=v]] = t[x::=u][y::=v]"
  by (nominal_induct t avoiding: x y u v rule: lam.strong_induct)
    (auto simp add: fresh_subst subst_forget)

declare subst_Var [simp del]

lemma subst_eq [simp]: "(Var x)[x::=u] = u"
  by (simp add: subst_Var)

lemma subst_neq [simp]: "x \<noteq> y \<Longrightarrow> (Var x)[y::=u] = Var x"
  by (simp add: subst_Var)

inductive beta :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta: "x \<sharp> t \<Longrightarrow> (Lam [x].s) \<degree> t \<rightarrow>\<^sub>\<beta> s[x::=t]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> (Lam [x].s) \<rightarrow>\<^sub>\<beta> (Lam [x].t)"

equivariance beta
nominal_inductive beta
  by (simp_all add: abs_fresh fresh_subst')

lemma better_beta [simp, intro!]: "(Lam [x].s) \<degree> t \<rightarrow>\<^sub>\<beta> s[x::=t]"
proof -
  obtain y::name where y: "y \<sharp> (x, s, t)"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> t" by simp
  then have "(Lam [y]. [(y, x)] \<bullet> s) \<degree> t \<rightarrow>\<^sub>\<beta> ([(y, x)] \<bullet> s)[y::=t]"
    by (rule beta)
  moreover from y have "(Lam [x].s) = (Lam [y]. [(y, x)] \<bullet> s)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis using y by (simp add: subst_rename)
qed

abbreviation
  beta_reds :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50) where
  "s \<rightarrow>\<^sub>\<beta>\<^sup>* t \<equiv> beta\<^sup>*\<^sup>* s t"

subsection \<open>Application of a term to a list of terms\<close>

abbreviation
  list_application :: "lam \<Rightarrow> lam list \<Rightarrow> lam"  (infixl "\<degree>\<degree>" 150) where
  "t \<degree>\<degree> ts \<equiv> foldl (op \<degree>) t ts"

lemma apps_eq_tail_conv [iff]: "(r \<degree>\<degree> ts = s \<degree>\<degree> ts) = (r = s)"
  by (induct ts rule: rev_induct) (auto simp add: lam.inject)

lemma Var_eq_apps_conv [iff]: "(Var m = s \<degree>\<degree> ss) = (Var m = s \<and> ss = [])"
  by (induct ss arbitrary: s) auto

lemma Var_apps_eq_Var_apps_conv [iff]:
    "(Var m \<degree>\<degree> rs = Var n \<degree>\<degree> ss) = (m = n \<and> rs = ss)"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply (simp add: lam.inject)
   apply blast
  apply (induct_tac ss rule: rev_induct)
   apply (auto simp add: lam.inject)
  done

lemma App_eq_foldl_conv:
  "(r \<degree> s = t \<degree>\<degree> ts) =
    (if ts = [] then r \<degree> s = t
    else (\<exists>ss. ts = ss @ [s] \<and> r = t \<degree>\<degree> ss))"
  apply (rule_tac xs = ts in rev_exhaust)
   apply (auto simp add: lam.inject)
  done

lemma Abs_eq_apps_conv [iff]:
    "((Lam [x].r) = s \<degree>\<degree> ss) = ((Lam [x].r) = s \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma apps_eq_Abs_conv [iff]: "(s \<degree>\<degree> ss = (Lam [x].r)) = (s = (Lam [x].r) \<and> ss = [])"
  by (induct ss rule: rev_induct) auto

lemma Abs_App_neq_Var_apps [iff]:
    "(Lam [x].s) \<degree> t \<noteq> Var n \<degree>\<degree> ss"
  by (induct ss arbitrary: s t rule: rev_induct) (auto simp add: lam.inject)

lemma Var_apps_neq_Abs_apps [iff]:
    "Var n \<degree>\<degree> ts \<noteq> (Lam [x].r) \<degree>\<degree> ss"
  apply (induct ss arbitrary: ts rule: rev_induct)
   apply simp
  apply (induct_tac ts rule: rev_induct)
   apply (auto simp add: lam.inject)
  done

lemma ex_head_tail:
  "\<exists>ts h. t = h \<degree>\<degree> ts \<and> ((\<exists>n. h = Var n) \<or> (\<exists>x u. h = (Lam [x].u)))"
  apply (induct t rule: lam.induct)
    apply (metis foldl_Nil)
   apply (metis foldl_Cons foldl_Nil foldl_append)
  apply (metis foldl_Nil)
  done

lemma size_apps [simp]:
  "size (r \<degree>\<degree> rs) = size r + foldl (op +) 0 (map size rs) + length rs"
  by (induct rs rule: rev_induct) auto

lemma lem0: "(0::nat) < k \<Longrightarrow> m \<le> n \<Longrightarrow> m < n + k"
  by simp

lemma subst_map [simp]:
    "(t \<degree>\<degree> ts)[x::=u] = t[x::=u] \<degree>\<degree> map (\<lambda>t. t[x::=u]) ts"
  by (induct ts arbitrary: t) simp_all

lemma app_last: "(t \<degree>\<degree> ts) \<degree> u = t \<degree>\<degree> (ts @ [u])"
  by simp

lemma perm_apps [eqvt]:
  "(pi::name prm) \<bullet> (t \<degree>\<degree> ts) = ((pi \<bullet> t) \<degree>\<degree> (pi \<bullet> ts))"
  by (induct ts rule: rev_induct) (auto simp add: append_eqvt)

lemma fresh_apps [simp]: "(x::name) \<sharp> (t \<degree>\<degree> ts) = (x \<sharp> t \<and> x \<sharp> ts)"
  by (induct ts rule: rev_induct)
    (auto simp add: fresh_list_append fresh_list_nil fresh_list_cons)

text \<open>A customized induction schema for \<open>\<degree>\<degree>\<close>.\<close>

lemma lem:
  assumes "\<And>n ts (z::'a::fs_name). (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z (Var n \<degree>\<degree> ts)"
    and "\<And>x u ts z. x \<sharp> z \<Longrightarrow> (\<And>z. P z u) \<Longrightarrow> (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z ((Lam [x].u) \<degree>\<degree> ts)"
  shows "size t = n \<Longrightarrow> P z t"
  apply (induct n arbitrary: t z rule: nat_less_induct)
  apply (cut_tac t = t in ex_head_tail)
  apply clarify
  apply (erule disjE)
   apply clarify
   apply (rule assms)
   apply clarify
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule impE, rule refl, erule spec)
    apply simp
    apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
    apply (fastforce simp add: sum_list_map_remove1)
  apply clarify
  apply (subgoal_tac "\<exists>y::name. y \<sharp> (x, u, z)")
   prefer 2
   apply (blast intro: exists_fresh' fin_supp)
  apply (erule exE)
  apply (subgoal_tac "(Lam [x].u) = (Lam [y].([(y, x)] \<bullet> u))")
  prefer 2
  apply (auto simp add: lam.inject alpha' fresh_prod fresh_atm)[]
  apply (simp (no_asm_simp))
  apply (rule assms)
  apply (simp add: fresh_prod)
   apply (erule allE, erule impE)
    prefer 2
    apply (erule allE, erule impE, rule refl, erule spec)
   apply simp
  apply clarify
  apply (erule allE, erule impE)
   prefer 2
   apply blast
  apply simp
  apply (simp only: foldl_conv_fold add.commute fold_plus_sum_list_rev)
  apply (fastforce simp add: sum_list_map_remove1)
  done

theorem Apps_lam_induct:
  assumes "\<And>n ts (z::'a::fs_name). (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z (Var n \<degree>\<degree> ts)"
    and "\<And>x u ts z. x \<sharp> z \<Longrightarrow> (\<And>z. P z u) \<Longrightarrow> (\<And>z. \<forall>t \<in> set ts. P z t) \<Longrightarrow> P z ((Lam [x].u) \<degree>\<degree> ts)"
  shows "P z t"
  apply (rule_tac t = t and z = z in lem)
    prefer 3
    apply (rule refl)
    using assms apply blast+
  done

subsection \<open>Congruence rules\<close>

lemma apps_preserves_beta [simp]:
    "r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> r \<degree>\<degree> ss \<rightarrow>\<^sub>\<beta> s \<degree>\<degree> ss"
  by (induct ss rule: rev_induct) auto

lemma rtrancl_beta_Abs [intro!]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> (Lam [x].s) \<rightarrow>\<^sub>\<beta>\<^sup>* (Lam [x].s')"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppL:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_AppR:
    "t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s \<degree> t'"
  by (induct set: rtranclp) (blast intro: rtranclp.rtrancl_into_rtrancl)+

lemma rtrancl_beta_App [intro]:
    "s \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<Longrightarrow> t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> s \<degree> t \<rightarrow>\<^sub>\<beta>\<^sup>* s' \<degree> t'"
  by (blast intro!: rtrancl_beta_AppL rtrancl_beta_AppR intro: rtranclp_trans)

subsection \<open>Lifting an order to lists of elements\<close>

definition
  step1 :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "step1 r =
    (\<lambda>ys xs. \<exists>us z z' vs. xs = us @ z # vs \<and> r z' z \<and> ys =
      us @ z' # vs)"

lemma not_Nil_step1 [iff]: "\<not> step1 r [] xs"
  apply (unfold step1_def)
  apply blast
  done

lemma not_step1_Nil [iff]: "\<not> step1 r xs []"
  apply (unfold step1_def)
  apply blast
  done

lemma Cons_step1_Cons [iff]:
    "(step1 r (y # ys) (x # xs)) =
      (r y x \<and> xs = ys \<or> x = y \<and> step1 r ys xs)"
  apply (unfold step1_def)
  apply (rule iffI)
   apply (erule exE)
   apply (rename_tac ts)
   apply (case_tac ts)
    apply fastforce
   apply force
  apply (erule disjE)
   apply blast
  apply (blast intro: Cons_eq_appendI)
  done

lemma append_step1I:
  "step1 r ys xs \<and> vs = us \<or> ys = xs \<and> step1 r vs us
    \<Longrightarrow> step1 r (ys @ vs) (xs @ us)"
  apply (unfold step1_def)
  apply auto
   apply blast
  apply (blast intro: append_eq_appendI)
  done

lemma Cons_step1E [elim!]:
  assumes "step1 r ys (x # xs)"
    and "\<And>y. ys = y # xs \<Longrightarrow> r y x \<Longrightarrow> R"
    and "\<And>zs. ys = x # zs \<Longrightarrow> step1 r zs xs \<Longrightarrow> R"
  shows R
  using assms
  apply (cases ys)
   apply (simp add: step1_def)
  apply blast
  done

lemma Snoc_step1_SnocD:
  "step1 r (ys @ [y]) (xs @ [x])
    \<Longrightarrow> (step1 r ys xs \<and> y = x \<or> ys = xs \<and> r y x)"
  apply (unfold step1_def)
  apply (clarify del: disjCI)
  apply (rename_tac vs)
  apply (rule_tac xs = vs in rev_exhaust)
   apply force
  apply simp
  apply blast
  done

subsection \<open>Lifting beta-reduction to lists\<close>

abbreviation
  list_beta :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>\<beta>]\<^sub>1" 50) where
  "rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<equiv> step1 beta rs ss"

lemma head_Var_reduction:
  "Var n \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> v \<Longrightarrow> \<exists>ss. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<and> v = Var n \<degree>\<degree> ss"
  apply (induct u \<equiv> "Var n \<degree>\<degree> rs" v arbitrary: rs set: beta)
     apply simp
    apply (rule_tac xs = rs in rev_exhaust)
     apply simp
    apply (atomize, force intro: append_step1I iff: lam.inject)
   apply (rule_tac xs = rs in rev_exhaust)
    apply simp
    apply (auto 0 3 intro: disjI2 [THEN append_step1I] simp add: lam.inject)
  done

lemma apps_betasE [case_names appL appR beta, consumes 1]:
  assumes major: "r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> s"
    and cases: "\<And>r'. r \<rightarrow>\<^sub>\<beta> r' \<Longrightarrow> s = r' \<degree>\<degree> rs \<Longrightarrow> R"
      "\<And>rs'. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs' \<Longrightarrow> s = r \<degree>\<degree> rs' \<Longrightarrow> R"
      "\<And>t u us. (x \<sharp> r \<Longrightarrow> r = (Lam [x].t) \<and> rs = u # us \<and> s = t[x::=u] \<degree>\<degree> us) \<Longrightarrow> R"
  shows R
proof -
  from major have
   "(\<exists>r'. r \<rightarrow>\<^sub>\<beta> r' \<and> s = r' \<degree>\<degree> rs) \<or>
    (\<exists>rs'. rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs' \<and> s = r \<degree>\<degree> rs') \<or>
    (\<exists>t u us. x \<sharp> r \<longrightarrow> r = (Lam [x].t) \<and> rs = u # us \<and> s = t[x::=u] \<degree>\<degree> us)"
    apply (nominal_induct u \<equiv> "r \<degree>\<degree> rs" s avoiding: x r rs rule: beta.strong_induct)
    apply (simp add: App_eq_foldl_conv)
    apply (split if_split_asm)
    apply simp
    apply blast
    apply simp
    apply (rule impI)+
    apply (rule disjI2)
    apply (rule disjI2)
    apply (subgoal_tac "r = [(xa, x)] \<bullet> (Lam [x].s)")
    prefer 2
    apply (simp add: perm_fresh_fresh)
    apply (drule conjunct1)
    apply (subgoal_tac "r = (Lam [xa]. [(xa, x)] \<bullet> s)")
    prefer 2
    apply (simp add: calc_atm)
    apply (thin_tac "r = _")
    apply simp
    apply (rule exI)
    apply (rule conjI)
    apply (rule refl)
    apply (simp add: abs_fresh fresh_atm fresh_left calc_atm subst_rename)
      apply (drule App_eq_foldl_conv [THEN iffD1])
      apply (split if_split_asm)
       apply simp
       apply blast
      apply (force intro!: disjI1 [THEN append_step1I] simp add: fresh_list_append)
     apply (drule App_eq_foldl_conv [THEN iffD1])
     apply (split if_split_asm)
      apply simp
      apply blast
     apply (clarify, auto 0 3 intro!: exI intro: append_step1I)
    done
  with cases show ?thesis by blast
qed

lemma apps_preserves_betas [simp]:
    "rs [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<Longrightarrow> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> r \<degree>\<degree> ss"
  apply (induct rs arbitrary: ss rule: rev_induct)
   apply simp
  apply simp
  apply (rule_tac xs = ss in rev_exhaust)
   apply simp
  apply simp
  apply (drule Snoc_step1_SnocD)
  apply blast
  done

subsection \<open>Standard reduction relation\<close>

text \<open>
Based on lecture notes by Ralph Matthes,
original proof idea due to Ralph Loader.
\<close>

declare listrel_mono [mono_set]

lemma listrelp_eqvt [eqvt]:
  fixes f :: "'a::pt_name \<Rightarrow> 'b::pt_name \<Rightarrow> bool"
  assumes xy: "listrelp f (x::'a::pt_name list) y"
  shows "listrelp ((pi::name prm) \<bullet> f) (pi \<bullet> x) (pi \<bullet> y)" using xy
  by induct (simp_all add: listrelp.intros perm_app [symmetric])

inductive
  sred :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>s" 50)
  and sredlist :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>s]" 50)
where
  "s [\<rightarrow>\<^sub>s] t \<equiv> listrelp op \<rightarrow>\<^sub>s s t"
| Var: "rs [\<rightarrow>\<^sub>s] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> rs'"
| Abs: "x \<sharp> (ss, ss') \<Longrightarrow> r \<rightarrow>\<^sub>s r' \<Longrightarrow> ss [\<rightarrow>\<^sub>s] ss' \<Longrightarrow> (Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> ss'"
| Beta: "x \<sharp> (s, ss, t) \<Longrightarrow> r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t \<Longrightarrow> (Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"

equivariance sred
nominal_inductive sred
  by (simp add: abs_fresh)+

lemma better_sred_Abs:
  assumes H1: "r \<rightarrow>\<^sub>s r'"
  and H2: "ss [\<rightarrow>\<^sub>s] ss'"
  shows "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> ss'"
proof -
  obtain y::name where y: "y \<sharp> (x, r, r', ss, ss')"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> (ss, ss')" by simp
  moreover from H1 have "[(y, x)] \<bullet> (r \<rightarrow>\<^sub>s r')" by (rule perm_boolI)
  then have "([(y, x)] \<bullet> r) \<rightarrow>\<^sub>s ([(y, x)] \<bullet> r')" by (simp add: eqvts)
  ultimately have "(Lam [y]. [(y, x)] \<bullet> r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [y]. [(y, x)] \<bullet> r') \<degree>\<degree> ss'" using H2
    by (rule sred.Abs)
  moreover from y have "(Lam [x].r) = (Lam [y]. [(y, x)] \<bullet> r)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  moreover from y have "(Lam [x].r') = (Lam [y]. [(y, x)] \<bullet> r')"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis by simp
qed

lemma better_sred_Beta:
  assumes H: "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
  shows "(Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
proof -
  obtain y::name where y: "y \<sharp> (x, r, s, ss, t)"
    by (rule exists_fresh) (rule fin_supp)
  then have "y \<sharp> (s, ss, t)" by simp
  moreover from y H have "([(y, x)] \<bullet> r)[y::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
    by (simp add: subst_rename)
  ultimately have "(Lam [y].[(y, x)] \<bullet> r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"
    by (rule sred.Beta)
  moreover from y have "(Lam [x].r) = (Lam [y]. [(y, x)] \<bullet> r)"
    by (auto simp add: lam.inject alpha' fresh_prod fresh_atm)
  ultimately show ?thesis by simp
qed

lemmas better_sred_intros = sred.Var better_sred_Abs better_sred_Beta

lemma refl_listrelp: "\<forall>x\<in>set xs. R x x \<Longrightarrow> listrelp R xs xs"
  by (induct xs) (auto intro: listrelp.intros)

lemma refl_sred: "t \<rightarrow>\<^sub>s t"
  by (nominal_induct t rule: Apps_lam_induct) (auto intro: refl_listrelp better_sred_intros)

lemma listrelp_conj1: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp R x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_conj2: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp S x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_app:
  assumes xsys: "listrelp R xs ys"
  shows "listrelp R xs' ys' \<Longrightarrow> listrelp R (xs @ xs') (ys @ ys')" using xsys
  by (induct arbitrary: xs' ys') (auto intro: listrelp.intros)

lemma lemma1:
  assumes r: "r \<rightarrow>\<^sub>s r'" and s: "s \<rightarrow>\<^sub>s s'"
  shows "r \<degree> s \<rightarrow>\<^sub>s r' \<degree> s'" using r
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "rs @ [s] [\<rightarrow>\<^sub>s] rs' @ [s']" by (rule listrelp_app)
  hence "Var x \<degree>\<degree> (rs @ [s]) \<rightarrow>\<^sub>s Var x \<degree>\<degree> (rs' @ [s'])" by (rule sred.Var)
  thus ?case by (simp only: app_last)
next
  case (Abs x ss ss' r r')
  from Abs(4) have "ss [\<rightarrow>\<^sub>s] ss'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "ss @ [s] [\<rightarrow>\<^sub>s] ss' @ [s']" by (rule listrelp_app)
  with \<open>r \<rightarrow>\<^sub>s r'\<close> have "(Lam [x].r) \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> (ss' @ [s'])"
    by (rule better_sred_Abs)
  thus ?case by (simp only: app_last)
next
  case (Beta x u ss t r)
  hence "r[x::=u] \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (simp only: app_last)
  hence "(Lam [x].r) \<degree> u \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (rule better_sred_Beta)
  thus ?case by (simp only: app_last)
qed

lemma lemma1':
  assumes ts: "ts [\<rightarrow>\<^sub>s] ts'"
  shows "r \<rightarrow>\<^sub>s r' \<Longrightarrow> r \<degree>\<degree> ts \<rightarrow>\<^sub>s r' \<degree>\<degree> ts'" using ts
  by (induct arbitrary: r r') (auto intro: lemma1)

lemma listrelp_betas:
  assumes ts: "listrelp op \<rightarrow>\<^sub>\<beta>\<^sup>* ts ts'"
  shows "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<degree>\<degree> ts'" using ts
  by induct auto

lemma lemma2:
  assumes t: "t \<rightarrow>\<^sub>s u"
  shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using t
  by induct (auto dest: listrelp_conj2
    intro: listrelp_betas apps_preserves_beta converse_rtranclp_into_rtranclp)

lemma lemma3:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "s \<rightarrow>\<^sub>s s' \<Longrightarrow> r[x::=s] \<rightarrow>\<^sub>s r'[x::=s']" using r
proof (nominal_induct avoiding: x s s' rule: sred.strong_induct)
  case (Var rs rs' y)
  hence "map (\<lambda>t. t[x::=s]) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. t[x::=s']) rs'"
    by induct (auto intro: listrelp.intros Var)
  moreover have "Var y[x::=s] \<rightarrow>\<^sub>s Var y[x::=s']"
    by (cases "y = x") (auto simp add: Var intro: refl_sred)
  ultimately show ?case by simp (rule lemma1')
next
  case (Abs y ss ss' r r')
  then have "r[x::=s] \<rightarrow>\<^sub>s r'[x::=s']" by fast
  moreover from Abs(8) \<open>s \<rightarrow>\<^sub>s s'\<close> have "map (\<lambda>t. t[x::=s]) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. t[x::=s']) ss'"
    by induct (auto intro: listrelp.intros Abs)
  ultimately show ?case using Abs(6) \<open>y \<sharp> x\<close> \<open>y \<sharp> s\<close> \<open>y \<sharp> s'\<close>
    by simp (rule better_sred_Abs)
next
  case (Beta y u ss t r)
  thus ?case by (auto simp add: subst_subst fresh_atm intro: better_sred_Beta)
qed

lemma lemma4_aux:
  assumes rs: "listrelp (\<lambda>t u. t \<rightarrow>\<^sub>s u \<and> (\<forall>r. u \<rightarrow>\<^sub>\<beta> r \<longrightarrow> t \<rightarrow>\<^sub>s r)) rs rs'"
  shows "rs' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss \<Longrightarrow> rs [\<rightarrow>\<^sub>s] ss" using rs
proof (induct arbitrary: ss)
  case Nil
  thus ?case by cases (auto intro: listrelp.Nil)
next
  case (Cons x y xs ys)
  note Cons' = Cons
  show ?case
  proof (cases ss)
    case Nil with Cons show ?thesis by simp
  next
    case (Cons y' ys')
    hence ss: "ss = y' # ys'" by simp
    from Cons Cons' have "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys \<or> y' = y \<and> ys [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ys'" by simp
    hence "x # xs [\<rightarrow>\<^sub>s] y' # ys'"
    proof
      assume H: "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from Cons' have "xs [\<rightarrow>\<^sub>s] ys" by (iprover dest: listrelp_conj1)
      ultimately have "x # xs [\<rightarrow>\<^sub>s] y' # ys" by (rule listrelp.Cons)
      with H show ?thesis by simp
    next
      assume H: "y' = y \<and> ys [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ys'"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from H have "xs [\<rightarrow>\<^sub>s] ys'" by (blast intro: Cons')
      ultimately show ?thesis by (rule listrelp.Cons)
    qed
    with ss show ?thesis by simp
  qed
qed

lemma lemma4:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "r' \<rightarrow>\<^sub>\<beta> r'' \<Longrightarrow> r \<rightarrow>\<^sub>s r''" using r
proof (nominal_induct avoiding: r'' rule: sred.strong_induct)
  case (Var rs rs' x)
  then obtain ss where rs: "rs' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ss" and r'': "r'' = Var x \<degree>\<degree> ss"
    by (blast dest: head_Var_reduction)
  from Var(1) [simplified] rs have "rs [\<rightarrow>\<^sub>s] ss" by (rule lemma4_aux)
  hence "Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> ss" by (rule sred.Var)
  with r'' show ?case by simp
next
  case (Abs x ss ss' r r')
  from \<open>(Lam [x].r') \<degree>\<degree> ss' \<rightarrow>\<^sub>\<beta> r''\<close> show ?case
  proof (cases rule: apps_betasE [where x=x])
    case (appL s)
    then obtain r''' where s: "s = (Lam [x].r''')" and r''': "r' \<rightarrow>\<^sub>\<beta> r'''" using \<open>x \<sharp> r''\<close>
      by (cases rule: beta.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
    from r''' have "r \<rightarrow>\<^sub>s r'''" by (blast intro: Abs)
    moreover from Abs have "ss [\<rightarrow>\<^sub>s] ss'" by (iprover dest: listrelp_conj1)
    ultimately have "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r''') \<degree>\<degree> ss'" by (rule better_sred_Abs)
    with appL s show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    case (appR rs')
    from Abs(6) [simplified] \<open>ss' [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs'\<close>
    have "ss [\<rightarrow>\<^sub>s] rs'" by (rule lemma4_aux)
    with \<open>r \<rightarrow>\<^sub>s r'\<close> have "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> rs'" by (rule better_sred_Abs)
    with appR show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    case (beta t u' us')
    then have Lam_eq: "(Lam [x].r') = (Lam [x].t)" and ss': "ss' = u' # us'"
      and r'': "r'' = t[x::=u'] \<degree>\<degree> us'"
      by (simp_all add: abs_fresh)
    from Abs(6) ss' obtain u us where
      ss: "ss = u # us" and u: "u \<rightarrow>\<^sub>s u'" and us: "us [\<rightarrow>\<^sub>s] us'"
      by cases (auto dest!: listrelp_conj1)
    have "r[x::=u] \<rightarrow>\<^sub>s r'[x::=u']" using \<open>r \<rightarrow>\<^sub>s r'\<close> and u by (rule lemma3)
    with us have "r[x::=u] \<degree>\<degree> us \<rightarrow>\<^sub>s r'[x::=u'] \<degree>\<degree> us'" by (rule lemma1')
    hence "(Lam [x].r) \<degree> u \<degree>\<degree> us \<rightarrow>\<^sub>s r'[x::=u'] \<degree>\<degree> us'" by (rule better_sred_Beta)
    with ss r'' Lam_eq show "(Lam [x].r) \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by (simp add: lam.inject alpha)
  qed
next
  case (Beta x s ss t r)
  show ?case
    by (rule better_sred_Beta) (rule Beta)+
qed

lemma rtrancl_beta_sred:
  assumes r: "r \<rightarrow>\<^sub>\<beta>\<^sup>* r'"
  shows "r \<rightarrow>\<^sub>s r'" using r
  by induct (iprover intro: refl_sred lemma4)+

subsection \<open>Terms in normal form\<close>

lemma listsp_eqvt [eqvt]:
  assumes xs: "listsp p (xs::'a::pt_name list)"
  shows "listsp ((pi::name prm) \<bullet> p) (pi \<bullet> xs)" using xs
  apply induct
  apply simp
  apply simp
  apply (rule listsp.intros)
  apply (drule_tac pi=pi in perm_boolI)
  apply perm_simp
  apply assumption
  done

inductive NF :: "lam \<Rightarrow> bool"
where
  App: "listsp NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
| Abs: "NF t \<Longrightarrow> NF (Lam [x].t)"

equivariance NF
nominal_inductive NF
  by (simp add: abs_fresh)

lemma Abs_NF:
  assumes NF: "NF ((Lam [x].t) \<degree>\<degree> ts)"
  shows "ts = []" using NF
proof cases
  case (App us i)
  thus ?thesis by (simp add: Var_apps_neq_Abs_apps [THEN not_sym])
next
  case (Abs u)
  thus ?thesis by simp
qed

text \<open>
@{term NF} characterizes exactly the terms that are in normal form.
\<close>

lemma NF_eq: "NF t = (\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t')"
proof
  assume H: "NF t"
  show "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  proof
    fix t'
    from H show "\<not> t \<rightarrow>\<^sub>\<beta> t'"
    proof (nominal_induct avoiding: t' rule: NF.strong_induct)
      case (App ts t)
      show ?case
      proof
        assume "Var t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> t'"
        then obtain rs where "ts [\<rightarrow>\<^sub>\<beta>]\<^sub>1 rs"
          by (iprover dest: head_Var_reduction)
        with App show False
          by (induct rs arbitrary: ts) (auto del: in_listspD)
      qed
    next
      case (Abs t x)
      show ?case
      proof
        assume "(Lam [x].t) \<rightarrow>\<^sub>\<beta> t'"
        then show False using Abs
          by (cases rule: beta.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
      qed
    qed
  qed
next
  assume H: "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  then show "NF t"
  proof (nominal_induct t rule: Apps_lam_induct)
    case (1 n ts)
    then have "\<forall>ts'. \<not> ts [\<rightarrow>\<^sub>\<beta>]\<^sub>1 ts'"
      by (iprover intro: apps_preserves_betas)
    with 1(1) have "listsp NF ts"
      by (induct ts) (auto simp add: in_listsp_conv_set)
    then show ?case by (rule NF.App)
  next
    case (2 x u ts)
    show ?case
    proof (cases ts)
      case Nil thus ?thesis by (metis 2 NF.Abs abs foldl_Nil)
    next
      case (Cons r rs)
      have "(Lam [x].u) \<degree> r \<rightarrow>\<^sub>\<beta> u[x::=r]" ..
      then have "(Lam [x].u) \<degree> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> u[x::=r] \<degree>\<degree> rs"
        by (rule apps_preserves_beta)
      with Cons have "(Lam [x].u) \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> u[x::=r] \<degree>\<degree> rs"
        by simp
      with 2 show ?thesis by iprover
    qed
  qed
qed

subsection \<open>Leftmost reduction and weakly normalizing terms\<close>

inductive
  lred :: "lam \<Rightarrow> lam \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>l" 50)
  and lredlist :: "lam list \<Rightarrow> lam list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>l]" 50)
where
  "s [\<rightarrow>\<^sub>l] t \<equiv> listrelp op \<rightarrow>\<^sub>l s t"
| Var: "rs [\<rightarrow>\<^sub>l] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>l Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>l r' \<Longrightarrow> (Lam [x].r) \<rightarrow>\<^sub>l (Lam [x].r')"
| Beta: "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>l t \<Longrightarrow> (Lam [x].r) \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>l t"

lemma lred_imp_sred:
  assumes lred: "s \<rightarrow>\<^sub>l t"
  shows "s \<rightarrow>\<^sub>s t" using lred
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (rule sred.Var)
next
  case (Abs r r' x)
  from \<open>r \<rightarrow>\<^sub>s r'\<close>
  have "(Lam [x].r) \<degree>\<degree> [] \<rightarrow>\<^sub>s (Lam [x].r') \<degree>\<degree> []" using listrelp.Nil
    by (rule better_sred_Abs)
  then show ?case by simp
next
  case (Beta r x s ss t)
  from \<open>r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>s t\<close>
  show ?case by (rule better_sred_Beta)
qed

inductive WN :: "lam \<Rightarrow> bool"
  where
    Var: "listsp WN rs \<Longrightarrow> WN (Var n \<degree>\<degree> rs)"
  | Lambda: "WN r \<Longrightarrow> WN (Lam [x].r)"
  | Beta: "WN ((r[x::=s]) \<degree>\<degree> ss) \<Longrightarrow> WN (((Lam [x].r) \<degree> s) \<degree>\<degree> ss)"

lemma listrelp_imp_listsp1:
  assumes H: "listrelp (\<lambda>x y. P x) xs ys"
  shows "listsp P xs" using H
  by induct auto

lemma listrelp_imp_listsp2:
  assumes H: "listrelp (\<lambda>x y. P y) xs ys"
  shows "listsp P ys" using H
  by induct auto

lemma lemma5:
  assumes lred: "r \<rightarrow>\<^sub>l r'"
  shows "WN r" and "NF r'" using lred
  by induct
    (iprover dest: listrelp_conj1 listrelp_conj2
     listrelp_imp_listsp1 listrelp_imp_listsp2 intro: WN.intros
     NF.intros)+

lemma lemma6:
  assumes wn: "WN r"
  shows "\<exists>r'. r \<rightarrow>\<^sub>l r'" using wn
proof induct
  case (Var rs n)
  then have "\<exists>rs'. rs [\<rightarrow>\<^sub>l] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (iprover intro: lred.Var)
qed (iprover intro: lred.intros)+

lemma lemma7:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "NF r' \<Longrightarrow> r \<rightarrow>\<^sub>l r'" using r
proof induct
  case (Var rs rs' x)
  from \<open>NF (Var x \<degree>\<degree> rs')\<close> have "listsp NF rs'"
    by cases simp_all
  with Var(1) have "rs [\<rightarrow>\<^sub>l] rs'"
  proof induct
    case Nil
    show ?case by (rule listrelp.Nil)
  next
    case (Cons x y xs ys)
    hence "x \<rightarrow>\<^sub>l y" and "xs [\<rightarrow>\<^sub>l] ys" by (auto del: in_listspD)
    thus ?case by (rule listrelp.Cons)
  qed
  thus ?case by (rule lred.Var)
next
  case (Abs x ss ss' r r')
  from \<open>NF ((Lam [x].r') \<degree>\<degree> ss')\<close>
  have ss': "ss' = []" by (rule Abs_NF)
  from Abs(4) have ss: "ss = []" using ss'
    by cases simp_all
  from ss' Abs have "NF (Lam [x].r')" by simp
  hence "NF r'" by (cases rule: NF.strong_cases) (auto simp add: abs_fresh lam.inject alpha)
  with Abs have "r \<rightarrow>\<^sub>l r'" by simp
  hence "(Lam [x].r) \<rightarrow>\<^sub>l (Lam [x].r')" by (rule lred.Abs)
  with ss ss' show ?case by simp
next
  case (Beta x s ss t r)
  hence "r[x::=s] \<degree>\<degree> ss \<rightarrow>\<^sub>l t" by simp
  thus ?case by (rule lred.Beta)
qed

lemma WN_eq: "WN t = (\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
proof
  assume "WN t"
  then have "\<exists>t'. t \<rightarrow>\<^sub>l t'" by (rule lemma6)
  then obtain t' where t': "t \<rightarrow>\<^sub>l t'" ..
  then have NF: "NF t'" by (rule lemma5)
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule lred_imp_sred)
  then have "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" by (rule lemma2)
  with NF show "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by iprover
next
  assume "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  then obtain t' where t': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and NF: "NF t'"
    by iprover
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule rtrancl_beta_sred)
  then have "t \<rightarrow>\<^sub>l t'" using NF by (rule lemma7)
  then show "WN t" by (rule lemma5)
qed

end


section \<open>Tree Decompositions\<close>

theory TreeDecomposition
imports Tree begin

text \<open>A tree decomposition of a graph.\<close>

locale TreeDecomposition = Graph G + T: Tree T
  for G :: "('a, 'b) Graph_scheme" (structure) and T :: "('c,'d) Graph_scheme" +
  fixes bag :: "'c \<Rightarrow> 'a set"
  assumes
    \<comment> \<open>Every vertex appears somewhere\<close>
    bags_union: "\<Union> { bag t | t. t \<in> V\<^bsub>T\<^esub> } = V"
     \<comment> \<open>Every edge is covered\<close>
    and bags_edges: "v\<rightarrow>w \<Longrightarrow> \<exists>t \<in> V\<^bsub>T\<^esub>. v \<in> bag t \<and> w \<in> bag t"
    \<comment> \<open>Every vertex appearing in @{term s} and @{term u} also appears in every bag on the path
        connecting @{term s} and @{term u}\<close>
    and bags_continuous: "\<lbrakk> s \<in> V\<^bsub>T\<^esub>; u \<in> V\<^bsub>T\<^esub>; t \<in> set (s \<leadsto>\<^bsub>T\<^esub> u) \<rbrakk> \<Longrightarrow> bag s \<inter> bag u \<subseteq> bag t"
begin
text \<open>
  Following the usual literature, we will call elements of @{term V} vertices and
  elements of @{term "V\<^bsub>T\<^esub>"} bags (or nodes) from now on.\<close>

subsection \<open>Width of a Tree Decomposition\<close>

text \<open>We define the width of this tree decomposition as the size of the largest bag minus 1.\<close>
abbreviation "bag_cards \<equiv> { card (bag t) | t. t \<in> V\<^bsub>T\<^esub> }"
definition "max_bag_card \<equiv> Max bag_cards"
text \<open>We need a special case for @{term "V\<^bsub>T\<^esub> = {}"} because in this case @{const max_bag_card}
  is not well-defined.\<close>
definition "width \<equiv> if V\<^bsub>T\<^esub> = {} then 0 else max_bag_card - 1"

lemma bags_in_V: "t \<in> V\<^bsub>T\<^esub> \<Longrightarrow> bag t \<subseteq> V" using bags_union Sup_upper mem_Collect_eq by blast
lemma bag_finite: "t \<in> V\<^bsub>T\<^esub> \<Longrightarrow> finite (bag t)" using bags_in_V finite_subset finite_vertex_set by blast
lemma bag_bound_V: "t \<in> V\<^bsub>T\<^esub> \<Longrightarrow> card (bag t) \<le> card V" by (simp add: bags_in_V card_mono finite_vertex_set)
lemma bag_bound_V_empty: "\<lbrakk> V = {}; t \<in> V\<^bsub>T\<^esub> \<rbrakk> \<Longrightarrow> card (bag t) = 0" using bag_bound_V by auto
lemma empty_tree_empty_V: "V\<^bsub>T\<^esub> = {} \<Longrightarrow> V = {}" using bags_union by simp
lemma bags_exist: "v \<in> V \<Longrightarrow> \<exists>t \<in> V\<^bsub>T\<^esub>. v \<in> bag t" using bags_union using UnionE mem_Collect_eq by auto

text \<open>
  The width is never larger than the number of vertices, and if there is at least one vertex
  in the graph, then it is always smaller.  This is trivially true because a bag contains at most
  all of @{term V}.  However, the proof is not fully trivial because we also need to show that
  @{const width} is well-defined.\<close>

lemma width_upper_bound_V: "V \<noteq> {} \<Longrightarrow> width < card V" unfolding width_def
  using max_bag_card_upper_bound_V max_bag_card_lower_bound_1
    diff_less empty_tree_empty_V le_neq_implies_less less_imp_diff_less zero_less_one by presburger

end \<comment> \<open>locale TreeDecomposition\<close>

subsection \<open>Treewidth of a Graph\<close>

context Graph begin

text \<open>The treewidth of a graph is the minimum treewidth over all its tree decompositions.
  Here we assume without loss of generality that the universe of the vertices of the tree
  is @{type nat}.  Because trees are finite, @{type nat} always contains enough elements.\<close>
abbreviation treewidth_cards :: "nat set" where "treewidth_cards \<equiv>
  { TreeDecomposition.width T bag | (T :: nat Graph) bag. TreeDecomposition G T bag }"
definition treewidth :: "nat" where "treewidth \<equiv> Min treewidth_cards"

text \<open>Every graph has a trivial tree decomposition consisting of a single bag containing all of
  @{term V}.\<close>
proposition tree_decomposition_exists: "\<exists>(T :: 'c Graph) bag. TreeDecomposition G T bag" proof-
  obtain x where "x \<in> (UNIV :: 'c set)" by blast
  define T where [simp]: "T = \<lparr> verts = {x}, arcs = {} \<rparr>"
  define bag where [simp]: "bag = (\<lambda>_ :: 'c. V)"
  have "Graph T" by unfold_locales simp_all
  then interpret T: Graph T .
  have "\<And>xs. \<not>T.cycle xs" using T.cycleE by auto
  moreover have "\<And>v w. v \<in> V\<^bsub>T\<^esub> \<Longrightarrow> w \<in> V\<^bsub>T\<^esub> \<Longrightarrow> T.connected v w" using T.connected_refl by auto
  ultimately have "Tree T" by unfold_locales
  then interpret T: Tree T .
  have "TreeDecomposition G T bag" by unfold_locales (simp_all add: edges_are_in_V)
  thus ?thesis by blast
qed

corollary treewidth_cards_upper_bound_V: "n \<in> treewidth_cards \<Longrightarrow> n \<le> card V - 1"
  using TreeDecomposition.width_bound_V_le by blast
corollary treewidth_cards_finite: "finite treewidth_cards"
  using treewidth_cards_upper_bound_V finite_nat_set_iff_bounded_le by auto
corollary treewidth_cards_nonempty: "treewidth_cards \<noteq> {}" by (simp add: tree_decomposition_exists)

lemma treewidth_cards_treewidth:
  "\<exists>(T :: nat Graph) bag. TreeDecomposition G T bag \<and> treewidth = TreeDecomposition.width T bag"
  using Min_in treewidth_cards_finite treewidth_cards_nonempty treewidth_def by fastforce

corollary treewidth_upper_bound_V: "treewidth \<le> card V - 1" unfolding treewidth_def
  using treewidth_cards_nonempty Min_in treewidth_cards_finite treewidth_cards_upper_bound_V by auto
corollary treewidth_upper_bound_0: "V = {} \<Longrightarrow> treewidth = 0" using treewidth_upper_bound_V by simp
corollary treewidth_upper_bound_1: "card V = 1 \<Longrightarrow> treewidth = 0" using treewidth_upper_bound_V by simp
corollary treewidth_lower_bound_1: "v\<rightarrow>w \<Longrightarrow> treewidth \<ge> 1"
  using TreeDecomposition.width_lower_bound_1 treewidth_cards_treewidth by fastforce

lemma treewidth_upper_bound_ex:
  "\<lbrakk> TreeDecomposition G (T :: nat Graph) bag; TreeDecomposition.width T bag \<le> n \<rbrakk> \<Longrightarrow> treewidth \<le> n"
  unfolding treewidth_def
  by (metis (mono_tags, lifting) Min_le dual_order.trans mem_Collect_eq treewidth_cards_finite)

end \<comment> \<open>locale Graph\<close>

subsection \<open>Separations\<close>

context TreeDecomposition begin

text \<open>
  Every edge @{term "s\<rightarrow>\<^bsub>T\<^esub> t"} in @{term T} separates @{term T}.  In a tree decomposition,
  this edge also separates @{term G}.  Proving this is our goal.  First, let us define the set of
  vertices appearing in the left subtree when separating the tree at @{term "s \<rightarrow>\<^bsub>T\<^esub> t"}.
\<close>
definition left_part :: "'c \<Rightarrow> 'c \<Rightarrow> 'a set" where
  "left_part s t \<equiv> \<Union>{ bag u | u. u \<in> T.left_tree s t }"
lemma left_partI [intro]: "\<lbrakk> v \<in> bag u; u \<in> T.left_tree s t \<rbrakk> \<Longrightarrow> v \<in> left_part s t"
  unfolding left_part_def by blast

lemma left_part_in_V: "left_part s t \<subseteq> V" unfolding left_part_def
  using T.left_tree_in_V bags_in_V by blast

text \<open>Let us define the subgraph of @{term T} induced by a vertex of @{term G}.\<close>
definition vertex_subtree :: "'a \<Rightarrow> 'c set" where
  "vertex_subtree v \<equiv> { t \<in> V\<^bsub>T\<^esub>. v \<in> bag t }"
lemma vertex_subtreeI [intro]: "\<lbrakk> t \<in> V\<^bsub>T\<^esub>; v \<in> bag t \<rbrakk> \<Longrightarrow> t \<in> vertex_subtree v"
  unfolding vertex_subtree_def by blast

text \<open>
  The suggestive name @{const vertex_subtree} is correct: Because @{term T} is a tree
  decomposition, @{term "vertex_subtree v"} is a subtree (it is connected).\<close>
lemma vertex_subtree_connected:
  assumes v: "v \<in> V" and s: "s \<in> vertex_subtree v" and t: "t \<in> vertex_subtree v"
    and xs: "s \<leadsto>xs\<leadsto>\<^bsub>T\<^esub> t"
  shows "set xs \<subseteq> vertex_subtree v"
using assms proof (induct xs arbitrary: s)
  case (Cons x xs)
  show ?case proof (cases)
    assume "xs = []" thus ?thesis using Cons.prems(3,4) by auto
  next
    assume "xs \<noteq> []"
    moreover hence "last xs = t" using Cons.prems(4) last.simps by auto
    moreover have "T.path xs" using Cons.prems(4) T.walk_tl by fastforce
    moreover have "hd xs \<in> vertex_subtree v" proof
      have "hd xs \<in> set (s \<leadsto>\<^bsub>T\<^esub> t)" using T.unique_connecting_path_unique
        using Cons.prems(4) \<open>xs \<noteq> []\<close> by auto
      hence "bag s \<inter> bag t \<subseteq> bag (hd xs)"
        using bags_continuous Cons.prems(4) T.connected_in_V by blast
      thus "v \<in> bag (hd xs)" using Cons.prems(2,3) unfolding vertex_subtree_def by blast
      show "hd xs \<in> V\<^bsub>T\<^esub>" using T.connected_in_V(1) \<open>xs \<noteq> []\<close> \<open>T.path xs\<close> by blast
    qed
    ultimately have "set xs \<subseteq> vertex_subtree v" using Cons.hyps Cons.prems(1,3) by blast
    thus ?thesis using Cons.prems(2,4) by auto
  qed
qed simp

corollary vertex_subtree_unique_path_connected:
  assumes "v \<in> V" "s \<in> vertex_subtree v" "t \<in> vertex_subtree v"
  shows "set (s \<leadsto>\<^bsub>T\<^esub> t) \<subseteq> vertex_subtree v"
  using assms vertex_subtree_connected T.unique_connecting_path_properties
  by (metis (no_types, lifting) T.unique_connecting_path T.unique_connecting_path_unique
      mem_Collect_eq vertex_subtree_def)

text \<open>
  In order to prove that edges in @{term T} are separations in @{term G}, we need one key lemma.
  If a vertex appears on both sides of a separation, then it also appears in the separation.
\<close>

text \<open>Now we can show the main theorem: For every edge @{term "s \<rightarrow>\<^bsub>T\<^esub> t"} in @{term T}, the
  set @{term "bag s \<inter> bag t"} is a separator of @{term G}.  That is, every path from the left part
  to the right part goes through @{term "bag s \<inter> bag t"}.\<close>
theorem bags_separate:
  assumes st: "s \<rightarrow>\<^bsub>T\<^esub> t" and v: "v \<in> left_part s t" and w: "w \<in> left_part t s" and xs: "v \<leadsto>xs\<leadsto> w"
  shows "set xs \<inter> bag s \<inter> bag t \<noteq> {}"
proof (rule ccontr)
  assume "\<not>?thesis"
  {
    fix u assume "u \<in> set xs"
    with xs v \<open>\<not>?thesis\<close> have "vertex_subtree u \<subseteq> T.left_tree s t"
    proof (induct xs arbitrary: v)
      case (Cons x xs v)
      hence contra: "v \<notin> bag s \<or> v \<notin> bag t" by (metis path_from_toE IntI empty_iff hd_in_set)
      {
        assume "x = u" "\<not>vertex_subtree u \<subseteq> T.left_tree s t"
        then obtain z where z: "z \<in> vertex_subtree u" "z \<notin> T.left_tree s t" by blast
        hence "z \<in> vertex_subtree v" using Cons.prems(1,3) \<open>x = u\<close>
          by (metis list.sel(1) path_from_to_def)
        hence "v \<in> left_part t s" unfolding vertex_subtree_def
          using T.left_tree_union_V z st by auto
        hence False using vertex_in_separator contra st Cons.prems(2) by blast
      }
      moreover {
        assume "x \<noteq> u"
        hence "u \<in> set xs" using Cons.prems(4) by auto
        moreover hence "xs \<noteq> Nil" using empty_iff list.set(1) by auto
        moreover hence "last xs = w" using Cons.prems(1) by auto
        moreover have "path xs" using Cons.prems(1) walk_tl by force
        moreover have "hd xs \<in> left_part s t" proof-
          have "v\<rightarrow>hd xs" using Cons.prems(1,3) \<open>xs \<noteq> Nil\<close> walk_first_edge' by auto
          then obtain u' where u': "u' \<in> V\<^bsub>T\<^esub>" "v \<in> bag u'" "hd xs \<in> bag u'"
            using bags_edges by blast
          hence "u' \<in> T.left_tree s t"
            using contra vertex_in_separator st T.left_tree_union_V Cons.prems(2) by blast
          thus ?thesis using u'(3) unfolding left_part_def by blast
        qed
        moreover have "\<not>set xs \<inter> bag s \<inter> bag t \<noteq> {}" using Cons.prems(3)
          IntI disjoint_iff_not_equal inf_le1 inf_le2 set_subset_Cons subsetCE by auto
        ultimately have "vertex_subtree u \<subseteq> T.left_tree s t" using Cons.hyps by blast
      }
      ultimately show ?case by blast
    qed simp
  }
  hence "vertex_subtree w \<subseteq> T.left_tree s t" using xs last_in_set by blast
  moreover have "vertex_subtree w \<inter> T.left_tree t s \<noteq> {}" using w
    unfolding left_part_def T.left_tree_def by blast
  ultimately show False using T.left_tree_disjoint st by blast
qed

text \<open>It follows that vertices cannot be dropped from a bag if they have a neighbor that has
  not been visited yet (that is, a neighbor that is strictly in the right part of the separation).\<close>
corollary bag_no_drop:
  assumes st: "s \<rightarrow>\<^bsub>T\<^esub> t" and vw: "v\<rightarrow>w" and v: "v \<in> bag s" and w: "w \<notin> bag s" "w \<in> left_part t s"
  shows "v \<in> bag t"
proof-
  have "v \<leadsto>[v,w]\<leadsto> w" using v vw w(1) by auto
  hence "set [v,w] \<inter> bag s \<inter> bag t \<noteq> {}" using st v w(2)
    by (meson T.edges_are_in_V T.left_tree_initial bags_separate left_partI)
  thus ?thesis using w(1) by auto
qed

end \<comment> \<open>locale TreeDecomposition\<close>
end


theory Int_Pair_State_Monad
imports
  Main
  "~~/src/HOL/Library/State_Monad"

begin

type_synonym 'a pair = "'a \<times> 'a"

definition return:: "'a \<Rightarrow> ('b, 'a) state" where "return = State_Monad.return"
definition get:: "('a pair, 'a pair) state" where "get = State (\<lambda>x. (x,x))"
definition put:: "'a pair \<Rightarrow> ('a pair, unit) state" where "put x = State (\<lambda>_. ((),x))"
definition get_fst:: "('a pair, 'a) state" where "get_fst = do { x \<leftarrow> get; return (fst x) }"
definition get_snd:: "('a pair, 'a) state" where "get_snd = do { x \<leftarrow> get; return (snd x) }"
definition set_fst:: "'a pair \<Rightarrow> 'a \<Rightarrow> 'a pair" where "set_fst v x = (x, snd v)"
definition set_snd:: "'a pair \<Rightarrow> 'a \<Rightarrow> 'a pair" where "set_snd v x = (fst v, x)"
definition put_fst:: "'a \<Rightarrow> ('a pair, unit) state" where "put_fst x = do { v \<leftarrow> get; put (set_fst v x) }"
definition put_snd:: "'a \<Rightarrow> ('a pair, unit) state" where "put_snd x = do { v \<leftarrow> get; put (set_snd v x) }"
definition skip:: "('a pair, unit) state" where "skip = State (\<lambda>x. ((),x))"

definition inject_npu:: "(nat pair, unit) state" where "inject_npu = State (\<lambda>x. ((),x))"

fun monfact:: "nat \<Rightarrow> (nat pair, unit) state" where
mf1: "monfact 0 = skip" |
mf2: "monfact (Suc n) = do { y \<leftarrow> get_fst; y \<leftarrow> return (y * (Suc n)); put_fst y; monfact n }"

fun fibacc :: "nat \<Rightarrow> nat => nat \<Rightarrow> nat" where
fa1: "fibacc 0 a b = a"|
fa2: "fibacc (Suc 0) a b = b"|
fa3: "fibacc (Suc (Suc n)) a b = fibacc (Suc n) b (a+b)"

value \<open>fibacc 6 0 1 = 8\<close>
value \<open>fibacc 9 0 1 = 34\<close>

definition fib_wrap:: "nat \<Rightarrow> nat" where
"fib_wrap n = fibacc n 0 1"

fun fib :: "nat => nat" where
  "fib 0 = 0"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc x)) = fib x + fib (Suc x)"

lemma [simp]: "fibacc (Suc n) 0 1 > 0"
  proof (induction n)
    case 0
    then show ?case by simp
  next
    case (Suc n)
    assume "fibacc n 0 1 > 0"
    from this have "fibacc (Suc n) 0 1 \<ge> fibacc n 0 1" by (simp add: fa1 fa2 fa3)
    from this and `fibacc n 0 1 > 0` show  "fibacc (Suc n) 0 1 > 0"
      using (Suc.IH) by blast
  qed

lemma [simp]: "fib (Suc n) > 0"
  by (induct n rule: fib.induct) simp_all

text {* Alternative induction rule. *}
theorem fib_induct:
    "P 0 ==> P 1 ==> (\<And>n. P (n + 1) ==> P n ==> P (n + 2)) ==> P (n::nat)"
  by (induct rule: fib.induct) simp_all

text\<open>The fibonacci function does always return the result at the fst value of the pair. The initial state passed in should be (0,1)\<close>
fun monfib:: "nat \<Rightarrow> (nat pair, unit) state" where
  "monfib 0 = skip" |
  "monfib (Suc 0) = do {a \<leftarrow> get_snd; put_fst a}" |
  "monfib (Suc (Suc n)) = do { a \<leftarrow> get_fst; b \<leftarrow> get_snd; temp_b \<leftarrow> return b; b \<leftarrow> return (a + b); put (temp_b,b); monfib (Suc n)}"

value \<open>fst(snd(run_state (monfib 4) e))\<close>

lemma fib_add:
  "fib (n + k + 1) = fib (k + 1) * fib (n + 1) + fib k * fib n"
  (is "?P n")
proof (induct n rule: fib_induct)
  show "?P 0" by simp
  show "?P 1" by simp
  fix n
  have "fib (n + 2 + k + 1)
    = fib (n + k + 1) + fib (n + 1 + k + 1)" by simp
  also assume "fib (n + k + 1)
    = fib (k + 1) * fib (n + 1) + fib k * fib n"
      (is " _ = ?R1")
  also assume "fib (n + 1 + k + 1)
    = fib (k + 1) * fib (n + 1 + 1) + fib k * fib (n + 1)"
      (is " _ = ?R2")
  also have "?R1 + ?R2
    = fib (k + 1) * fib (n + 2 + 1) + fib k * fib (n + 2)"
    by (simp add: add_mult_distrib2)
  finally show "?P (n + 2)" .
qed

lemma monfib_aux: "fst(snd (run_state (monfib (Suc (Suc n))) x)) = fst(snd (run_state (monfib n) x)) + fst(snd (run_state (monfib (Suc n)) x))"
  apply (induction n arbitrary: x)
   apply (simp add:  skip_def)
   apply (simp add: get_def set_fst_def)
  sledgehammer

lemma fib_basic: "fst(snd(run_state (monfib n) x)) = fibacc n ((fst x)::nat) ((snd x)::nat)"
  apply (induction n arbitrary: x)
   apply (simp add:  skip_def)
  sorry

value \<open>fst(snd (run_state (monfact 10) e))\<close>
lemma monfact_mult: "fst(snd (run_state (monfact n) (a * b, y))) =  b * fst(snd (run_state (monfact n) (a, y)))"
  apply (induction n arbitrary: a b)
  apply (simp add: skip_def)
  apply (simp add: return_def put_def get_def)
  by (metis mult.assoc mult.commute mult_Suc)

lemma monfact_shift: "fst(snd (run_state (monfact (Suc n)) (x,y))) = fst(snd (run_state (monfact n) ((Suc n) * x, y)))"
  apply (induction n arbitrary: x y)
  apply (simp add: get_fst_def put_fst_def return_def)
   apply (simp add: put_fst_def return_def get_def fst_def snd_def)
  sorry

lemma monfact_aux: "fst(snd (run_state (monfact (Suc n)) x)) = (Suc n) * fst(snd (run_state (monfact n) x))"
  apply (induction n arbitrary: x)
   apply (simp add: skip_def return_def get_def put_def)
  by (metis monfact_mult monfact_shift mult.commute)

fun accfact:: "nat \<Rightarrow> nat \<Rightarrow> nat" where
af1:  "accfact 0 a = a" |
af2: "accfact (Suc n) a = accfact n (a * Suc n)"

lemma accfact_mult: "accfact n (a * b) = b * accfact n a"
  apply (induction n arbitrary: a b)
   apply (simp)
  apply (simp only: af2)
  by (simp add: semiring_normalization_rules(19))

lemma accfact_aux: "accfact (Suc n) x = (Suc n) * accfact n x"
  apply (induction n)
   apply simp
  using Int_Pair_State_Monad.af2 accfact_mult by presburger

value "fst(snd (run_state (monfact 6) (1::nat, y::nat)))"
value "accfact 6 1"

lemma fact_basic: "fst(snd (run_state (monfact n) (x::nat,y::nat))) = accfact n (fst(x::nat,y::nat))"
  apply (induction n arbitrary: x y)
   apply (simp add: put_fst_def get_fst_def snd_def fst_def skip_def)
  sledgehammer

lemma monad_example1: "fst(snd(run_state (do { put (1, 1) }) (0, 0))) = 1"
  by (simp add: put_def)

lemma monad_example2: "snd(snd(run_state (do { put (1, 1) }) (0, 0))) = 1"
  by (simp add: put_def)

lemma monad_example3: "fst(run_state (do { put (1, 2); x \<leftarrow> get_fst; return x }) (0, 0)) = 1"
  by (simp add: get_fst_def put_def get_def return_def)

lemma monad_example4: "fst(run_state (do { put (1, 2); x \<leftarrow> get_snd; return x }) (0, 0)) = 2"
  by (simp add: get_snd_def put_def get_def return_def)

value "snd(snd((run_state (do { x \<leftarrow> return (3::nat); put_snd x })) (2, 2)))"

lemma monad_example5: "snd(snd((run_state (do { x \<leftarrow> return 1; put_snd x })) (2, 2))) = 1"
  by (simp add: put_snd_def put_def set_snd_def get_def return_def)

lemma monad_example6: "fst(snd((run_state (do { x \<leftarrow> return 1; put_snd x })) (2, 2))) = 2"
  by (simp add: put_snd_def put_def set_snd_def get_def return_def)

definition swap:: "(nat pair, unit) state"
  where "swap = do { a \<leftarrow> get_fst; b \<leftarrow> get_snd; put_fst b; put_snd a }"

lemma monad_example7: "snd (run_state swap (x,y)) = (y,x)"
  by (simp add: swap_def put_def get_fst_def get_snd_def put_fst_def put_snd_def set_fst_def set_snd_def get_def return_def)

end


(*  Title:       Presburger Example Implementation
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> Presburger Automata Implementation \<close>

theory RBT_Presburger_Impl
imports Main
        "../../../Presburger_Adapt"
        RBT_NFAImpl

begin

(*
instantiation "bool" :: linorder
begin
  instance by (intro_classes, auto)
end
*)

definition lexord_lexord_less where
  "lexord_lexord_less (l1::('a::linorder) list) l2 = ((l1, l2) \<in> lexord {(x,y) |x y. x < y})"

definition lexord_lexord_less_eq where
  "lexord_lexord_less_eq l1 l2 \<longleftrightarrow> (lexord_lexord_less l1 l2) \<or> (l1 = l2)"

lemma [simp] : "lexord_lexord_less_eq l l" unfolding lexord_lexord_less_eq_def by simp

lemma lexord_lexord_less_irreflexive [simp] : "\<not>(lexord_lexord_less l l)"
proof -
  have R_irreflexive: "\<forall>x. (x::('a::linorder), x) \<notin> {(x,y) |x y. x < y}"
    by simp
  note this_irrefl = lexord_irreflexive [OF R_irreflexive]

  thus ?thesis unfolding lexord_lexord_less_def by simp
qed

lemma lexord_lexord_less_trans :
assumes l1_l2_less: "lexord_lexord_less l1 l2"
    and l2_l3_less: "lexord_lexord_less l2 l3"
shows "lexord_lexord_less l1 l3"
proof -
  have R_trans : "trans {(x::('a::linorder),y) |x y. x < y}" unfolding trans_def by auto
  note this_trans = lexord_trans [OF _ _ R_trans]

  with l1_l2_less l2_l3_less show ?thesis
    unfolding lexord_lexord_less_def by blast
qed

lemma lexord_lexord_less_linear :
shows "lexord_lexord_less l1 l2 \<or> (l1 = l2) \<or> lexord_lexord_less l2 l1"
proof -
  define R where "R \<equiv> {(x::('a::linorder),y::'a). x < y}"
  have R_linear : "\<forall>a b. (a, b) \<in> R \<or> a = b \<or> (b, a) \<in> R"
    unfolding R_def trans_def by auto
  note this_linear = lexord_linear[OF R_linear]
  thus ?thesis
    unfolding lexord_lexord_less_def unfolding R_def by simp
qed

lemma lexord_lexord_less_eval [simp, code] :
  "lexord_lexord_less [] [] = False"
  "lexord_lexord_less [] (y # ys) = True"
  "lexord_lexord_less (x # xs) [] = False"
  "lexord_lexord_less (x # xs) (y # ys) =
    (if (x < y) then True else
    (if (x = y) then lexord_lexord_less xs ys else False))"
unfolding lexord_lexord_less_def by simp_all

lemma lexord_lexord_less_eq_eval [simp, code] :
  "lexord_lexord_less_eq [] [] = True"
  "lexord_lexord_less_eq [] (y # ys) = True"
  "lexord_lexord_less_eq (x # xs) [] = False"
  "lexord_lexord_less_eq (x # xs) (y # ys) =
    (if (x < y) then True else
    (if (x = y) then lexord_lexord_less_eq xs ys else False))"
unfolding lexord_lexord_less_eq_def by simp_all

instantiation "list" :: (linorder) linorder
begin

  definition [simp] : "less (l1::'a list) (l2::'a list) == lexord_lexord_less l1 l2"
  definition [simp] : "less_eq (l1::'a list) l2 == lexord_lexord_less_eq l1 l2"

  instance proof (intro_classes)
    fix xs :: "'a list"
    show "xs \<le> xs" by (auto simp add: lexord_lexord_less_eq_def)
  next
    fix xs :: "'a list"
    fix ys :: "'a list"
    show "(xs < ys) = (xs \<le> ys \<and> \<not> ys \<le> xs)"
      apply (auto simp add: lexord_lexord_less_eq_def)
      apply (metis lexord_lexord_less_trans lexord_lexord_less_irreflexive)
    done

    show "xs \<le> ys \<or> ys \<le> xs"
      apply (simp add: lexord_lexord_less_eq_def)
      apply (metis lexord_lexord_less_linear)
    done

    {
      assume "xs \<le> ys" "ys \<le> xs"
      thus "xs = ys"
        apply (simp add: lexord_lexord_less_eq_def)
        apply (metis lexord_lexord_less_trans lexord_lexord_less_irreflexive)
      done
    }

    {
      fix zs
      assume "xs \<le> ys" "ys \<le> zs"
      thus "xs \<le> zs"
        apply (simp add: lexord_lexord_less_eq_def)
        apply (metis lexord_lexord_less_trans)
      done
    }
  qed
end

interpretation label_set: presburger_label_set_cache_by_map_set rs_ops rm_ops rs_image
  by (simp add: presburger_label_set_cache_by_map_set_def
                rs_ops_unfold rs_image_impl rsr.StdSet_axioms rmr.StdMap_axioms)

lemmas set_cache_impl = label_set.presburger_label_set_cache_OK

interpretation rs_pres:
  presburger_locale rs_\<alpha> rm_invar rm_empty
    "presburger_label_set_cache_by_map_set.c_\<alpha> rs_ops rm_ops rs_image"
    "presburger_label_set_cache_by_map_set.c_invar rs_ops rm_ops" rs_nfa_ops rs_dfa_construct_reachable_fun
    "rs_nfa_rename_labels_gen False"
using presburger_locale.intro [OF rs_nfa_StdNFA_impl set_cache_impl,
   unfolded rs_nfa_ops_unfold rs_ops_unfold rm_ops_unfold,
   OF rs_dfa_construct_reachable_no_enc_fun_impl
      rs_nfa_rename_labels_gen_impl]
by simp

definition "rs_cache_\<alpha> \<equiv> label_set.c_\<alpha>"
declare label_set.c_\<alpha>.simps [folded rs_cache_\<alpha>_def, code]

definition "rs_DFA_eq_ineq \<equiv> rs_pres.pres_DFA_eq_ineq_impl"
declare rs_pres.pres_DFA_eq_ineq_impl_def[folded rs_DFA_eq_ineq_def, code]

definition "rs_pres_nfa_of_pf \<equiv> rs_pres.nfa_of_pf"
declare rs_pres.nfa_of_pf.simps [folded rs_pres_nfa_of_pf_def rs_cache_\<alpha>_def rs_DFA_eq_ineq_def,
   unfolded rs_pres.pres_DFA_forall_min_impl_def rs_pres.pres_DFA_exists_min_impl_def, code]

definition rs_pres_pf_to_nfa :: "nat \<Rightarrow> pf \<Rightarrow> (bool list) rs_nfa" where
"rs_pres_pf_to_nfa \<equiv> rs_pres.pf_to_nfa"

definition rs_eval_pf where
  "rs_eval_pf pf = rs_nfa_accept (rs_pres_pf_to_nfa 0 pf) []"

definition eval_pf_dfa where
  "eval_pf_dfa pf = dfa_accepts (dfa_of_pf' 0 pf) []"

lemma rs_eval_pf_correct :
  "rs_eval_pf pf = (eval_pf pf [])"
using rs_pres.eval_pf_impl[of pf,symmetric]
by (simp add: rs_eval_pf_def rs_nfa_ops_unfold rs_pres_pf_to_nfa_def)

lemma rs_eval_pf_correct2 :
  "eval_pf_dfa pf = rs_eval_pf pf"
unfolding rs_eval_pf_correct eval_pf_dfa_def
using dfa_of_pf'_correctness [of 0 "[]" pf]
by simp

end