theory VC_To_HC
  imports  Main "../Three_Sat_To_Set_Cover" Graph_Theory.Digraph  Graph_Theory.Arc_Walk
    Graph_Theory.Vertex_Walk
    "Poly_Reductions_Lib.List_Auxiliaries" "VC_To_HC_1" "VC_To_HC_2"
    Definitions_HC
begin

subsection\<open>Main theorem\<close>

lemma vc_impl_hc: "(E,k) \<in> vertex_cover_list \<Longrightarrow> vc_hc (E,k) \<in> hc"
proof -
  assume in_vc: "(E,k)\<in> vertex_cover_list"
  then obtain Cov where "is_vertex_cover_list E Cov" "distinct Cov" "size Cov = k"
    using vertex_cover_list_def
    by (smt case_prodD mem_Collect_eq)
  then show ?thesis
    using vc_impl_hc_context in_vc
    by blast
qed

lemma hc_impl_vc: "vc_hc (E,k) \<in> hc \<Longrightarrow> (E,k) \<in> vertex_cover_list"
proof -
  assume in_hc: "vc_hc (E, k) \<in> hc"
  obtain Cycle where Cycle_def: "is_hc (vc_hc (E, k)) Cycle"
    using hc_def in_hc
    by auto
  obtain Cov where Cov_def: "Cov ={v|v e i j. (Cover j, Edge v e i) \<in> set (vwalk_arcs Cycle)}"
    by simp
  then show ?thesis
    using hc_impl_vc_context in_hc Cycle_def Cov_def
    by fastforce
qed

theorem is_reduction_vc_to_hc:
  "is_reduction vc_hc vertex_cover_list hc"
  unfolding is_reduction_def using vc_impl_hc hc_impl_vc by auto

end


section \<open> Memory Preliminaries \<close>

theory utp_mem_prelim
  imports
    "UTP1-Undef.utp_undef"
    "Continuum.Lightweight_Cardinals"
    "UTP1.utp_full"
begin recall_syntax

purge_notation n_add_op (infixl "\<oplus>" 65)

subsection \<open> State space \<close>

text \<open> As usual, the memory consists of the store and the heap. The store is an abstract
  type, and will usually be another alphabet. \<close>

alphabet 'h mem =
  hp :: "'h"

abbreviation str :: "'s \<Longrightarrow> ('a :: override, 's) mem_ext" where
"str \<equiv> mem.more\<^sub>L"

text \<open> We define an order on memory by lifting of the containment order on finite functions. \<close>

instantiation mem_ext :: (order, type) order
begin
  definition less_eq_mem_ext :: "('a, 'b) mem_scheme \<Rightarrow> ('a, 'b) mem_scheme \<Rightarrow> bool" where
  [upred_defs]: "less_eq_mem_ext x y = (hp\<^sub>v x \<le> hp\<^sub>v y \<and> mem.more x = mem.more y)"

  definition less_mem_ext :: "('a, 'b) mem_scheme \<Rightarrow> ('a, 'b) mem_scheme \<Rightarrow> bool" where
  [upred_defs]: "less_mem_ext x y = (hp\<^sub>v x < hp\<^sub>v y \<and> mem.more x = mem.more y)"

  instance by (intro_classes, (rel_auto)+)
end

text \<open> We set up some useful syntax \<close>

syntax
  "_ucompat" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "##\<^sub>u" 60)

translations
  "f ##\<^sub>u g" == "CONST bop CONST compatible f g"

type_synonym ('h, 's) spred = "('h, 's) mem_ext upred"
type_synonym ('h, 's) sprog = "('h, 's) mem_ext hrel_des"

text \<open> For now we represent addresses and data as naturals. We can therefore inject
  countable data structures into our memory model. \<close>

type_synonym addr = nat
type_synonym data = nat

type_synonym 's mpred = "((addr, data) ffun, 's) spred"
type_synonym 's mprog = "((addr, data) ffun, 's) sprog"
type_synonym ('a, 's) mexpr = "('a, ((addr, data) ffun, 's) mem_ext) pexpr"

subsection \<open> Dereferencing Lens \<close>

text \<open> We first create a bijective lens that extracts a countable type from a natural number. \<close>

definition to_nat_lens :: "'a::{countable,infinite} \<Longrightarrow> nat" ("to-nat\<^sub>L") where
[lens_defs]: "to_nat_lens = \<lparr> lens_get = \<lambda> s. from_nat_bij s, lens_put = \<lambda> s v. to_nat_bij v \<rparr>"

lemma to_nat_lens_bij [simp]: "bij_lens to_nat_lens"
  by (unfold_locales, simp_all add: lens_defs)

text \<open> The dereferencing lens obtains the heap, applies the finite function lens with the given
  address, and finally obtains the typed data. \<close>

definition deref :: "(addr \<Longrightarrow> 's) \<Rightarrow> ('a::{countable,infinite} \<Longrightarrow> ((nat, nat) ffun, 's) mem_ext)" where
[lens_defs]: "deref a = to-nat\<^sub>L ;\<^sub>L ind_lens (\<lambda> i. ffun_lens i ;\<^sub>L hp) &str:a"

syntax \<comment> \<open> Dereferencing Variable Identifier \<close>
  "_spderef"       :: "id \<Rightarrow> svid" ("*_")

translations
  "_spderef a" == "CONST deref a"

lemma src_deref: "vwb_lens a \<Longrightarrow> \<S>\<^bsub>deref a\<^esub> = {s. get\<^bsub>a ;\<^sub>L str\<^esub> s \<in> fdom(get\<^bsub>hp\<^esub> s)}"
  apply (simp add: deref_def source_lens_comp wb_lens.source_UNIV ffun_lens_src)
  apply (auto simp add: lens_defs lens_source_def var.rep_eq)
  apply (metis ffun_upd_ext from_nat_bij_inv mem.surjective mem.update_convs(1))
  done

lemma src_pred_deref [simp]: "vwb_lens a \<Longrightarrow> \<^bold>S(deref a) = (&str:a \<in>\<^sub>u dom\<^sub>u(&hp))"
  by (simp add: src_pred_def src_deref, rel_auto)

end


section \<open>Data: Tuple\<close>

theory Data_Tuple
  imports
    Type_Classes
    Data_Bool
begin

subsection \<open>Datatype definitions\<close>

domain Unit ("\<langle>\<rangle>") = Unit ("\<langle>\<rangle>")

domain ('a, 'b) Tuple2 ("\<langle>_, _\<rangle>") =
  Tuple2 (lazy fst :: "'a") (lazy snd :: "'b") ("\<langle>_, _\<rangle>")

notation Tuple2 ("\<langle>,\<rangle>")

fixrec uncurry :: "('a \<rightarrow> 'b \<rightarrow> 'c) \<rightarrow> \<langle>'a, 'b\<rangle> \<rightarrow> 'c"
  where "uncurry\<cdot>f\<cdot>p = f\<cdot>(fst\<cdot>p)\<cdot>(snd\<cdot>p)"

fixrec curry :: "(\<langle>'a, 'b\<rangle>  \<rightarrow> 'c) \<rightarrow> 'a \<rightarrow> 'b \<rightarrow> 'c"
  where "curry\<cdot>f\<cdot>a\<cdot>b = f\<cdot>\<langle>a, b\<rangle>"

domain ('a, 'b, 'c) Tuple3 ("\<langle>_, _, _\<rangle>") =
  Tuple3 (lazy "'a") (lazy "'b") (lazy "'c") ("\<langle>_, _, _\<rangle>")

notation Tuple3 ("\<langle>,,\<rangle>")

subsection \<open>Type class instances\<close>

instantiation Unit :: Ord_linear
begin

definition
  "eq = (\<Lambda> \<langle>\<rangle> \<langle>\<rangle>. TT)"

definition
  "compare = (\<Lambda> \<langle>\<rangle> \<langle>\<rangle>. EQ)"

instance
  apply standard
        apply (unfold eq_Unit_def compare_Unit_def)
        apply simp
       apply (rename_tac x, case_tac x, simp, simp)
      apply (rename_tac x y, case_tac x, simp, case_tac y, simp, simp)
     apply (rename_tac x y, case_tac x, case_tac y, simp, simp, case_tac y, simp, simp)
    apply (rename_tac x y, case_tac x, simp, case_tac y, simp, simp)
   apply (rename_tac x, case_tac x, simp, simp)
  apply (rename_tac x y z, case_tac x, simp, case_tac y, simp, case_tac z, simp, simp)
  done

end

instantiation Tuple2 :: (Eq, Eq) Eq_strict
begin

definition
  "eq = (\<Lambda> \<langle>x1, y1\<rangle> \<langle>x2, y2\<rangle>. eq\<cdot>x1\<cdot>x2 andalso eq\<cdot>y1\<cdot>y2)"

instance proof
  fix x :: "\<langle>'a, 'b\<rangle>"
  show "eq\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding eq_Tuple2_def by (cases x, simp_all)
  show "eq\<cdot>\<bottom>\<cdot>x = \<bottom>"
    unfolding eq_Tuple2_def by simp
qed

end

lemma eq_Tuple2_simps [simp]:
  "eq\<cdot>\<langle>x1, y1\<rangle>\<cdot>\<langle>x2, y2\<rangle> = (eq\<cdot>x1\<cdot>x2 andalso eq\<cdot>y1\<cdot>y2)"
  unfolding eq_Tuple2_def by simp

instance Tuple2 :: (Eq_sym, Eq_sym) Eq_sym
proof
  fix x y :: "\<langle>'a, 'b\<rangle>"
  show "eq\<cdot>x\<cdot>y = eq\<cdot>y\<cdot>x"
    unfolding eq_Tuple2_def
    by (cases x, simp, (cases y, simp, simp add: eq_sym)+)
qed

instance Tuple2 :: (Eq_equiv, Eq_equiv) Eq_equiv
proof
  fix x y z :: "\<langle>'a, 'b\<rangle>"
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    by (cases x, simp_all)
  { assume "eq\<cdot>x\<cdot>y = TT" and "eq\<cdot>y\<cdot>z = TT" then show "eq\<cdot>x\<cdot>z = TT"
      by (cases x, simp, cases y, simp, cases z, simp, simp,
          fast intro: eq_trans) }
qed

instance Tuple2 :: (Eq_eq, Eq_eq) Eq_eq
proof
  fix x y :: "\<langle>'a, 'b\<rangle>"
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    by (cases x, simp_all)
  { assume "eq\<cdot>x\<cdot>y = TT" then show "x = y"
      by (cases x, simp, cases y, simp, simp, fast) }
qed

instantiation Tuple2 :: (Ord, Ord) Ord_strict
begin

definition
  "compare = (\<Lambda> \<langle>x1, y1\<rangle> \<langle>x2, y2\<rangle>.
    thenOrdering\<cdot>(compare\<cdot>x1\<cdot>x2)\<cdot>(compare\<cdot>y1\<cdot>y2))"

instance
  by standard (simp add: compare_Tuple2_def,
      rename_tac x, case_tac x, simp_all add: compare_Tuple2_def)

end

lemma compare_Tuple2_simps [simp]:
  "compare\<cdot>\<langle>x1, y1\<rangle>\<cdot>\<langle>x2, y2\<rangle> = thenOrdering\<cdot>(compare\<cdot>x1\<cdot>x2)\<cdot>(compare\<cdot>y1\<cdot>y2)"
  unfolding compare_Tuple2_def by simp

instance Tuple2 :: (Ord_linear, Ord_linear) Ord_linear
proof
  fix x y z :: "\<langle>'a, 'b\<rangle>"
  show "eq\<cdot>x\<cdot>y = is_EQ\<cdot>(compare\<cdot>x\<cdot>y)"
    by (cases x, simp, cases y, simp, simp add: eq_conv_compare)
  show "oppOrdering\<cdot>(compare\<cdot>x\<cdot>y) = compare\<cdot>y\<cdot>x"
    by (cases x, simp, cases y, simp, simp add: oppOrdering_thenOrdering)
  { assume "compare\<cdot>x\<cdot>y = EQ" then show "x = y"
      by (cases x, simp, cases y, simp, auto elim: compare_EQ_dest) }
  { assume "compare\<cdot>x\<cdot>y = LT" and "compare\<cdot>y\<cdot>z = LT" then show "compare\<cdot>x\<cdot>z = LT"
      apply (cases x, simp, cases y, simp, cases z, simp, simp)
      apply (elim disjE conjE)
         apply (fast elim!: compare_LT_trans)
        apply (fast dest: compare_EQ_dest)
       apply (fast dest: compare_EQ_dest)
      apply (drule compare_EQ_dest)
      apply (fast elim!: compare_LT_trans)
      done }
  show "compare\<cdot>x\<cdot>x \<sqsubseteq> EQ"
    by (cases x, simp_all)
qed

instantiation Tuple3 :: (Eq, Eq, Eq) Eq_strict
begin

definition
  "eq = (\<Lambda> \<langle>x1, y1, z1\<rangle> \<langle>x2, y2, z2\<rangle>.
    eq\<cdot>x1\<cdot>x2 andalso eq\<cdot>y1\<cdot>y2 andalso eq\<cdot>z1\<cdot>z2)"

instance proof
  fix x :: "\<langle>'a, 'b, 'c\<rangle>"
  show "eq\<cdot>x\<cdot>\<bottom> = \<bottom>"
    unfolding eq_Tuple3_def by (cases x, simp_all)
  show "eq\<cdot>\<bottom>\<cdot>x = \<bottom>"
    unfolding eq_Tuple3_def by simp
qed

end

lemma eq_Tuple3_simps [simp]:
  "eq\<cdot>\<langle>x1, y1, z1\<rangle>\<cdot>\<langle>x2, y2, z2\<rangle> = (eq\<cdot>x1\<cdot>x2 andalso eq\<cdot>y1\<cdot>y2 andalso eq\<cdot>z1\<cdot>z2)"
  unfolding eq_Tuple3_def by simp

instance Tuple3 :: (Eq_sym, Eq_sym, Eq_sym) Eq_sym
proof
  fix x y :: "\<langle>'a, 'b, 'c\<rangle>"
  show "eq\<cdot>x\<cdot>y = eq\<cdot>y\<cdot>x"
    unfolding eq_Tuple3_def
    by (cases x, simp, (cases y, simp, simp add: eq_sym)+)
qed

instance Tuple3 :: (Eq_equiv, Eq_equiv, Eq_equiv) Eq_equiv
proof
  fix x y z :: "\<langle>'a, 'b, 'c\<rangle>"
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    by (cases x, simp_all)
  { assume "eq\<cdot>x\<cdot>y = TT" and "eq\<cdot>y\<cdot>z = TT" then show "eq\<cdot>x\<cdot>z = TT"
      by (cases x, simp, cases y, simp, cases z, simp, simp,
          fast intro: eq_trans) }
qed

instance Tuple3 :: (Eq_eq, Eq_eq, Eq_eq) Eq_eq
proof
  fix x y :: "\<langle>'a, 'b, 'c\<rangle>"
  show "eq\<cdot>x\<cdot>x \<noteq> FF"
    by (cases x, simp_all)
  { assume "eq\<cdot>x\<cdot>y = TT" then show "x = y"
      by (cases x, simp, cases y, simp, simp, fast) }
qed

instantiation Tuple3 :: (Ord, Ord, Ord) Ord_strict
begin

definition
  "compare = (\<Lambda> \<langle>x1, y1, z1\<rangle> \<langle>x2, y2, z2\<rangle>.
    thenOrdering\<cdot>(compare\<cdot>x1\<cdot>x2)\<cdot>(thenOrdering\<cdot>(compare\<cdot>y1\<cdot>y2)\<cdot>(compare\<cdot>z1\<cdot>z2)))"

instance
  by standard (simp add: compare_Tuple3_def,
    rename_tac x, case_tac x, simp_all add: compare_Tuple3_def)

end

lemma compare_Tuple3_simps [simp]:
  "compare\<cdot>\<langle>x1, y1, z1\<rangle>\<cdot>\<langle>x2, y2, z2\<rangle> =
    thenOrdering\<cdot>(compare\<cdot>x1\<cdot>x2)\<cdot>
      (thenOrdering\<cdot>(compare\<cdot>y1\<cdot>y2)\<cdot>(compare\<cdot>z1\<cdot>z2))"
  unfolding compare_Tuple3_def by simp

instance Tuple3 :: (Ord_linear, Ord_linear, Ord_linear) Ord_linear
proof
  fix x y z :: "\<langle>'a, 'b, 'c\<rangle>"
  show "eq\<cdot>x\<cdot>y = is_EQ\<cdot>(compare\<cdot>x\<cdot>y)"
    by (cases x, simp, cases y, simp, simp add: eq_conv_compare)
  show "oppOrdering\<cdot>(compare\<cdot>x\<cdot>y) = compare\<cdot>y\<cdot>x"
    by (cases x, simp, cases y, simp, simp add: oppOrdering_thenOrdering)
  { assume "compare\<cdot>x\<cdot>y = EQ" then show "x = y"
      by (cases x, simp, cases y, simp, auto elim: compare_EQ_dest) }
  { assume "compare\<cdot>x\<cdot>y = LT" and "compare\<cdot>y\<cdot>z = LT" then show "compare\<cdot>x\<cdot>z = LT"
      apply (cases x, simp, cases y, simp, cases z, simp, simp)
      apply (elim disjE conjE)
              apply (fast elim!: compare_LT_trans)
             apply (fast dest: compare_EQ_dest)
            apply (fast dest: compare_EQ_dest)
           apply (fast dest: compare_EQ_dest)
          apply (fast dest: compare_EQ_dest)
         apply (drule compare_EQ_dest)
         apply (fast elim!: compare_LT_trans)
        apply (fast dest: compare_EQ_dest)
       apply (fast dest: compare_EQ_dest)
      apply (fast dest: compare_EQ_dest elim!: compare_LT_trans)
      done }
  show "compare\<cdot>x\<cdot>x \<sqsubseteq> EQ"
    by (cases x, simp_all)
qed

end


theory CR
imports Lambda
begin

inductive par_beta (infixl "\<Rightarrow>\<beta>" 50) where
  pb_var: "Var x \<Rightarrow>\<beta> Var x"
| pb_app: "\<lbrakk> t1 \<Rightarrow>\<beta> t2; s1 \<Rightarrow>\<beta> s2 \<rbrakk> \<Longrightarrow> t1 $ s1 \<Rightarrow>\<beta> t2 $ s2"
| pb_abs: "t \<Rightarrow>\<beta> s \<Longrightarrow> lam[x].t \<Rightarrow>\<beta> lam[x].s"
| pb_beta: "\<lbrakk> x \<sharp> (s1,s2); t1 \<Rightarrow>\<beta> t2; s1 \<Rightarrow>\<beta> s2 \<rbrakk> \<Longrightarrow> (lam [x]. t1) $ s1 \<Rightarrow>\<beta> t2 [x ::= s2]"

equivariance par_beta

nominal_inductive par_beta
by (simp_all add: abs_fresh subst_fresh)

lemma pb_refl: "t \<Rightarrow>\<beta> t"
apply (induction t rule: lambda.induct)
apply (rule, rule, simp, simp, rule, simp)
done

lemma one_to_par: "M \<rightarrow>\<beta> N \<Longrightarrow> M \<Rightarrow>\<beta> N"
apply (induction rule: beta.induct)
  apply (rule, simp, rule pb_refl)
  apply (rule, rule pb_refl, simp)
  apply (rule, simp, rule)
  apply (auto simp add: pb_refl)
done

abbreviation long_beta (infixl "\<longrightarrow>\<beta>" 50) where
  "long_beta == beta\<^sup>*\<^sup>*"

lemma lb_app1: "t1 \<longrightarrow>\<beta> t2 \<Longrightarrow> t1 $ s \<longrightarrow>\<beta> t2 $ s"
apply (induction rule: rtranclp_induct)
apply (simp, rule, simp, rule, simp)
done

lemma lb_app2: "s1 \<longrightarrow>\<beta> s2 \<Longrightarrow> t $ s1 \<longrightarrow>\<beta> t $ s2"
apply (induction rule: rtranclp_induct)
apply (simp, rule, simp, rule, simp)
done

lemma lb_abs: "t \<longrightarrow>\<beta> s \<Longrightarrow> lam[x].t \<longrightarrow>\<beta> lam[x].s"
apply (induction rule: rtranclp_induct)
apply (simp, rule, simp, rule, simp)
done

lemma perm_fresh_lambda:
  fixes M :: lambda and x y :: var
  assumes "y \<sharp> (x,M)"
  shows "x \<sharp> ([(y,x)] \<bullet> M)"
using assms
apply (nominal_induct M rule: lambda.strong_induct)
  apply (metis fresh_bij fresh_prodD(2) swap_simps(1))
  apply (simp add: fresh_prod)
  apply (metis fresh_bij fresh_prodD(2) swap_simps(1))
done

lemma perm_fresh_lambda':
  fixes M :: lambda and x y :: var
  assumes "y \<sharp> (x,M)"
  shows "x \<sharp> ([(x,y)] \<bullet> M)"
using assms
apply (nominal_induct M rule: lambda.strong_induct)
  apply (metis fresh_bij fresh_prodD(2) swap_simps(2))
  apply (simp add: fresh_prod)
  apply (metis fresh_bij fresh_prodD(2) swap_simps(2))
done

lemma lb_subst1: "t \<rightarrow>\<beta> s \<Longrightarrow> t[x ::= p] \<longrightarrow>\<beta> s[x ::= p]"
apply (nominal_induct avoiding: x p rule: beta.strong_induct, simp_all)
  apply (rule lb_app1, simp, rule lb_app2, simp)
  apply (rule lb_abs, simp)
  apply (rule rtranclp_trans, rule, rule, rule, rule subst_gfresh, simp_all)
  apply (subst substitution [symmetric], auto simp add: fresh_atm)
done

lemma lb_subst: "\<lbrakk> t1 \<longrightarrow>\<beta> t2; s1 \<longrightarrow>\<beta> s2 \<rbrakk> \<Longrightarrow> t1[x ::= s1] \<longrightarrow>\<beta> t2[x ::= s2]"
apply (induction rule: rtranclp_induct)
  apply (nominal_induct t1 avoiding: x s1 s2 rule: lambda.strong_induct)
  apply (simp, simp, rule rtranclp_trans, rule lb_app1)
  defer
  apply (rule lb_app2, simp)
  apply (simp, rule lb_abs, simp)
  apply (auto, rule rtranclp_trans, simp)
  apply (simp add: lb_subst1)
done

lemma par_to_longbeta: "M \<Rightarrow>\<beta> N \<Longrightarrow> M \<longrightarrow>\<beta> N"
apply (induction rule: par_beta.induct)
  apply (simp)
  apply (rule rtranclp_trans, rule lb_app1, simp, rule lb_app2, simp)
  apply (rule lb_abs, simp)
  apply (rule rtranclp_trans, rule r_into_rtranclp, rule, simp)
  apply (simp add: lb_subst)
done

nominal_primrec nonabs :: "lambda \<Rightarrow> bool" where
  "nonabs (lam [_]._) = False"
  | "nonabs (Var _) = True"
  | "nonabs (App _ _) = True"
by (finite_guess+, rule+, fresh_guess+)

lemma nonabs_eqvt[eqvt]:
  fixes \<pi> :: "var prm" and M :: lambda
  shows "\<pi> \<bullet> nonabs M = nonabs (\<pi> \<bullet> M)"
by (nominal_induct M rule: lambda.strong_induct, auto)

inductive bstar (infixl "\<longrightarrow>*" 50) where
  bs_var: "Var x \<longrightarrow>* Var x"
| bs_abs: "M \<longrightarrow>* M' \<Longrightarrow> lam [x]. M \<longrightarrow>* lam [x]. M'"
| bs_app: "\<lbrakk> nonabs M1; M1 \<longrightarrow>* M2; N1 \<longrightarrow>* N2 \<rbrakk> \<Longrightarrow> M1 $ N1 \<longrightarrow>* M2 $ N2"
| bs_beta': "\<lbrakk> x \<sharp> (N1,N2); M1 \<longrightarrow>* M2; N1 \<longrightarrow>* N2 \<rbrakk> \<Longrightarrow> (lam [x]. M1) $ N1 \<longrightarrow>* M2 [x ::= N2]"

equivariance bstar

nominal_inductive bstar
by (simp_all add: abs_fresh subst_fresh)

lemma bs_beta:
  assumes "M1 \<longrightarrow>* M2" "N1 \<longrightarrow>* N2"
  shows "(lam [x]. M1) $ N1 \<longrightarrow>* M2 [x ::= N2]"
proof-
  obtain y :: var where y: "y \<sharp> (x,M1,M2,N1,N2)"
    using exists_fresh [of "(x,M1,M2,N1,N2)"]
    using fs_var1 by blast
  have "(lam [x]. M1) $ N1 = (lam [y]. ([(y,x)]\<bullet>M1)) $ N1"
    apply (simp add: lambda.inject alpha, rule disjI2, auto)
    using y apply (meson fresh_atm fresh_prodD(1))
    apply (simp add: perm_swap)
    apply (rule perm_fresh_lambda, simp add: y)
    done
  also have "\<dots> \<longrightarrow>* ([(y,x)]\<bullet>M2)[y ::= N2]"
    by (rule, simp add: y, simp add: assms bstar.eqvt, rule assms)
  also have "\<dots> = M2[x ::= N2]"
    by (auto simp add: subst_rename y)
  finally show "(lam [x]. M1) $ N1 \<longrightarrow>* M2 [x ::= N2]"
    by simp
qed

lemma elim_pb_var: "Var x \<Rightarrow>\<beta> N \<Longrightarrow> N = Var x"
by (cases rule: par_beta.cases, auto)

lemma elim_pb_abs:
  assumes "lam [x]. M \<Rightarrow>\<beta> N'" "x \<sharp> N'"
  obtains N where "M \<Rightarrow>\<beta> N" "N' = lam [x]. N"
using assms
apply (cases rule: par_beta.cases, auto simp add: abs_fresh lambda.inject alpha)
by (metis fresh_bij par_beta.eqvt perm_swap(2) swap_simps(1))

lemma elim_pb_app:
  assumes "M1 $ M2 \<Rightarrow>\<beta> N"
  obtains N1 N2 where "N = N1 $ N2" "M1 \<Rightarrow>\<beta> N1" "M2 \<Rightarrow>\<beta> N2"
     | x P P' L where "M1 = lam[x]. P" "P \<Rightarrow>\<beta> P'" "N = P'[x ::= L]" "M2 \<Rightarrow>\<beta> L" "x \<sharp> (M2,L)"
using assms
apply (cases rule: par_beta.cases, auto simp add: lambda.inject)
done

lemma elim_pb_app_nonabs:
  assumes "M1 $ M2 \<Rightarrow>\<beta> N" "nonabs M1"
  obtains N1 N2 where "N = N1 $ N2" "M1 \<Rightarrow>\<beta> N1" "M2 \<Rightarrow>\<beta> N2"
using assms
apply (cases rule: par_beta.cases, auto simp add: lambda.inject)
done

lemma elim_pb_app_beta:
  assumes "(lam [x]. M1) $ M2 \<Rightarrow>\<beta> N" "x \<sharp> (M2,N)"
  obtains N1 N2 where "N = (lam [x]. N1) $ N2" "M1 \<Rightarrow>\<beta> N1" "M2 \<Rightarrow>\<beta> N2"
  | N1 N2 where "N = N1[x ::= N2]" "M1 \<Rightarrow>\<beta> N1" "M2 \<Rightarrow>\<beta> N2"
using assms
apply (cases rule: par_beta.strong_cases [of _ _ _ x x], auto)
apply (auto simp add: lambda.inject)
apply (erule elim_pb_abs, simp add: fresh_prod, simp)
apply (simp add: abs_fresh)
apply (simp add: abs_fresh abs_fun_eq1)
done

lemma pb_subst: "\<lbrakk> t1 \<Rightarrow>\<beta> s1; t2 \<Rightarrow>\<beta> s2 \<rbrakk> \<Longrightarrow> t1 [x ::= t2] \<Rightarrow>\<beta> s1 [x ::= s2]"
apply (nominal_induct avoiding: x t2 s2 rule: par_beta.strong_induct, auto)
  apply (rule, rule, simp, simp)
  apply (rule, simp)
  apply (simp add: fresh_atm pb_beta subst_gfresh' substitution)
done

lemma par_to_star: "\<lbrakk> t \<longrightarrow>* t1; t \<Rightarrow>\<beta> t2 \<rbrakk> \<Longrightarrow> t2 \<Rightarrow>\<beta> t1"
apply (nominal_induct avoiding: t2 rule: bstar.strong_induct)
  using elim_pb_var apply blast
  apply (erule elim_pb_abs, simp, simp, rule, simp)
  apply (erule elim_pb_app, simp, rule, simp, simp, simp)
  apply (erule elim_pb_app_beta, simp, simp, rule, simp, simp, simp)
  apply (simp, rule pb_subst, simp, simp)
done

lemma bstar_fresh:
  fixes x :: var
  assumes "M \<longrightarrow>* N"
  shows "x \<sharp> M \<Longrightarrow> x \<sharp> N"
using assms apply (nominal_induct rule: bstar.strong_induct, auto)
apply (auto simp add: abs_fresh subst_gfresh)
apply (auto simp add: subst_fresh)
done

lemma elim_bs_abs:
  assumes "lam [x]. t \<longrightarrow>* s"
  obtains t' where "t \<longrightarrow>* t'" "s = lam [x]. t'"
proof-
  have Q: "lam [x]. t \<longrightarrow>* s \<Longrightarrow> \<exists>t'. t \<longrightarrow>* t' \<and> s = lam [x]. t'"
    apply (cases rule: bstar.strong_cases [of _ _ _ x x], auto)
    apply (auto simp add: lambda.inject alpha bstar_fresh abs_fresh)
    done
  show "(\<And>t'. t \<longrightarrow>* t' \<Longrightarrow> s = lam [x].t' \<Longrightarrow> thesis) \<Longrightarrow> thesis"
    using Q [OF assms] by blast
qed

lemma lambda_nonabs_case:
  fixes M :: lambda
  shows "(nonabs M \<Longrightarrow> thesis) \<Longrightarrow> (\<And>x M'. M = lam [x]. M' \<Longrightarrow> thesis) \<Longrightarrow> thesis"
by (nominal_induct M rule: lambda.strong_induct, auto)

lemma star_exist:
  obtains t' where "t \<longrightarrow>* t'"
proof-
  have "\<exists>t'. t \<longrightarrow>* t'"
    apply (nominal_induct t rule: lambda.strong_induct, auto)
    apply (rule, rule)
    defer
    apply (rule, rule, simp)
    proof-
      fix M1 M2 N N'
      assume hyp: "M1 \<longrightarrow>* N" "M2 \<longrightarrow>* N'"
      show "\<exists>t'. M1 $ M2 \<longrightarrow>* t'"
        apply (rule_tac lambda_nonabs_case [of M1])
        apply (rule, rule, simp, rule hyp, rule hyp)
        proof-
          fix x M'
          assume M1: "M1 = lam [x].M'"
          then obtain N1 where N1: "N = lam [x].N1" "M' \<longrightarrow>* N1"
            using elim_bs_abs hyp(1) by blast
          have "M1 $ M2 \<longrightarrow>* N1 [x ::= N']"
            by (simp add: M1, rule bs_beta, simp add: N1, simp add: hyp)
          thus ?thesis by blast
        qed
    qed
  thus "(\<And>t'. t \<longrightarrow>* t' \<Longrightarrow> thesis) \<Longrightarrow> thesis" by blast
qed

lemma par_confluent:
  assumes "t \<Rightarrow>\<beta> t1" "t \<Rightarrow>\<beta> t2"
  obtains s where "t1 \<Rightarrow>\<beta> s" "t2 \<Rightarrow>\<beta> s"
proof-
  obtain t' where t': "t \<longrightarrow>* t'"
    using star_exist by auto
  have "t1 \<Rightarrow>\<beta> t'" "t2 \<Rightarrow>\<beta> t'"
    using par_to_star [OF t'] assms by auto
  thus "(\<And>s. t1 \<Rightarrow>\<beta> s \<Longrightarrow> t2 \<Rightarrow>\<beta> s \<Longrightarrow> thesis) \<Longrightarrow> thesis" by blast
qed

abbreviation long_par_beta (infixl "\<Longrightarrow>\<beta>" 50) where
  "long_par_beta == par_beta\<^sup>*\<^sup>*"

lemma long_pb_iff_long_b: "t \<Longrightarrow>\<beta> s \<longleftrightarrow> t \<longrightarrow>\<beta> s"
apply rule
apply (induct rule: rtranclp_induct)
  apply simp
  apply (rule rtranclp_trans, simp, simp add: par_to_longbeta)
apply (induct rule: rtranclp_induct)
  apply simp
  apply (rule rtranclp_trans, simp, rule r_into_rtranclp, simp add: one_to_par)
done

lemma CR:
  assumes "t \<longrightarrow>\<beta> t1" "t \<longrightarrow>\<beta> t2"
  obtains s where "t1 \<longrightarrow>\<beta> s" "t2 \<longrightarrow>\<beta> s"
proof-
  have CR_one_long: "\<And>t t1 t2. \<lbrakk> t \<Longrightarrow>\<beta> t2; t \<Rightarrow>\<beta> t1 \<rbrakk> \<Longrightarrow> \<exists>s. t1 \<Longrightarrow>\<beta> s \<and> t2 \<Rightarrow>\<beta> s"
    proof-
      fix t t1 t2
      show "\<lbrakk> t \<Longrightarrow>\<beta> t2; t \<Rightarrow>\<beta> t1 \<rbrakk> \<Longrightarrow> \<exists>s. t1 \<Longrightarrow>\<beta> s \<and> t2 \<Rightarrow>\<beta> s"
        proof (induct arbitrary: t1 rule: rtranclp_induct)
          fix t1 show "t \<Rightarrow>\<beta> t1 \<Longrightarrow> \<exists>s. t1 \<Longrightarrow>\<beta> s \<and> t \<Rightarrow>\<beta> s"
            by (rule par_confluent, rule pb_refl, simp, blast)
        next
          fix y z t1
          assume t: "t \<Longrightarrow>\<beta> y" "y \<Rightarrow>\<beta> z" and hyp: "\<And>t1. t \<Rightarrow>\<beta> t1 \<Longrightarrow> \<exists>s. t1 \<Longrightarrow>\<beta> s \<and> y \<Rightarrow>\<beta> s" and t2: "t \<Rightarrow>\<beta> t1"
          obtain s where s: "t1 \<Longrightarrow>\<beta> s" "y \<Rightarrow>\<beta> s" using hyp t t2 by blast
          obtain s' where s': "s \<Rightarrow>\<beta> s'" "z \<Rightarrow>\<beta> s'" using par_confluent [OF t(2) s(2)] by blast
          have "t1 \<Longrightarrow>\<beta> s'" "z \<Rightarrow>\<beta> s'"
            by (rule, rule s, rule s', rule s')
          thus "\<exists>s. t1 \<Longrightarrow>\<beta> s \<and> z \<Rightarrow>\<beta> s"
            by blast
        qed
    qed

  have CR_long_long: "\<lbrakk> t \<Longrightarrow>\<beta> t1; t \<Longrightarrow>\<beta> t2 \<rbrakk> \<Longrightarrow> \<exists>s. t1 \<Longrightarrow>\<beta> s \<and> t2 \<Longrightarrow>\<beta> s"
    apply (induct arbitrary: t2 rule: rtranclp_induct)
      apply (rule, rule, simp, simp)
      using CR_one_long apply (meson rtranclp.rtrancl_into_rtrancl)
    done

  have "t \<Longrightarrow>\<beta> t1" "t \<Longrightarrow>\<beta> t2"
    using assms by (simp add: long_pb_iff_long_b, simp add: long_pb_iff_long_b)
  hence "\<exists>s. t1 \<Longrightarrow>\<beta> s \<and> t2 \<Longrightarrow>\<beta> s"
    by (rule CR_long_long)
  hence "\<exists>s. t1 \<longrightarrow>\<beta> s \<and> t2 \<longrightarrow>\<beta> s"
    by (simp add: long_pb_iff_long_b)
  thus "(\<And>s. t1 \<longrightarrow>\<beta> s \<Longrightarrow> t2 \<longrightarrow>\<beta> s \<Longrightarrow> thesis) \<Longrightarrow> thesis"
    by blast
qed
end