theory FL_Formula
imports
  Nominal_Bounded_Set
  Nominal_Wellfounded
  Residual
  FL_Transition_System
begin

section \<open>Infinitary Formulas With Effects\<close>

subsection \<open>Infinitely branching trees\<close>

text \<open>First, we define a type of trees, with a constructor~@{term tConj} that maps (potentially
infinite) sets of trees into trees. To avoid paradoxes (note that there is no injection from the
powerset of trees into the set of trees), the cardinality of the argument set must be bounded.\<close>

text \<open>The effect consequence operator~\<open>\<langle>f\<rangle>\<close> is always and only used as a prefix to a
predicate or an action formula. So to simplify the representation of formula trees with effects, the
effect operator is merged into the predicate or action it precedes.\<close>

datatype ('idx,'pred,'act,'eff) Tree =
    tConj "('idx,'pred,'act,'eff) Tree set['idx]"  \<comment> \<open>potentially infinite sets of trees\<close>
  | tNot "('idx,'pred,'act,'eff) Tree"
  | tPred 'eff 'pred
  | tAct  'eff 'act "('idx,'pred,'act,'eff) Tree"

text \<open>The (automatically generated) induction principle for trees allows us to prove that the
following relation over trees is well-founded. This will be useful for termination proofs when we
define functions by recursion over trees.\<close>

inductive_set Tree_wf :: "('idx,'pred,'act,'eff) Tree rel" where
  "t \<in> set_bset tset \<Longrightarrow> (t, tConj tset) \<in> Tree_wf"
| "(t, tNot t) \<in> Tree_wf"
| "(t, tAct f \<alpha> t) \<in> Tree_wf"

lemma wf_Tree_wf: "wf Tree_wf"
unfolding wf_def
proof (rule allI, rule impI, rule allI)
  fix P :: "('idx,'pred,'act,'eff) Tree \<Rightarrow> bool" and t
  assume "\<forall>x. (\<forall>y. (y, x) \<in> Tree_wf \<longrightarrow> P y) \<longrightarrow> P x"
  then show "P t"
    proof (induction t)
      case tConj then show ?case
        by (metis Tree.distinct(2) Tree.distinct(5) Tree.inject(1) Tree_wf.cases)
    next
      case tNot then show ?case
        by (metis Tree.distinct(1) Tree.distinct(9) Tree.inject(2) Tree_wf.cases)
    next
      case tPred then show ?case
        by (metis Tree.distinct(11) Tree.distinct(3) Tree.distinct(7) Tree_wf.cases)
    next
      case tAct then show ?case
        by (metis Tree.distinct(10) Tree.distinct(6) Tree.inject(4) Tree_wf.cases)
    qed
qed

text \<open>We define a permutation operation on the type of trees.\<close>

instantiation Tree :: (type, pt, pt, pt) pt
begin

  primrec permute_Tree :: "perm \<Rightarrow> (_,_,_,_) Tree \<Rightarrow> (_,_,_,_) Tree" where
    "p \<bullet> (tConj tset) = tConj (map_bset (permute p) tset)"  \<comment> \<open>neat trick to get around the fact that~@{term tset} is not of permutation type yet\<close>
  | "p \<bullet> (tNot t) = tNot (p \<bullet> t)"
  | "p \<bullet> (tPred f \<phi>) = tPred (p \<bullet> f) (p \<bullet> \<phi>)"
  | "p \<bullet> (tAct f \<alpha> t) = tAct (p \<bullet> f) (p \<bullet> \<alpha>) (p \<bullet> t)"

  instance
  proof
    fix t :: "(_,_,_,_) Tree"
    show "0 \<bullet> t = t"
    proof (induction t)
      case tConj then show ?case
        by (simp, transfer) (auto simp: image_def)
    qed simp_all
  next
    fix p q :: perm and t :: "(_,_,_,_) Tree"
    show "(p + q) \<bullet> t = p \<bullet> q \<bullet> t"
      proof (induction t)
        case tConj then show ?case
          by (simp, transfer) (auto simp: image_def)
      qed simp_all
  qed

end

text \<open>Now that the type of trees---and hence the type of (bounded) sets of trees---is a permutation
type, we can massage the definition of~@{term "p \<bullet> tConj tset"} into its more usual form.\<close>

lemma permute_Tree_tConj [simp]: "p \<bullet> tConj tset = tConj (p \<bullet> tset)"
by (simp add: map_bset_permute)

declare permute_Tree.simps(1) [simp del]

text \<open>The relation~@{const Tree_wf} is equivariant.\<close>

lemma Tree_wf_eqvt_aux:
  assumes "(t1, t2) \<in> Tree_wf" shows "(p \<bullet> t1, p \<bullet> t2) \<in> Tree_wf"
using assms proof (induction rule: Tree_wf.induct)
  fix t :: "('a,'b,'c,'d) Tree" and tset :: "('a,'b,'c,'d) Tree set['a]"
  assume "t \<in> set_bset tset" then show "(p \<bullet> t, p \<bullet> tConj tset) \<in> Tree_wf"
    by (metis Tree_wf.intros(1) mem_permute_iff permute_Tree_tConj set_bset_eqvt)
next
  fix t :: "('a,'b,'c,'d) Tree"
  show "(p \<bullet> t, p \<bullet> tNot t) \<in> Tree_wf"
    by (metis Tree_wf.intros(2) permute_Tree.simps(2))
next
  fix t :: "('a,'b,'c,'d) Tree" and f and  \<alpha>
  show "(p \<bullet> t, p \<bullet> tAct f \<alpha> t) \<in> Tree_wf"
    by (metis Tree_wf.intros(3) permute_Tree.simps(4))
qed

lemma Tree_wf_eqvt [eqvt, simp]: "p \<bullet> Tree_wf = Tree_wf"
proof
  show "p \<bullet> Tree_wf \<subseteq> Tree_wf"
    by (auto simp add: permute_set_def) (rule Tree_wf_eqvt_aux)
next
  show "Tree_wf \<subseteq> p \<bullet> Tree_wf"
    by (auto simp add: permute_set_def) (metis Tree_wf_eqvt_aux permute_minus_cancel(1))
qed

lemma Tree_wf_eqvt': "eqvt Tree_wf"
by (metis Tree_wf_eqvt eqvtI)

text \<open>The definition of~@{const permute} for trees gives rise to the usual notion of support. The
following lemmas, one for each constructor, describe the support of trees.\<close>

lemma supp_tConj [simp]: "supp (tConj tset) = supp tset"
unfolding supp_def by simp

lemma supp_tNot [simp]: "supp (tNot t) = supp t"
unfolding supp_def by simp

lemma supp_tPred [simp]: "supp (tPred f \<phi>) = supp f \<union> supp \<phi>"
unfolding supp_def by (simp add: Collect_imp_eq Collect_neg_eq)

lemma supp_tAct [simp]: "supp (tAct f \<alpha> t) = supp f \<union> supp \<alpha> \<union> supp t"
unfolding supp_def by (auto simp add: Collect_imp_eq Collect_neg_eq)

subsection \<open>Trees modulo \texorpdfstring{$\alpha$}{alpha}-equivalence\<close>

text \<open>We generalize the notion of support, which considers whether a permuted element is
\emph{equal} to itself, to arbitrary endorelations. This is available as @{const supp_rel} in
Nominal Isabelle.\<close>

lemma supp_rel_eqvt [eqvt]:
  "p \<bullet> supp_rel R x = supp_rel (p \<bullet> R) (p \<bullet> x)"
by (simp add: supp_rel_def)

text \<open>Usually, the definition of $\alpha$-equivalence presupposes a notion of free variables.
However, the variables that are ``free'' in an infinitary conjunction are not necessarily those
that are free in one of the conjuncts. For instance, consider a conjunction over \emph{all} names.
Applying any permutation will yield the same conjunction, i.e., this conjunction has \emph{no} free
variables.

To obtain the correct notion of free variables for infinitary conjunctions, we initially defined
$\alpha$-equivalence and free variables via mutual recursion. In particular, we defined the free
variables of a conjunction as term @{term "fv_Tree (tConj tset) = supp_rel alpha_Tree (tConj tset)"}.

We then realized that it is not necessary to define the concept of ``free variables'' at all, but
the definition of $\alpha$-equivalence becomes much simpler (in particular, it is no longer mutually
recursive) if we directly use the support modulo $\alpha$-equivalence.\<close>

text \<open>The following lemmas and constructions are used to prove termination of our definition.\<close>

lemma supp_rel_cong [fundef_cong]:
  "\<lbrakk> x=x'; \<And>a b. R ((a \<rightleftharpoons> b) \<bullet> x') x' \<longleftrightarrow> R' ((a \<rightleftharpoons> b) \<bullet> x') x' \<rbrakk> \<Longrightarrow> supp_rel R x = supp_rel R' x'"
by (simp add: supp_rel_def)

lemma rel_bset_cong [fundef_cong]:
  "\<lbrakk> x=x'; y=y'; \<And>a b. a \<in> set_bset x' \<Longrightarrow> b \<in> set_bset y' \<Longrightarrow> R a b \<longleftrightarrow> R' a b \<rbrakk> \<Longrightarrow> rel_bset R x y \<longleftrightarrow> rel_bset R' x' y'"
by (simp add: rel_bset_def rel_set_def)

lemma alpha_set_cong [fundef_cong]:
  "\<lbrakk> bs=bs'; x=x'; R (p' \<bullet> x') y' \<longleftrightarrow> R' (p' \<bullet> x') y'; f x' = f' x'; f y' = f' y'; p=p'; cs=cs'; y=y' \<rbrakk> \<Longrightarrow>
    alpha_set (bs, x) R f p (cs, y) \<longleftrightarrow> alpha_set (bs', x') R' f' p' (cs', y')"
by (simp add: alpha_set)

quotient_type
  ('idx,'pred,'act,'eff) Tree\<^sub>p = "('idx,'pred::pt,'act::bn,'eff::fs) Tree" / "hull_relp"
  by (fact hull_relp_equivp)

lemma abs_Tree\<^sub>p_eq [simp]: "abs_Tree\<^sub>p (p \<bullet> t) = abs_Tree\<^sub>p t"
by (metis hull_relp.simps Tree\<^sub>p.abs_eq_iff)

lemma permute_rep_abs_Tree\<^sub>p:
  obtains p where "rep_Tree\<^sub>p (abs_Tree\<^sub>p t) = p \<bullet> t"
by (metis Quotient3_Tree\<^sub>p Tree\<^sub>p.abs_eq_iff rep_abs_rsp hull_relp.simps)

lift_definition Tree_wf\<^sub>p :: "('idx,'pred::pt,'act::bn,'eff::fs) Tree\<^sub>p rel" is
  Tree_wf .

lemma Tree_wf\<^sub>pI [simp]:
  assumes "(a, b) \<in> Tree_wf"
  shows "(abs_Tree\<^sub>p (p \<bullet> a), abs_Tree\<^sub>p b) \<in> Tree_wf\<^sub>p"
using assms by (metis (erased, lifting) Tree\<^sub>p.abs_eq_iff Tree_wf\<^sub>p.abs_eq hull_relp.intros map_prod_simp rev_image_eqI)

lemma Tree_wf\<^sub>p_trivialI [simp]:
  assumes "(a, b) \<in> Tree_wf"
  shows "(abs_Tree\<^sub>p a, abs_Tree\<^sub>p b) \<in> Tree_wf\<^sub>p"
using assms by (metis Tree_wf\<^sub>pI permute_zero)

lemma Tree_wf\<^sub>pE:
  assumes "(a\<^sub>p, b\<^sub>p) \<in> Tree_wf\<^sub>p"
  obtains a b where "a\<^sub>p = abs_Tree\<^sub>p a" and "b\<^sub>p = abs_Tree\<^sub>p b" and "(a,b) \<in> Tree_wf"
using assms by (metis (erased, lifting) Pair_inject Tree_wf\<^sub>p.abs_eq prod_fun_imageE) (* DIFF *)

lemma wf_Tree_wf\<^sub>p: "wf Tree_wf\<^sub>p"
apply (rule wf_subset[of "inv_image (hull_rel O Tree_wf) rep_Tree\<^sub>p"])
 apply (metis Tree_wf_eqvt' wf_Tree_wf wf_hull_rel_relcomp wf_inv_image)
apply (auto elim!: Tree_wf\<^sub>pE)
apply (rename_tac t1 t2)
apply (rule_tac t=t1 in permute_rep_abs_Tree\<^sub>p)
apply (rule_tac t=t2 in permute_rep_abs_Tree\<^sub>p)
apply (rename_tac p1 p2)
apply (subgoal_tac "(p2 \<bullet> t1, p2 \<bullet> t2) \<in> Tree_wf")
 apply (subgoal_tac "(p1 \<bullet> t1, p2 \<bullet> t1) \<in> hull_rel")
  apply (metis relcomp.relcompI)
 apply (metis hull_rel.simps permute_minus_cancel(2) permute_plus)
apply (metis Tree_wf_eqvt_aux)
done

fun alpha_Tree_termination :: "('a, 'b, 'c, 'd) Tree \<times> ('a, 'b, 'c, 'd) Tree \<Rightarrow> ('a, 'b::pt, 'c::bn, 'd::fs) Tree\<^sub>p set" where
  "alpha_Tree_termination (t1, t2) = {abs_Tree\<^sub>p t1, abs_Tree\<^sub>p t2}"

text \<open>Here it comes \ldots\<close>

function (sequential)
  alpha_Tree :: "('idx,'pred::pt,'act::bn,'eff::fs) Tree \<Rightarrow> ('idx,'pred,'act,'eff) Tree \<Rightarrow> bool" (infix "=\<^sub>\<alpha>" 50) where
\<comment> \<open>@{const alpha_Tree}\<close>
  alpha_tConj: "tConj tset1 =\<^sub>\<alpha> tConj tset2 \<longleftrightarrow> rel_bset alpha_Tree tset1 tset2"
| alpha_tNot: "tNot t1 =\<^sub>\<alpha> tNot t2 \<longleftrightarrow> t1 =\<^sub>\<alpha> t2"
| alpha_tPred: "tPred f1 \<phi>1 =\<^sub>\<alpha> tPred f2 \<phi>2 \<longleftrightarrow> f1 = f2 \<and> \<phi>1 = \<phi>2"
\<comment> \<open>the action may have binding names\<close>
| alpha_tAct: "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2 \<longleftrightarrow>
    f1 = f2 \<and> (\<exists>p. (bn \<alpha>1, t1) \<approx>set alpha_Tree (supp_rel alpha_Tree) p (bn \<alpha>2, t2) \<and> (bn \<alpha>1, \<alpha>1) \<approx>set ((=)) supp p (bn \<alpha>2, \<alpha>2))"
| alpha_other: "_ =\<^sub>\<alpha> _ \<longleftrightarrow> False"
\<comment> \<open>254 subgoals (!)\<close>
by pat_completeness auto
termination
proof
  let ?R = "inv_image (max_ext Tree_wf\<^sub>p) alpha_Tree_termination"
  show "wf ?R"
    by (metis max_ext_wf wf_Tree_wf\<^sub>p wf_inv_image)
qed (auto simp add: max_ext.simps Tree_wf.simps simp del: permute_Tree_tConj)

text \<open>We provide more descriptive case names for the automatically generated induction principle,
and specialize it to an induction rule for $\alpha$-equivalence.\<close>

lemmas alpha_Tree_induct' = alpha_Tree.induct[case_names alpha_tConj alpha_tNot
  alpha_tPred alpha_tAct "alpha_other(1)" "alpha_other(2)" "alpha_other(3)" "alpha_other(4)"
  "alpha_other(5)" "alpha_other(6)" "alpha_other(7)" "alpha_other(8)" "alpha_other(9)"
  "alpha_other(10)" "alpha_other(11)" "alpha_other(12)" "alpha_other(13)" "alpha_other(14)"
  "alpha_other(15)" "alpha_other(16)" "alpha_other(17)" "alpha_other(18)"]

lemma alpha_Tree_induct[case_names tConj tNot tPred tAct, consumes 1]:
  assumes "t1 =\<^sub>\<alpha> t2"
  and "\<And>tset1 tset2. (\<And>a b. a \<in> set_bset tset1 \<Longrightarrow> b \<in> set_bset tset2 \<Longrightarrow> a =\<^sub>\<alpha> b \<Longrightarrow> P a b) \<Longrightarrow>
            rel_bset (=\<^sub>\<alpha>) tset1 tset2 \<Longrightarrow> P (tConj tset1) (tConj tset2)"
  and "\<And>t1 t2. t1 =\<^sub>\<alpha> t2 \<Longrightarrow> P t1 t2 \<Longrightarrow> P (tNot t1) (tNot t2)"
  and "\<And>f \<phi>. P (tPred f \<phi>) (tPred f \<phi>)"
  and "\<And>f1 \<alpha>1 t1 f2 \<alpha>2 t2. (\<And>p. p \<bullet> t1 =\<^sub>\<alpha> t2 \<Longrightarrow> P (p \<bullet> t1) t2) \<Longrightarrow> f1 = f2 \<Longrightarrow>
            (\<exists>p. (bn \<alpha>1, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) p (bn \<alpha>2, t2) \<and> (bn \<alpha>1, \<alpha>1) \<approx>set (=) supp p (bn \<alpha>2, \<alpha>2)) \<Longrightarrow>
            P (tAct f1 \<alpha>1 t1) (tAct f2 \<alpha>2 t2)"
  shows "P t1 t2"
using assms by (induction t1 t2 rule: alpha_Tree.induct) simp_all

text \<open>$\alpha$-equivalence is equivariant.\<close>

lemma alpha_Tree_eqvt_aux:
  assumes "\<And>a b. (a \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t \<longleftrightarrow> p \<bullet> (a \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> p \<bullet> t"
  shows "p \<bullet> supp_rel (=\<^sub>\<alpha>) t = supp_rel (=\<^sub>\<alpha>) (p \<bullet> t)"
proof -
  {
    fix a
    let ?B = "{b. \<not> ((a \<rightleftharpoons> b) \<bullet> t) =\<^sub>\<alpha> t}"
    let ?pB = "{b. \<not> ((p \<bullet> a \<rightleftharpoons> b) \<bullet> p \<bullet> t) =\<^sub>\<alpha> (p \<bullet> t)}"
    {
      assume "finite ?B"
      moreover have "inj_on (unpermute p) ?pB"
        by (simp add: inj_on_def unpermute_def)
      moreover have "unpermute p ` ?pB \<subseteq> ?B"
        using assms by auto (metis (erased, lifting) eqvt_bound permute_eqvt swap_eqvt)
      ultimately have "finite ?pB"
        by (metis inj_on_finite)
    }
    moreover
    {
      assume "finite ?pB"
      moreover have "inj_on (permute p) ?B"
        by (simp add: inj_on_def)
      moreover have "permute p ` ?B \<subseteq> ?pB"
        using assms by auto (metis (erased, lifting) permute_eqvt swap_eqvt)
      ultimately have "finite ?B"
        by (metis inj_on_finite)
    }
    ultimately have "infinite ?B \<longleftrightarrow> infinite ?pB"
      by auto
  }
  then show ?thesis
    by (auto simp add: supp_rel_def permute_set_def) (metis eqvt_bound)
qed

lemma alpha_Tree_eqvt': "t1 =\<^sub>\<alpha> t2 \<longleftrightarrow> p \<bullet> t1 =\<^sub>\<alpha> p \<bullet> t2"
proof (induction t1 t2 rule: alpha_Tree_induct')
  case (alpha_tConj tset1 tset2) show ?case
  proof
    assume *: "tConj tset1 =\<^sub>\<alpha> tConj tset2"
    {
      fix x
      assume "x \<in> set_bset (p \<bullet> tset1)"
      then obtain x' where 1: "x' \<in> set_bset tset1" and 2: "x = p \<bullet> x'"
        by (metis imageE permute_bset.rep_eq permute_set_eq_image)
      from 1 obtain y' where 3: "y' \<in> set_bset tset2" and 4: "x' =\<^sub>\<alpha> y'"
        using "*" by (metis (mono_tags, lifting) FL_Formula.alpha_tConj rel_bset.rep_eq rel_set_def)
      from 3 have "p \<bullet> y' \<in> set_bset (p \<bullet> tset2)"
        by (metis mem_permute_iff set_bset_eqvt)
      moreover from 1 and 2 and 3 and 4 have "x =\<^sub>\<alpha> p \<bullet> y'"
        using alpha_tConj.IH by blast
      ultimately have "\<exists>y\<in>set_bset (p \<bullet> tset2). x =\<^sub>\<alpha> y" ..
    }
    moreover
    {
      fix y
      assume "y \<in> set_bset (p \<bullet> tset2)"
      then obtain y' where 1: "y' \<in> set_bset tset2" and 2: "p \<bullet> y' = y"
        by (metis imageE permute_bset.rep_eq permute_set_eq_image)
      from 1 obtain x' where 3: "x' \<in> set_bset tset1" and 4: "x' =\<^sub>\<alpha> y'"
        using "*" by (metis (mono_tags, lifting) FL_Formula.alpha_tConj rel_bset.rep_eq rel_set_def)
      from 3 have "p \<bullet> x' \<in> set_bset (p \<bullet> tset1)"
        by (metis mem_permute_iff set_bset_eqvt)
      moreover from 1 and 2 and 3 and 4 have "p \<bullet> x' =\<^sub>\<alpha> y"
        using alpha_tConj.IH by blast
      ultimately have "\<exists>x\<in>set_bset (p \<bullet> tset1). x =\<^sub>\<alpha> y" ..
    }
    ultimately show "p \<bullet> tConj tset1 =\<^sub>\<alpha> p \<bullet> tConj tset2"
      by (simp add: rel_bset_def rel_set_def)
  next
    assume *: "p \<bullet> tConj tset1 =\<^sub>\<alpha> p \<bullet> tConj tset2"
    {
      fix x
      assume 1: "x \<in> set_bset tset1"
      then have "p \<bullet> x \<in> set_bset (p \<bullet> tset1)"
        by (metis mem_permute_iff set_bset_eqvt)
      then obtain y' where 2: "y' \<in> set_bset (p \<bullet> tset2)" and 3: "p \<bullet> x =\<^sub>\<alpha> y'"
        using "*" by (metis FL_Formula.alpha_tConj permute_Tree_tConj rel_bset.rep_eq rel_set_def)
      from 2 obtain y where 4: "y \<in> set_bset tset2" and 5: "y' = p \<bullet> y"
        by (metis imageE permute_bset.rep_eq permute_set_eq_image)
      from 1 and 3 and 4 and 5 have "x =\<^sub>\<alpha> y"
        using alpha_tConj.IH by blast
      with 4 have "\<exists>y\<in>set_bset tset2. x =\<^sub>\<alpha> y" ..
    }
    moreover
    {
      fix y
      assume 1: "y \<in> set_bset tset2"
      then have "p \<bullet> y \<in> set_bset (p \<bullet> tset2)"
        by (metis mem_permute_iff set_bset_eqvt)
      then obtain x' where 2: "x' \<in> set_bset (p \<bullet> tset1)" and 3: "x' =\<^sub>\<alpha> p \<bullet> y"
        using "*" by (metis FL_Formula.alpha_tConj permute_Tree_tConj rel_bset.rep_eq rel_set_def)
      from 2 obtain x where 4: "x \<in> set_bset tset1" and 5: "p \<bullet> x = x'"
        by (metis imageE permute_bset.rep_eq permute_set_eq_image)
      from 1 and 3 and 4 and 5 have "x =\<^sub>\<alpha> y"
        using alpha_tConj.IH by blast
      with 4 have "\<exists>x\<in>set_bset tset1. x =\<^sub>\<alpha> y" ..
    }
    ultimately show "tConj tset1 =\<^sub>\<alpha> tConj tset2"
      by (simp add: rel_bset_def rel_set_def)
  qed
next
  case (alpha_tAct f1 \<alpha>1 t1 f2 \<alpha>2 t2)
  from alpha_tAct.IH(2) have t1: "p \<bullet> supp_rel (=\<^sub>\<alpha>) t1 = supp_rel (=\<^sub>\<alpha>) (p \<bullet> t1)"
    by (rule alpha_Tree_eqvt_aux)
  from alpha_tAct.IH(3) have t2: "p \<bullet> supp_rel (=\<^sub>\<alpha>) t2 = supp_rel (=\<^sub>\<alpha>) (p \<bullet> t2)"
    by (rule alpha_Tree_eqvt_aux)
  show ?case
  proof
    assume "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2"
    then obtain q where 0: "f1 = f2" and 1: "(bn \<alpha>1, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) q (bn \<alpha>2, t2)" and 2: "(bn \<alpha>1, \<alpha>1) \<approx>set (=) supp q (bn \<alpha>2, \<alpha>2)"
      by auto
    from 1 and t1 and t2 have "supp_rel (=\<^sub>\<alpha>) (p \<bullet> t1) - bn (p \<bullet> \<alpha>1) = supp_rel (=\<^sub>\<alpha>) (p \<bullet> t2) - bn (p \<bullet> \<alpha>2)"
      by (metis Diff_eqvt alpha_set bn_eqvt)
    moreover from 1 and t1 have "(supp_rel (=\<^sub>\<alpha>) (p \<bullet> t1) - bn (p \<bullet> \<alpha>1)) \<sharp>* (p + q - p)"
      by (metis Diff_eqvt alpha_set bn_eqvt fresh_star_permute_iff permute_perm_def)
    moreover from 1 and alpha_tAct.IH(1) have "p \<bullet> q \<bullet> t1 =\<^sub>\<alpha> p \<bullet> t2"
      by (simp add: alpha_set)
    moreover from 2 have "p \<bullet> q \<bullet> -p \<bullet> bn (p \<bullet> \<alpha>1) = bn (p \<bullet> \<alpha>2)"
      by (simp add: alpha_set bn_eqvt)
    ultimately have "(bn (p \<bullet> \<alpha>1), p \<bullet> t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) (p + q - p) (bn (p \<bullet> \<alpha>2), p \<bullet> t2)"
      by (simp add: alpha_set)
    moreover from 2 have "(bn (p \<bullet> \<alpha>1), p \<bullet> \<alpha>1) \<approx>set (=) supp (p + q - p) (bn (p \<bullet> \<alpha>2), p \<bullet> \<alpha>2)"
      by (simp add: alpha_set) (metis (mono_tags, lifting) Diff_eqvt bn_eqvt fresh_star_permute_iff permute_minus_cancel(2) permute_perm_def supp_eqvt)
    ultimately show "p \<bullet> tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> p \<bullet> tAct f2 \<alpha>2 t2" using 0
      by auto
  next
    assume "p \<bullet> tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> p \<bullet> tAct f2 \<alpha>2 t2"
    then obtain q where 0: "f1 = f2" and 1: "(bn (p \<bullet> \<alpha>1), p \<bullet> t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) q (bn (p \<bullet> \<alpha>2), p \<bullet> t2)" and 2: "(bn (p \<bullet> \<alpha>1), p \<bullet> \<alpha>1) \<approx>set (=) supp q (bn (p \<bullet> \<alpha>2), p \<bullet> \<alpha>2)"
      by auto
    {
      from 1 and t1 and t2 have "supp_rel (=\<^sub>\<alpha>) t1 - bn \<alpha>1 = supp_rel (=\<^sub>\<alpha>) t2 - bn \<alpha>2"
        by (metis (no_types, lifting) Diff_eqvt alpha_set bn_eqvt permute_eq_iff)
      moreover with 1 and t2 have "(supp_rel (=\<^sub>\<alpha>) t1 - bn \<alpha>1) \<sharp>* (- p + q + p)"
        by (auto simp add: fresh_star_def fresh_perm alphas) (metis (no_types, lifting) DiffI bn_eqvt mem_permute_iff permute_minus_cancel(2))
      moreover from 1 have "- p \<bullet> q \<bullet> p \<bullet> t1 =\<^sub>\<alpha> t2"
        using alpha_tAct.IH(1) by (simp add: alpha_set) (metis (no_types, lifting) permute_eqvt permute_minus_cancel(2))
      moreover from 1 have "- p \<bullet> q \<bullet> p \<bullet> bn \<alpha>1 = bn \<alpha>2"
        by (metis alpha_set bn_eqvt permute_minus_cancel(2))
      ultimately have "(bn \<alpha>1, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) (-p + q + p) (bn \<alpha>2, t2)"
        by (simp add: alpha_set)
    }
    moreover
    {
      from 2 have "supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2"
        by (metis (no_types, lifting) Diff_eqvt alpha_set bn_eqvt permute_eq_iff supp_eqvt)
      moreover with 2 have "(supp \<alpha>1 - bn \<alpha>1) \<sharp>* (-p + q + p)"
        by (auto simp add: fresh_star_def fresh_perm alphas) (metis (no_types, lifting) DiffI bn_eqvt mem_permute_iff permute_minus_cancel(1) supp_eqvt)
      moreover from 2 have "-p \<bullet> q \<bullet> p \<bullet> \<alpha>1 = \<alpha>2"
        by (simp add: alpha_set)
      moreover have "-p \<bullet> q \<bullet> p \<bullet> bn \<alpha>1 = bn \<alpha>2"
        by (simp add: bn_eqvt calculation(3))
      ultimately have "(bn \<alpha>1, \<alpha>1) \<approx>set (=) supp (-p + q + p) (bn \<alpha>2, \<alpha>2)"
        by (simp add: alpha_set)
    }
    ultimately show "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2" using 0
      by auto
  qed
qed simp_all

lemma alpha_Tree_eqvt [eqvt]: "t1 =\<^sub>\<alpha> t2 \<Longrightarrow> p \<bullet> t1 =\<^sub>\<alpha> p \<bullet> t2"
by (metis alpha_Tree_eqvt')

text \<open>@{const alpha_Tree} is an equivalence relation.\<close>

lemma alpha_Tree_reflp: "reflp alpha_Tree"
proof (rule reflpI)
  fix t :: "('a,'b,'c,'d) Tree"
  show "t =\<^sub>\<alpha> t"
  proof (induction t)
    case tConj then show ?case by (metis alpha_tConj rel_bset.rep_eq rel_setI)
  next
    case tNot then show ?case by (metis alpha_tNot)
  next
    case tPred show ?case by (metis alpha_tPred)
  next
    case tAct then show ?case by (metis (mono_tags) alpha_tAct alpha_refl(1))
  qed
qed

lemma alpha_Tree_symp: "symp alpha_Tree"
proof (rule sympI)
  fix x y :: "('a,'b,'c,'d) Tree"
  assume "x =\<^sub>\<alpha> y" then show "y =\<^sub>\<alpha> x"
  proof (induction x y rule: alpha_Tree_induct)
    case tConj then show ?case
      by (simp add: rel_bset_def rel_set_def) metis
  next
    case (tAct f1 \<alpha>1 t1 f2 \<alpha>2 t2)
    then obtain p where "f1=f2 \<and> (bn \<alpha>1, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) p (bn \<alpha>2, t2) \<and> (bn \<alpha>1, \<alpha>1) \<approx>set (=) supp p (bn \<alpha>2, \<alpha>2)"
      by auto
    then have "f1=f2 \<and> (bn \<alpha>2, t2) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) (-p) (bn \<alpha>1, t1) \<and> (bn \<alpha>2, \<alpha>2) \<approx>set (=) supp (-p) (bn \<alpha>1, \<alpha>1)"
      using tAct.IH by (metis (mono_tags, lifting) alpha_Tree_eqvt alpha_sym(1) permute_minus_cancel(2))
    then show ?case
      by auto
  qed simp_all
qed

lemma alpha_Tree_transp: "transp alpha_Tree"
proof (rule transpI)
  fix x y z:: "('a,'b,'c,'d) Tree"
  assume "x =\<^sub>\<alpha> y" and "y =\<^sub>\<alpha> z"
  then show "x =\<^sub>\<alpha> z"
  proof (induction x y arbitrary: z rule: alpha_Tree_induct)
    case (tConj tset_x tset_y) show ?case
      proof (cases z)
        fix tset_z
        assume z: "z = tConj tset_z"
        have "rel_bset (=\<^sub>\<alpha>) tset_x tset_z"
          unfolding rel_bset.rep_eq rel_set_def Ball_def Bex_def
          proof
            show "\<forall>x'. x' \<in> set_bset tset_x \<longrightarrow> (\<exists>z'. z' \<in> set_bset tset_z \<and> x' =\<^sub>\<alpha> z')"
            proof (rule allI, rule impI)
              fix x' assume 1: "x' \<in> set_bset tset_x"
              then obtain y' where 2: "y' \<in> set_bset tset_y" and 3: "x' =\<^sub>\<alpha> y'"
                by (metis rel_bset.rep_eq rel_set_def tConj.hyps)
              from 2 obtain z' where 4: "z' \<in> set_bset tset_z" and 5: "y' =\<^sub>\<alpha> z'"
                by (metis alpha_tConj rel_bset.rep_eq rel_set_def tConj.prems z)
              from 1 2 3 5 have "x' =\<^sub>\<alpha> z'"
                by (rule tConj.IH)
              with 4 show "\<exists>z'. z' \<in> set_bset tset_z \<and> x' =\<^sub>\<alpha> z'"
                by auto
            qed
          next
            show "\<forall>z'. z' \<in> set_bset tset_z \<longrightarrow> (\<exists>x'. x' \<in> set_bset tset_x \<and> x' =\<^sub>\<alpha> z')"
            proof (rule allI, rule impI)
              fix z' assume 1: "z' \<in> set_bset tset_z"
              then obtain y' where 2: "y' \<in> set_bset tset_y" and 3: "y' =\<^sub>\<alpha> z'"
                by (metis alpha_tConj rel_bset.rep_eq rel_set_def tConj.prems z)
              from 2 obtain x' where 4: "x' \<in> set_bset tset_x" and 5: "x' =\<^sub>\<alpha> y'"
                by (metis rel_bset.rep_eq rel_set_def tConj.hyps)
              from 4 2 5 3 have "x' =\<^sub>\<alpha> z'"
                by (rule tConj.IH)
              with 4 show "\<exists>x'. x' \<in> set_bset tset_x \<and> x' =\<^sub>\<alpha> z'"
                by auto
            qed
          qed
        with z show "tConj tset_x =\<^sub>\<alpha> z"
          by simp
      qed (insert tConj.prems, auto)
  next
    case tNot then show ?case
      by (cases z) simp_all
  next
    case tPred then show ?case
      by simp
  next
    case (tAct f1 \<alpha>1 t1 f2 \<alpha>2 t2) show ?case
    proof (cases z)
      fix f \<alpha> t
      assume z: "z = tAct f \<alpha> t"
      obtain p where 1: "f1=f2 \<and> (bn \<alpha>1, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) p (bn \<alpha>2, t2) \<and> (bn \<alpha>1, \<alpha>1) \<approx>set (=) supp p (bn \<alpha>2, \<alpha>2)"
        using tAct.hyps by auto
      obtain q where 2: "f2=f \<and> (bn \<alpha>2, t2) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) q (bn \<alpha>, t) \<and> (bn \<alpha>2, \<alpha>2) \<approx>set (=) supp q (bn \<alpha>, \<alpha>)"
        using tAct.prems z by auto
      have "f1=f \<and> (bn \<alpha>1, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) (q + p) (bn \<alpha>, t)"
        proof -
          have "supp_rel (=\<^sub>\<alpha>) t1 - bn \<alpha>1 = supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>"
            using 1 and 2 by (metis alpha_set)
          moreover have "(supp_rel (=\<^sub>\<alpha>) t1 - bn \<alpha>1) \<sharp>* (q + p)"
            using 1 and 2 by (metis alpha_set fresh_star_plus)
          moreover have "(q + p) \<bullet> t1 =\<^sub>\<alpha> t"
            using 1 and 2 and tAct.IH by (metis (no_types, lifting) alpha_Tree_eqvt alpha_set permute_minus_cancel(1) permute_plus)
          moreover have "(q + p) \<bullet> bn \<alpha>1 = bn \<alpha>"
            using 1 and 2 by (metis alpha_set permute_plus)
          moreover have "f1=f"
            using 1 and 2 by simp
          ultimately show ?thesis
            by (metis alpha_set)
        qed
      moreover have "(bn \<alpha>1, \<alpha>1) \<approx>set (=) supp (q + p) (bn \<alpha>, \<alpha>)"
        using 1 and 2 by (metis (mono_tags) alpha_trans(1) permute_plus)
      ultimately show "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> z"
        using z by auto
    qed (insert tAct.prems, auto)
  qed
qed

lemma alpha_Tree_equivp: "equivp alpha_Tree"
by (auto intro: equivpI alpha_Tree_reflp alpha_Tree_symp alpha_Tree_transp)

text \<open>$\alpha$-equivalent trees have the same support modulo $\alpha$-equivalence.\<close>

lemma alpha_Tree_supp_rel:
  assumes "t1 =\<^sub>\<alpha> t2"
  shows "supp_rel (=\<^sub>\<alpha>) t1 = supp_rel (=\<^sub>\<alpha>) t2"
using assms proof (induction rule: alpha_Tree_induct)
  case (tConj tset1 tset2)
  have sym: "\<And>x y. rel_bset (=\<^sub>\<alpha>) x y \<longleftrightarrow> rel_bset (=\<^sub>\<alpha>) y x"
    by (meson alpha_Tree_symp bset.rel_symp sympE)
  {
    fix a b
    from tConj.hyps have *: "rel_bset (=\<^sub>\<alpha>) ((a \<rightleftharpoons> b) \<bullet> tset1) ((a \<rightleftharpoons> b) \<bullet> tset2)"
      by (metis alpha_tConj alpha_Tree_eqvt permute_Tree_tConj)
    have "rel_bset (=\<^sub>\<alpha>) ((a \<rightleftharpoons> b) \<bullet> tset1) tset1 \<longleftrightarrow> rel_bset (=\<^sub>\<alpha>) ((a \<rightleftharpoons> b) \<bullet> tset2) tset2"
      by (rule iffI) (metis "*" alpha_Tree_transp bset.rel_transp sym tConj.hyps transpE)+
  }
  then show ?case
    by (simp add: supp_rel_def)
next
  case tNot then show ?case
    by (simp add: supp_rel_def)
next
  case (tAct f1 \<alpha>1 t1 f2 \<alpha>2 t2)
  {
    fix a b
    have "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2"
      using tAct.hyps by simp
    then have "(a \<rightleftharpoons> b) \<bullet> tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f1 \<alpha>1 t1 \<longleftrightarrow> (a \<rightleftharpoons> b) \<bullet> tAct f2 \<alpha>2 t2 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2"
      by (metis (no_types, lifting) alpha_Tree_eqvt alpha_Tree_symp alpha_Tree_transp sympE transpE)
  }
  then show ?case
    by (simp add: supp_rel_def)
qed simp_all

text \<open>@{const tAct} preserves $\alpha$-equivalence.\<close>

lemma alpha_Tree_tAct:
  assumes "t1 =\<^sub>\<alpha> t2"
  shows "tAct f \<alpha> t1 =\<^sub>\<alpha> tAct f \<alpha> t2"
proof -
  have "(bn \<alpha>, t1) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) 0 (bn \<alpha>, t2)"
    using assms by (simp add: alpha_Tree_supp_rel alpha_set fresh_star_zero)
  moreover have "(bn \<alpha>, \<alpha>) \<approx>set (=) supp 0 (bn \<alpha>, \<alpha>)"
    by (metis (full_types) alpha_refl(1))
  ultimately show ?thesis
    by auto
qed

text \<open>The following lemmas describe the support modulo $\alpha$-equivalence.\<close>

lemma supp_rel_tNot [simp]: "supp_rel (=\<^sub>\<alpha>) (tNot t) = supp_rel (=\<^sub>\<alpha>) t"
unfolding supp_rel_def by simp

lemma supp_rel_tPred [simp]: "supp_rel (=\<^sub>\<alpha>) (tPred f \<phi>) = supp f \<union> supp \<phi>"
unfolding supp_rel_def supp_def by (simp add: Collect_imp_eq Collect_neg_eq)

text \<open>The support modulo $\alpha$-equivalence of~@{term "tAct \<alpha> t"} is not easily described:
when~@{term t} has infinite support (modulo $\alpha$-equivalence), the support (modulo
$\alpha$-equivalence) of~@{term "tAct \<alpha> t"} may still contain names in~@{term "bn \<alpha>"}. This
incongruity is avoided when~@{term t} has finite support modulo $\alpha$-equivalence.\<close>

lemma infinite_mono: "infinite S \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> x \<in> T) \<Longrightarrow> infinite T"
by (metis infinite_super subsetI)

lemma supp_rel_tAct [simp]:
  assumes "finite (supp_rel (=\<^sub>\<alpha>) t)"
  shows "supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t) = supp f \<union> (supp \<alpha> \<union> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>)"
proof
  show "supp f \<union> (supp \<alpha> \<union> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>) \<subseteq> supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t)"
  proof
    fix x
    assume "x \<in> supp f \<union> (supp \<alpha> \<union> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>)"
    moreover
    {
      assume x1: "x \<in> supp f"
      from x1 have "infinite {b. (x \<rightleftharpoons> b) \<bullet> f \<noteq> f}"
        unfolding supp_def ..
      then have "infinite ({b. (x \<rightleftharpoons> b) \<bullet> f \<noteq> f} - supp f)"
        by (simp add: finite_supp)
      moreover
      {
        fix b
        assume "b \<in> {b. (x \<rightleftharpoons> b) \<bullet> f \<noteq> f} - supp f"
        then have b1: "(x \<rightleftharpoons> b) \<bullet> f \<noteq> f" and b2: "b \<notin> supp f"
          by simp+
        then have "sort_of x = sort_of b"
          using swap_different_sorts by fastforce
        then have "(x \<rightleftharpoons> b) \<bullet> supp f \<noteq> supp f"
          using b2 x1 using swap_set_in by blast
        then have "b \<in> {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
          by auto
      }
      ultimately have "infinite {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
        by (rule infinite_mono)
      then have "x \<in> supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t)"
        unfolding supp_rel_def ..
    }
    moreover
    {
      assume x1: "x \<in> supp \<alpha>" and x2: "x \<notin> bn \<alpha>"
      from x1 have "infinite {b. (x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha>}"
        unfolding supp_def ..
      then have "infinite ({b. (x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha>} - supp \<alpha>)"
        by (simp add: finite_supp)
      moreover
      {
        fix b
        assume "b \<in> {b. (x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha>} - supp \<alpha>"
        then have b1: "(x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha>" and b2: "b \<notin> supp \<alpha> - bn \<alpha>"
          by simp+
        from b1 have "sort_of x = sort_of b"
          using swap_different_sorts by fastforce
        then have "(x \<rightleftharpoons> b) \<bullet> (supp \<alpha> - bn \<alpha>) \<noteq> supp \<alpha> - bn \<alpha>"
          using b2 x1 x2 by (simp add: swap_set_in)
        then have "b \<in> {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
          by (auto simp add: alpha_set Diff_eqvt bn_eqvt)
      }
      ultimately have "infinite {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
        by (rule infinite_mono)
      then have "x \<in> supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t)"
        unfolding supp_rel_def ..
    }
    moreover
    {
      assume x1: "x \<in> supp_rel (=\<^sub>\<alpha>) t" and x2: "x \<notin> bn \<alpha>"
      from x1 have "infinite {b. \<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t}"
        unfolding supp_rel_def ..
      then have "infinite ({b. \<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t} - supp_rel (=\<^sub>\<alpha>) t)"
        using assms by simp
      moreover
      {
        fix b
        assume "b \<in> {b. \<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t} - supp_rel (=\<^sub>\<alpha>) t"
        then have b1: "\<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t" and b2: "b \<notin> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>"
          by simp+
        from b1 have "(x \<rightleftharpoons> b) \<bullet> t \<noteq> t"
          by (metis alpha_Tree_reflp reflpE)
        then have "sort_of x = sort_of b"
          using swap_different_sorts by fastforce
        then have "(x \<rightleftharpoons> b) \<bullet> (supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>) \<noteq> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>"
          using b2 x1 x2 by (simp add: swap_set_in)
        then have "supp_rel (=\<^sub>\<alpha>) ((x \<rightleftharpoons> b) \<bullet> t) - bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>) \<noteq> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>"
          by (simp add: Diff_eqvt bn_eqvt)
        then have "b \<in> {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
          by (simp add: alpha_set)
      }
      ultimately have "infinite {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
        by (rule infinite_mono)
      then have "x \<in> supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t)"
        unfolding supp_rel_def ..
    }
    ultimately show "x \<in> supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t)"
      by auto
  qed
next
  show "supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t) \<subseteq> supp f \<union> (supp \<alpha> \<union> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>)"
  proof
    fix x
    assume "x \<in> supp_rel (=\<^sub>\<alpha>) (tAct f \<alpha> t)"
    then have *: "infinite {b. \<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t}"
      unfolding supp_rel_def ..
    moreover
    {
      fix b
      assume "\<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t"
      then have "(x \<rightleftharpoons> b) \<bullet> f \<noteq> f \<or> (x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha> \<or> \<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t"
        using alpha_Tree_tAct by force
    }
    ultimately have "infinite {b. (x \<rightleftharpoons> b) \<bullet> f \<noteq> f \<or> (x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha> \<or> \<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t}"
      using infinite_mono mem_Collect_eq by force
    then have "infinite {b. (x \<rightleftharpoons> b) \<bullet> f \<noteq> f} \<or> infinite {b. (x \<rightleftharpoons> b) \<bullet> \<alpha> \<noteq> \<alpha>} \<or> infinite {b. \<not> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t}"
      by (metis (mono_tags) finite_Collect_disjI)
    then have "x \<in> supp f \<union> supp \<alpha> \<union> supp_rel (=\<^sub>\<alpha>) t"
      by (simp add: supp_def supp_rel_def)
    moreover
    {
      assume **: "x \<in> bn \<alpha> \<and> x \<notin> supp f"
      from "*" obtain b where b0: "\<not> (x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t" and b1: "b \<notin> supp f" and b2: "b \<notin> supp \<alpha>" and b3: "b \<notin> supp_rel (=\<^sub>\<alpha>) t"
        using assms by (metis (no_types, lifting) UnCI finite_UnI finite_supp infinite_mono mem_Collect_eq)
      let ?p = "(x \<rightleftharpoons> b)"
      have "supp_rel (=\<^sub>\<alpha>) ((x \<rightleftharpoons> b) \<bullet> t) - bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>) = supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>"
        using "**" and b3 by (metis (no_types, lifting) Diff_eqvt Diff_iff alpha_Tree_eqvt' alpha_Tree_eqvt_aux bn_eqvt swap_set_not_in)
      moreover then have "(supp_rel (=\<^sub>\<alpha>) ((x \<rightleftharpoons> b) \<bullet> t) - bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>)) \<sharp>* ?p"
        using "**" and b3 by (metis Diff_iff fresh_perm fresh_star_def swap_atom_simps(3))
      moreover have "?p \<bullet> (x \<rightleftharpoons> b) \<bullet> t =\<^sub>\<alpha> t"
        using alpha_Tree_reflp reflpE by force
      moreover have "?p \<bullet> bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>) = bn \<alpha>"
        by (simp add: bn_eqvt)
      moreover have "supp ((x \<rightleftharpoons> b) \<bullet> \<alpha>) - bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>) = supp \<alpha> - bn \<alpha>"
        using "**" and b2 by (metis (mono_tags, hide_lams) Diff_eqvt Diff_iff bn_eqvt supp_eqvt swap_set_not_in)
      moreover then have "(supp ((x \<rightleftharpoons> b) \<bullet> \<alpha>) - bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>)) \<sharp>* ?p"
        using "**" and b2 by (simp add: fresh_star_def fresh_def supp_perm) (metis Diff_iff swap_atom_simps(3))
      moreover have "?p \<bullet> (x \<rightleftharpoons> b) \<bullet> \<alpha> = \<alpha>"
        by simp
      ultimately have "\<exists>p. (bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>), (x \<rightleftharpoons> b) \<bullet> t) \<approx>set (=\<^sub>\<alpha>) supp_rel (=\<^sub>\<alpha>) p (bn \<alpha>, t) \<and>
                           (bn ((x \<rightleftharpoons> b) \<bullet> \<alpha>), (x \<rightleftharpoons> b) \<bullet> \<alpha>) \<approx>set (=) supp p (bn \<alpha>, \<alpha>)"
         by (auto simp add: alpha_set.simps)
        moreover have "(x \<rightleftharpoons> b) \<bullet> f = f" using "**" and b1
           by (simp add: fresh_def swap_fresh_fresh)
      ultimately have "(x \<rightleftharpoons> b) \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha> t"
        by simp
      with b0 have "False" ..
    }
    ultimately show "x \<in> supp f \<union> (supp \<alpha> \<union> supp_rel (=\<^sub>\<alpha>) t - bn \<alpha>)"
      by blast
  qed
qed

text \<open>We define the type of (infinitely branching) trees quotiented by $\alpha$-equivalence.\<close>

(* FIXME: No map function defined. No relator found. *)
quotient_type
  ('idx,'pred,'act,'eff) Tree\<^sub>\<alpha> = "('idx,'pred::pt,'act::bn,'eff::fs) Tree" / "alpha_Tree"
  by (fact alpha_Tree_equivp)

lemma Tree\<^sub>\<alpha>_abs_rep [simp]: "abs_Tree\<^sub>\<alpha> (rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha>) = t\<^sub>\<alpha>"
by (metis Quotient_Tree\<^sub>\<alpha> Quotient_abs_rep)

lemma Tree\<^sub>\<alpha>_rep_abs [simp]: "rep_Tree\<^sub>\<alpha> (abs_Tree\<^sub>\<alpha> t) =\<^sub>\<alpha> t"
by (metis Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep)

text \<open>The permutation operation is lifted from trees.\<close>

instantiation Tree\<^sub>\<alpha> :: (type, pt, bn, fs) pt
begin

  lift_definition permute_Tree\<^sub>\<alpha> :: "perm \<Rightarrow> ('a,'b,'c,'d) Tree\<^sub>\<alpha> \<Rightarrow> ('a,'b,'c,'d) Tree\<^sub>\<alpha>"
    is permute
  by (fact alpha_Tree_eqvt)

  instance
  proof
    fix t\<^sub>\<alpha> :: "(_,_,_,_) Tree\<^sub>\<alpha>"
    show "0 \<bullet> t\<^sub>\<alpha> = t\<^sub>\<alpha>"
      by transfer (metis alpha_Tree_equivp equivp_reflp permute_zero)
  next
    fix p q :: perm and t\<^sub>\<alpha> :: "(_,_,_,_) Tree\<^sub>\<alpha>"
    show "(p + q) \<bullet> t\<^sub>\<alpha> = p \<bullet> q \<bullet> t\<^sub>\<alpha>"
      by transfer (metis alpha_Tree_equivp equivp_reflp permute_plus)
  qed

end

text \<open>The abstraction function from trees to trees modulo $\alpha$-equivalence is equivariant. The
representation function is equivariant modulo $\alpha$-equivalence.\<close>

lemmas permute_Tree\<^sub>\<alpha>.abs_eq [eqvt, simp]

lemma alpha_Tree_permute_rep_commute [simp]: "p \<bullet> rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha> =\<^sub>\<alpha> rep_Tree\<^sub>\<alpha> (p \<bullet> t\<^sub>\<alpha>)"
by (metis Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep permute_Tree\<^sub>\<alpha>.abs_eq)

subsection \<open>Constructors for trees modulo \texorpdfstring{$\alpha$}{alpha}-equivalence\<close>

text \<open>The constructors are lifted from trees.\<close>

lift_definition Conj\<^sub>\<alpha> :: "('idx,'pred,'act,'eff) Tree\<^sub>\<alpha> set['idx] \<Rightarrow> ('idx,'pred::pt,'act::bn,'eff::fs) Tree\<^sub>\<alpha>" is
  tConj
by simp

lemma map_bset_abs_rep_Tree\<^sub>\<alpha>: "map_bset abs_Tree\<^sub>\<alpha> (map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>) = tset\<^sub>\<alpha>"
by (metis (full_types) Quotient_Tree\<^sub>\<alpha> Quotient_abs_rep bset_lifting.bset_quot_map)

lift_definition Not\<^sub>\<alpha> :: "('idx,'pred,'act,'eff) Tree\<^sub>\<alpha> \<Rightarrow> ('idx,'pred::pt,'act::bn,'eff::fs) Tree\<^sub>\<alpha>" is
  tNot
by simp

lift_definition Pred\<^sub>\<alpha> :: "'eff \<Rightarrow> 'pred \<Rightarrow> ('idx,'pred::pt,'act::bn,'eff::fs) Tree\<^sub>\<alpha>" is
  tPred
.

lift_definition Act\<^sub>\<alpha> :: "'eff \<Rightarrow> 'act \<Rightarrow> ('idx,'pred,'act,'eff) Tree\<^sub>\<alpha> \<Rightarrow> ('idx,'pred::pt,'act::bn,'eff::fs) Tree\<^sub>\<alpha>" is
  tAct
by (fact alpha_Tree_tAct)

text \<open>The lifted constructors are equivariant.\<close>

lemma Conj\<^sub>\<alpha>_eqvt [eqvt, simp]: "p \<bullet> Conj\<^sub>\<alpha> tset\<^sub>\<alpha> = Conj\<^sub>\<alpha> (p \<bullet> tset\<^sub>\<alpha>)"
proof -
  {
    fix x
    assume "x \<in> set_bset (p \<bullet> map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>)"
    then obtain y where "y \<in> set_bset (map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>)" and "x = p \<bullet> y"
      by (metis imageE permute_bset.rep_eq permute_set_eq_image)
    then obtain t\<^sub>\<alpha> where 1: "t\<^sub>\<alpha> \<in> set_bset tset\<^sub>\<alpha>" and 2: "x = p \<bullet> rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha>"
      by (metis imageE map_bset.rep_eq)
    let ?x' = "rep_Tree\<^sub>\<alpha> (p \<bullet> t\<^sub>\<alpha>)"
    from 1 have "p \<bullet> t\<^sub>\<alpha> \<in> set_bset (p \<bullet> tset\<^sub>\<alpha>)"
      by (metis mem_permute_iff permute_bset.rep_eq)
    then have "?x' \<in> set_bset (map_bset rep_Tree\<^sub>\<alpha> (p \<bullet> tset\<^sub>\<alpha>))"
      by (simp add: bset.set_map)
    moreover from 2 have "x =\<^sub>\<alpha> ?x'"
      by (metis alpha_Tree_permute_rep_commute)
    ultimately have "\<exists>x'\<in>set_bset (map_bset rep_Tree\<^sub>\<alpha> (p \<bullet> tset\<^sub>\<alpha>)). x =\<^sub>\<alpha> x'"
      ..
  }
  moreover
  {
    fix y
    assume "y \<in> set_bset (map_bset rep_Tree\<^sub>\<alpha> (p \<bullet> tset\<^sub>\<alpha>))"
    then obtain x where "x \<in> set_bset (p \<bullet> tset\<^sub>\<alpha>)" and "rep_Tree\<^sub>\<alpha> x = y"
      by (metis imageE map_bset.rep_eq)
    then obtain t\<^sub>\<alpha> where 1: "t\<^sub>\<alpha> \<in> set_bset tset\<^sub>\<alpha>" and 2: "rep_Tree\<^sub>\<alpha> (p \<bullet> t\<^sub>\<alpha>) = y"
      by (metis imageE permute_bset.rep_eq permute_set_eq_image)
    let ?y' = "p \<bullet> rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha>"
    from 1 have "rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha> \<in> set_bset (map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>)"
      by (simp add: bset.set_map)
    then have "?y' \<in> set_bset (p \<bullet> map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>)"
      by (metis mem_permute_iff permute_bset.rep_eq)
    moreover from 2 have "?y' =\<^sub>\<alpha> y"
      by (metis alpha_Tree_permute_rep_commute)
    ultimately have "\<exists>y'\<in>set_bset (p \<bullet> map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>). y' =\<^sub>\<alpha> y"
      ..
  }
  ultimately show ?thesis
    by (simp add: Conj\<^sub>\<alpha>_def' map_bset_eqvt rel_bset_def rel_set_def Tree\<^sub>\<alpha>.abs_eq_iff)
qed

lemma Not\<^sub>\<alpha>_eqvt [eqvt, simp]: "p \<bullet> Not\<^sub>\<alpha> t\<^sub>\<alpha> = Not\<^sub>\<alpha> (p \<bullet> t\<^sub>\<alpha>)"
by (induct t\<^sub>\<alpha>) (simp add: Not\<^sub>\<alpha>.abs_eq)

lemma Pred\<^sub>\<alpha>_eqvt [eqvt, simp]: "p \<bullet> Pred\<^sub>\<alpha> f \<phi> = Pred\<^sub>\<alpha> (p \<bullet> f) (p \<bullet> \<phi>)"
by (simp add: Pred\<^sub>\<alpha>.abs_eq)

lemma Act\<^sub>\<alpha>_eqvt [eqvt, simp]: "p \<bullet> Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha> = Act\<^sub>\<alpha> (p \<bullet> f) (p \<bullet> \<alpha>) (p \<bullet> t\<^sub>\<alpha>)"
by (induct t\<^sub>\<alpha>) (simp add: Act\<^sub>\<alpha>.abs_eq)

text \<open>The lifted constructors are injective (except for~@{const Act\<^sub>\<alpha>}).\<close>

lemma Conj\<^sub>\<alpha>_eq_iff [simp]: "Conj\<^sub>\<alpha> tset1\<^sub>\<alpha> = Conj\<^sub>\<alpha> tset2\<^sub>\<alpha> \<longleftrightarrow> tset1\<^sub>\<alpha> = tset2\<^sub>\<alpha>"
proof
  assume "Conj\<^sub>\<alpha> tset1\<^sub>\<alpha> = Conj\<^sub>\<alpha> tset2\<^sub>\<alpha>"
  then have "tConj (map_bset rep_Tree\<^sub>\<alpha> tset1\<^sub>\<alpha>) =\<^sub>\<alpha> tConj (map_bset rep_Tree\<^sub>\<alpha> tset2\<^sub>\<alpha>)"
    by (metis Conj\<^sub>\<alpha>_def' Tree\<^sub>\<alpha>.abs_eq_iff)
  then have "rel_bset (=\<^sub>\<alpha>) (map_bset rep_Tree\<^sub>\<alpha> tset1\<^sub>\<alpha>) (map_bset rep_Tree\<^sub>\<alpha> tset2\<^sub>\<alpha>)"
    by (auto elim: alpha_Tree.cases)
  then show "tset1\<^sub>\<alpha> = tset2\<^sub>\<alpha>"
    using Quotient_Tree\<^sub>\<alpha> Quotient_rel_abs2 bset_lifting.bset_quot_map map_bset_abs_rep_Tree\<^sub>\<alpha> by fastforce
qed (fact arg_cong)

lemma Not\<^sub>\<alpha>_eq_iff [simp]: "Not\<^sub>\<alpha> t1\<^sub>\<alpha> = Not\<^sub>\<alpha> t2\<^sub>\<alpha> \<longleftrightarrow> t1\<^sub>\<alpha> = t2\<^sub>\<alpha>"
proof
  assume "Not\<^sub>\<alpha> t1\<^sub>\<alpha> = Not\<^sub>\<alpha> t2\<^sub>\<alpha>"
  then have "tNot (rep_Tree\<^sub>\<alpha> t1\<^sub>\<alpha>) =\<^sub>\<alpha> tNot (rep_Tree\<^sub>\<alpha> t2\<^sub>\<alpha>)"
    by (metis Not\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep)
  then have "rep_Tree\<^sub>\<alpha> t1\<^sub>\<alpha> =\<^sub>\<alpha> rep_Tree\<^sub>\<alpha> t2\<^sub>\<alpha>"
    using alpha_Tree.cases by auto
  then show "t1\<^sub>\<alpha> = t2\<^sub>\<alpha>"
    by (metis Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep)
next
  assume "t1\<^sub>\<alpha> = t2\<^sub>\<alpha>" then show "Not\<^sub>\<alpha> t1\<^sub>\<alpha> = Not\<^sub>\<alpha> t2\<^sub>\<alpha>"
    by simp
qed

lemma Pred\<^sub>\<alpha>_eq_iff [simp]: "Pred\<^sub>\<alpha> f1 \<phi>1 = Pred\<^sub>\<alpha> f2 \<phi>2 \<longleftrightarrow> f1 = f2 \<and> \<phi>1 = \<phi>2"
proof
  assume "Pred\<^sub>\<alpha> f1 \<phi>1 = Pred\<^sub>\<alpha> f2 \<phi>2"
  then have "(tPred f1 \<phi>1 :: ('e, 'b, 'f, 'd) Tree) =\<^sub>\<alpha> tPred f2 \<phi>2"  \<comment> \<open>note the unrelated type\<close> (* WHY? *)
    by (metis Pred\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>.abs_eq_iff)
  then show "f1 = f2 \<and> \<phi>1 = \<phi>2"
    using alpha_Tree.cases by auto
next
  assume "f1 = f2 \<and> \<phi>1 = \<phi>2" then show "Pred\<^sub>\<alpha> f1 \<phi>1 = Pred\<^sub>\<alpha> f2 \<phi>2"
    by simp
qed

lemma Act\<^sub>\<alpha>_eq_iff: "Act\<^sub>\<alpha> f1 \<alpha>1 t1 = Act\<^sub>\<alpha> f2 \<alpha>2 t2 \<longleftrightarrow> tAct f1 \<alpha>1 (rep_Tree\<^sub>\<alpha> t1) =\<^sub>\<alpha> tAct f2 \<alpha>2 (rep_Tree\<^sub>\<alpha> t2)"
by (metis Act\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep)

text \<open>The lifted constructors are free (except for~@{const Act\<^sub>\<alpha>}).\<close>

lemma Tree\<^sub>\<alpha>_free [simp]:
  shows "Conj\<^sub>\<alpha> tset\<^sub>\<alpha> \<noteq> Not\<^sub>\<alpha> t\<^sub>\<alpha>"
  and "Conj\<^sub>\<alpha> tset\<^sub>\<alpha> \<noteq> Pred\<^sub>\<alpha> f \<phi>"
  and "Conj\<^sub>\<alpha> tset\<^sub>\<alpha> \<noteq> Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha>"
  and "Not\<^sub>\<alpha> t\<^sub>\<alpha> \<noteq> Pred\<^sub>\<alpha> f \<phi>"
  and "Not\<^sub>\<alpha> t1\<^sub>\<alpha> \<noteq> Act\<^sub>\<alpha> f \<alpha> t2\<^sub>\<alpha>"
  and "Pred\<^sub>\<alpha> f1 \<phi> \<noteq> Act\<^sub>\<alpha> f2 \<alpha> t\<^sub>\<alpha>"
by (simp add: Conj\<^sub>\<alpha>_def' Not\<^sub>\<alpha>_def Pred\<^sub>\<alpha>_def Act\<^sub>\<alpha>_def Tree\<^sub>\<alpha>.abs_eq_iff)+

text \<open>The following lemmas describe the support of constructed trees modulo $\alpha$-equivalence.\<close>

lemma supp_alpha_supp_rel: "supp t\<^sub>\<alpha> = supp_rel (=\<^sub>\<alpha>) (rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha>)"
unfolding supp_def supp_rel_def by (metis (mono_tags, lifting) Collect_cong Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep alpha_Tree_permute_rep_commute)

lemma supp_Conj\<^sub>\<alpha> [simp]: "supp (Conj\<^sub>\<alpha> tset\<^sub>\<alpha>) = supp tset\<^sub>\<alpha>"
unfolding supp_def by simp

lemma supp_Not\<^sub>\<alpha> [simp]: "supp (Not\<^sub>\<alpha> t\<^sub>\<alpha>) = supp t\<^sub>\<alpha>"
unfolding supp_def by simp

lemma supp_Pred\<^sub>\<alpha> [simp]: "supp (Pred\<^sub>\<alpha> f \<phi>) = supp f \<union> supp \<phi>"
unfolding supp_def by (simp add: Collect_imp_eq Collect_neg_eq)

lemma supp_Act\<^sub>\<alpha> [simp]:
  assumes "finite (supp t\<^sub>\<alpha>)"
  shows "supp (Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha>) = supp f \<union> (supp \<alpha> \<union> supp t\<^sub>\<alpha> - bn \<alpha>)"
using assms by (metis Act\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>_abs_rep Tree\<^sub>\<alpha>_rep_abs alpha_Tree_supp_rel supp_alpha_supp_rel supp_rel_tAct) (* Patience *)

subsection \<open>Induction over trees modulo \texorpdfstring{$\alpha$}{alpha}-equivalence\<close>

lemma Tree\<^sub>\<alpha>_induct [case_names Conj\<^sub>\<alpha> Not\<^sub>\<alpha> Pred\<^sub>\<alpha> Act\<^sub>\<alpha> Env\<^sub>\<alpha>, induct type: Tree\<^sub>\<alpha>]:
  fixes t\<^sub>\<alpha>
  assumes "\<And>tset\<^sub>\<alpha>. (\<And>x. x \<in> set_bset tset\<^sub>\<alpha> \<Longrightarrow> P x) \<Longrightarrow> P (Conj\<^sub>\<alpha> tset\<^sub>\<alpha>)"
    and "\<And>t\<^sub>\<alpha>. P t\<^sub>\<alpha> \<Longrightarrow> P (Not\<^sub>\<alpha> t\<^sub>\<alpha>)"
    and "\<And>f pred. P (Pred\<^sub>\<alpha> f pred)"
    and "\<And>f act t\<^sub>\<alpha>. P t\<^sub>\<alpha> \<Longrightarrow> P (Act\<^sub>\<alpha> f act t\<^sub>\<alpha>)"
  shows "P t\<^sub>\<alpha>"
proof (rule Tree\<^sub>\<alpha>.abs_induct)
  fix t show "P (abs_Tree\<^sub>\<alpha> t)"
    proof (induction t)
      case (tConj tset)
        let ?tset\<^sub>\<alpha> = "map_bset abs_Tree\<^sub>\<alpha> tset"
        have "abs_Tree\<^sub>\<alpha> (tConj tset) = Conj\<^sub>\<alpha> ?tset\<^sub>\<alpha>"
          by (simp add: Conj\<^sub>\<alpha>.abs_eq)
        then show ?case
          using assms(1) tConj.IH by (metis imageE map_bset.rep_eq)
    next
      case tNot then show ?case
        using assms(2) by (metis Not\<^sub>\<alpha>.abs_eq)
    next
      case tPred show ?case
        using assms(3) by (metis Pred\<^sub>\<alpha>.abs_eq)
    next
      case tAct then show ?case
        using assms(4) by (metis Act\<^sub>\<alpha>.abs_eq)
    qed
qed

text \<open>There is no (obvious) strong induction principle for trees modulo $\alpha$-equivalence: since
their support may be infinite, we may not be able to rename bound variables without also renaming
free variables.\<close>

subsection \<open>Hereditarily finitely supported trees\<close>

text \<open>We cannot obtain the type of infinitary formulas simply as the sub-type of all trees (modulo
$\alpha$-equivalence) that are finitely supported: since an infinite set of trees may be finitely
supported even though its members are not (and thus, would not be formulas), the sub-type of
\emph{all} finitely supported trees does not validate the induction principle that we desire for
formulas.

Instead, we define \emph{hereditarily} finitely supported trees. We require that environments and
state predicates are finitely supported.\<close>

inductive hereditarily_fs :: "('idx,'pred::fs,'act::bn,'eff::fs) Tree\<^sub>\<alpha> \<Rightarrow> bool" where
  Conj\<^sub>\<alpha>: "finite (supp tset\<^sub>\<alpha>) \<Longrightarrow> (\<And>t\<^sub>\<alpha>. t\<^sub>\<alpha> \<in> set_bset tset\<^sub>\<alpha> \<Longrightarrow> hereditarily_fs t\<^sub>\<alpha>) \<Longrightarrow> hereditarily_fs (Conj\<^sub>\<alpha> tset\<^sub>\<alpha>)"
| Not\<^sub>\<alpha>: "hereditarily_fs t\<^sub>\<alpha> \<Longrightarrow> hereditarily_fs (Not\<^sub>\<alpha> t\<^sub>\<alpha>)"
| Pred\<^sub>\<alpha>: "hereditarily_fs (Pred\<^sub>\<alpha> f \<phi>)"
| Act\<^sub>\<alpha>: "hereditarily_fs t\<^sub>\<alpha> \<Longrightarrow> hereditarily_fs (Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha>)"

text \<open>@{const hereditarily_fs} is equivariant.\<close>

lemma hereditarily_fs_eqvt [eqvt]:
  assumes "hereditarily_fs t\<^sub>\<alpha>"
  shows "hereditarily_fs (p \<bullet> t\<^sub>\<alpha>)"
using assms proof (induction rule: hereditarily_fs.induct)
  case Conj\<^sub>\<alpha> then show ?case
    by (metis (erased, hide_lams) Conj\<^sub>\<alpha>_eqvt hereditarily_fs.Conj\<^sub>\<alpha> mem_permute_iff permute_finite permute_minus_cancel(1) set_bset_eqvt supp_eqvt)
next
  case Not\<^sub>\<alpha> then show ?case
    by (metis Not\<^sub>\<alpha>_eqvt hereditarily_fs.Not\<^sub>\<alpha>)
next
  case Pred\<^sub>\<alpha> then show ?case
    by (metis Pred\<^sub>\<alpha>_eqvt hereditarily_fs.Pred\<^sub>\<alpha>)
next
  case Act\<^sub>\<alpha> then show ?case
    by (metis Act\<^sub>\<alpha>_eqvt hereditarily_fs.Act\<^sub>\<alpha>)
qed

text \<open>@{const hereditarily_fs} is preserved under $\alpha$-renaming.\<close>

lemma hereditarily_fs_alpha_renaming:
  assumes "Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha> = Act\<^sub>\<alpha> f' \<alpha>' t\<^sub>\<alpha>'"
  shows "hereditarily_fs t\<^sub>\<alpha> \<longleftrightarrow> hereditarily_fs t\<^sub>\<alpha>'"
proof
  assume "hereditarily_fs t\<^sub>\<alpha>"
  then show "hereditarily_fs t\<^sub>\<alpha>'"
    using assms by (auto simp add: Act\<^sub>\<alpha>_def Tree\<^sub>\<alpha>.abs_eq_iff alphas) (metis Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep hereditarily_fs_eqvt permute_Tree\<^sub>\<alpha>.abs_eq)
next
  assume "hereditarily_fs t\<^sub>\<alpha>'"
  then show "hereditarily_fs t\<^sub>\<alpha>"
    using assms by (auto simp add: Act\<^sub>\<alpha>_def Tree\<^sub>\<alpha>.abs_eq_iff alphas) (metis Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep hereditarily_fs_eqvt permute_Tree\<^sub>\<alpha>.abs_eq permute_minus_cancel(2))
qed

text \<open>Hereditarily finitely supported trees have finite support.\<close>

lemma hereditarily_fs_implies_finite_supp:
  assumes "hereditarily_fs t\<^sub>\<alpha>"
  shows "finite (supp t\<^sub>\<alpha>)"
using assms by (induction rule: hereditarily_fs.induct)  (simp_all add: finite_supp)

subsection \<open>Infinitary formulas\<close>

text \<open>Now, infinitary formulas are simply the sub-type of hereditarily finitely supported trees.\<close>

typedef ('idx,'pred::fs,'act::bn,'eff::fs) formula = "{t\<^sub>\<alpha>::('idx,'pred,'act,'eff) Tree\<^sub>\<alpha>. hereditarily_fs t\<^sub>\<alpha>}"
by (metis hereditarily_fs.Pred\<^sub>\<alpha> mem_Collect_eq)

text \<open>We set up Isabelle's lifting infrastructure so that we can lift definitions from the type of
trees modulo $\alpha$-equivalence to the sub-type of formulas.\<close>

(* FIXME: No relator found. *)
setup_lifting type_definition_formula

lemma Abs_formula_inverse [simp]:
  assumes "hereditarily_fs t\<^sub>\<alpha>"
  shows "Rep_formula (Abs_formula t\<^sub>\<alpha>) = t\<^sub>\<alpha>"
using assms by (metis Abs_formula_inverse mem_Collect_eq)

lemma Rep_formula' [simp]: "hereditarily_fs (Rep_formula x)"
by (metis Rep_formula mem_Collect_eq)

text \<open>Now we lift the permutation operation.\<close>

instantiation formula :: (type, fs, bn, fs) pt
begin

  lift_definition permute_formula :: "perm \<Rightarrow> ('a,'b,'c,'d) formula \<Rightarrow> ('a,'b,'c,'d) formula"
    is permute
  by (fact hereditarily_fs_eqvt)

  instance
  by standard (transfer, simp)+

end

text \<open>The abstraction and representation functions for formulas are equivariant, and they preserve
support.\<close>

lemma Abs_formula_eqvt [simp]:
  assumes "hereditarily_fs t\<^sub>\<alpha>"
  shows "p \<bullet> Abs_formula t\<^sub>\<alpha> = Abs_formula (p \<bullet> t\<^sub>\<alpha>)"
by (metis assms eq_onp_same_args permute_formula.abs_eq)

lemma supp_Abs_formula [simp]:
  assumes "hereditarily_fs t\<^sub>\<alpha>"
  shows "supp (Abs_formula t\<^sub>\<alpha>) = supp t\<^sub>\<alpha>"
proof -
  {
    fix p :: perm
    have "p \<bullet> Abs_formula t\<^sub>\<alpha> = Abs_formula (p \<bullet> t\<^sub>\<alpha>)"
      using assms by (metis Abs_formula_eqvt)
    moreover have "hereditarily_fs (p \<bullet> t\<^sub>\<alpha>)"
      using assms by (metis hereditarily_fs_eqvt)
    ultimately have "p \<bullet> Abs_formula t\<^sub>\<alpha> = Abs_formula t\<^sub>\<alpha> \<longleftrightarrow> p \<bullet> t\<^sub>\<alpha> = t\<^sub>\<alpha>"
      using assms by (metis Abs_formula_inverse)
  }
  then show ?thesis unfolding supp_def by simp
qed

lemmas Rep_formula_eqvt [eqvt, simp] = permute_formula.rep_eq[symmetric]

lemma supp_Rep_formula [simp]: "supp (Rep_formula x) = supp x"
by (metis Rep_formula' Rep_formula_inverse supp_Abs_formula)

lemma supp_map_bset_Rep_formula [simp]: "supp (map_bset Rep_formula xset) = supp xset"
proof
  have "eqvt (map_bset Rep_formula)"
    unfolding eqvt_def by (simp add: ext)
  then show "supp (map_bset Rep_formula xset) \<subseteq> supp xset"
    by (fact supp_fun_app_eqvt)
next
  {
    fix a :: atom
    have "inj (map_bset Rep_formula)"
      by (metis bset.inj_map Rep_formula_inject injI)
    then have "\<And>x y. x \<noteq> y \<Longrightarrow> map_bset Rep_formula x \<noteq> map_bset Rep_formula y"
      by (metis inj_eq)
    then have "{b. (a \<rightleftharpoons> b) \<bullet> xset \<noteq> xset} \<subseteq> {b. (a \<rightleftharpoons> b) \<bullet> map_bset Rep_formula xset \<noteq> map_bset Rep_formula xset}" (is "?S \<subseteq> ?T")
      by auto
    then have "infinite ?S \<Longrightarrow> infinite ?T"
      by (metis infinite_super)
  }
  then show "supp xset \<subseteq> supp (map_bset Rep_formula xset)"
    unfolding supp_def by auto
qed

text \<open>Formulas are in fact finitely supported.\<close>

instance formula :: (type, fs, bn, fs) fs
by standard (metis Rep_formula' hereditarily_fs_implies_finite_supp supp_Rep_formula)

subsection \<open>Constructors for infinitary formulas\<close>

text \<open>We lift the constructors for trees (modulo $\alpha$-equivalence) to infinitary formulas.
Since~@{const Conj\<^sub>\<alpha>} does not necessarily yield a (hereditarily) finitely supported tree when
applied to a (potentially infinite) set of (hereditarily) finitely supported trees, we cannot use
Isabelle's {\bf lift\_definition} to define~@{term Conj}. Instead, theorems about terms of the
form~@{term "Conj xset"} will usually carry an assumption that~@{term xset} is finitely supported.\<close>

definition Conj :: "('idx,'pred,'act,'eff) formula set['idx] \<Rightarrow> ('idx,'pred::fs,'act::bn,'eff::fs) formula" where
  "Conj xset = Abs_formula (Conj\<^sub>\<alpha> (map_bset Rep_formula xset))"

lemma finite_supp_implies_hereditarily_fs_Conj\<^sub>\<alpha> [simp]:
  assumes "finite (supp xset)"
  shows "hereditarily_fs (Conj\<^sub>\<alpha> (map_bset Rep_formula xset))"
proof (rule hereditarily_fs.Conj\<^sub>\<alpha>)
  show "finite (supp (map_bset Rep_formula xset))"
    using assms by (metis supp_map_bset_Rep_formula)
next
  fix t\<^sub>\<alpha> assume "t\<^sub>\<alpha> \<in> set_bset (map_bset Rep_formula xset)"
  then show "hereditarily_fs t\<^sub>\<alpha>"
    by (auto simp add: bset.set_map)
qed

lemma Conj_rep_eq:
  assumes "finite (supp xset)"
  shows "Rep_formula (Conj xset) = Conj\<^sub>\<alpha> (map_bset Rep_formula xset)"
using assms unfolding Conj_def by simp

lift_definition Not :: "('idx,'pred,'act,'eff) formula \<Rightarrow> ('idx,'pred::fs,'act::bn,'eff::fs) formula" is
  Not\<^sub>\<alpha>
by (fact hereditarily_fs.Not\<^sub>\<alpha>)

lift_definition Pred :: "'eff \<Rightarrow> 'pred \<Rightarrow> ('idx,'pred::fs,'act::bn,'eff::fs) formula" is
  Pred\<^sub>\<alpha>
by (fact hereditarily_fs.Pred\<^sub>\<alpha>)

lift_definition Act :: "'eff \<Rightarrow> 'act \<Rightarrow> ('idx,'pred,'act,'eff) formula \<Rightarrow> ('idx,'pred::fs,'act::bn,'eff::fs) formula" is
  Act\<^sub>\<alpha>
by (fact hereditarily_fs.Act\<^sub>\<alpha>)

text \<open>The lifted constructors are equivariant (in the case of~@{const Conj}, on finitely supported
arguments).\<close>

lemma Conj_eqvt [simp]:
  assumes "finite (supp xset)"
  shows "p \<bullet> Conj xset = Conj (p \<bullet> xset)"
using assms unfolding Conj_def by simp

lemma Not_eqvt [eqvt, simp]: "p \<bullet> Not x = Not (p \<bullet> x)"
by transfer simp

lemma Pred_eqvt [eqvt, simp]: "p \<bullet> Pred f \<phi> = Pred (p \<bullet> f) (p \<bullet> \<phi>)"
by transfer simp

text \<open>The following lemmas describe the support of constructed formulas.\<close>

lemma supp_Conj [simp]:
  assumes "finite (supp xset)"
  shows "supp (Conj xset) = supp xset"
using assms unfolding Conj_def by simp

lemma supp_Not [simp]: "supp (Not x) = supp x"
by (metis Not.rep_eq supp_Not\<^sub>\<alpha> supp_Rep_formula)

lemma supp_Pred [simp]: "supp (Pred f \<phi>) = supp f \<union> supp \<phi>"
by (metis Pred.rep_eq supp_Pred\<^sub>\<alpha> supp_Rep_formula)

lemma supp_Act [simp]: "supp (Act f \<alpha> x) = supp f \<union> (supp \<alpha> \<union> supp x - bn \<alpha>)"
by (metis Act.rep_eq finite_supp supp_Act\<^sub>\<alpha> supp_Rep_formula)

text \<open>The lifted constructors are injective (partially for @{const Act}).\<close>

lemma Conj_eq_iff [simp]:
  assumes "finite (supp xset1)" and "finite (supp xset2)"
  shows "Conj xset1 = Conj xset2 \<longleftrightarrow> xset1 = xset2"
using assms
by (metis (erased, hide_lams) Conj\<^sub>\<alpha>_eq_iff Conj_rep_eq Rep_formula_inverse injI inj_eq bset.inj_map)

lemma Not_eq_iff [simp]: "Not x1 = Not x2 \<longleftrightarrow> x1 = x2"
by (metis Not.rep_eq Not\<^sub>\<alpha>_eq_iff Rep_formula_inverse)

lemma Pred_eq_iff [simp]: "Pred f1 \<phi>1 = Pred f2 \<phi>2 \<longleftrightarrow> f1 = f2 \<and> \<phi>1 = \<phi>2"
by (metis Pred.rep_eq Pred\<^sub>\<alpha>_eq_iff)

lemma Act_eq_iff: "Act f1 \<alpha>1 x1 = Act f2 \<alpha>2 x2 \<longleftrightarrow> Act\<^sub>\<alpha> f1 \<alpha>1 (Rep_formula x1) = Act\<^sub>\<alpha> f2 \<alpha>2 (Rep_formula x2)"
by (metis Act.rep_eq Rep_formula_inverse)

text \<open>Helpful lemmas for dealing with equalities involving~@{const Act}.\<close>

lemma Act_eq_iff_perm: "Act f1 \<alpha>1 x1 = Act f2 \<alpha>2 x2 \<longleftrightarrow>
  f1 = f2 \<and> (\<exists>p. supp x1 - bn \<alpha>1 = supp x2 - bn \<alpha>2 \<and> (supp x1 - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> x1 = x2 \<and> supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2 \<and> (supp \<alpha>1 - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> \<alpha>1 = \<alpha>2)"
  (is "?l \<longleftrightarrow> ?r")
proof
  assume *: "?l"
  then have "f1 = f2"
    by (metis Act_eq_iff Act\<^sub>\<alpha>_eq_iff alpha_tAct)
  moreover from * obtain p where alpha: "(bn \<alpha>1, rep_Tree\<^sub>\<alpha> (Rep_formula x1)) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) p (bn \<alpha>2, rep_Tree\<^sub>\<alpha> (Rep_formula x2))" and eq: "(bn \<alpha>1, \<alpha>1) \<approx>set (=) supp p (bn \<alpha>2, \<alpha>2)"
    by (metis Act_eq_iff Act\<^sub>\<alpha>_eq_iff alpha_tAct)
  from alpha have "supp x1 - bn \<alpha>1 = supp x2 - bn \<alpha>2"
    by (metis alpha_set.simps supp_Rep_formula supp_alpha_supp_rel)
  moreover from alpha have "(supp x1 - bn \<alpha>1) \<sharp>* p"
    by (metis alpha_set.simps supp_Rep_formula supp_alpha_supp_rel)
  moreover from alpha have "p \<bullet> x1 = x2"
    by (metis Rep_formula_eqvt Rep_formula_inject Tree\<^sub>\<alpha>.abs_eq_iff Tree\<^sub>\<alpha>_abs_rep alpha_Tree_permute_rep_commute alpha_set.simps)
  moreover from eq have "supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2"
    by (metis alpha_set.simps)
  moreover from eq have "(supp \<alpha>1 - bn \<alpha>1) \<sharp>* p"
    by (metis alpha_set.simps)
  moreover from eq have "p \<bullet> \<alpha>1 = \<alpha>2"
    by (simp add: alpha_set.simps)
  ultimately show "?r"
    by metis
next
  assume *: "?r"
  then have "f1 = f2"
    by metis
  moreover from * obtain p where 1: "supp x1 - bn \<alpha>1 = supp x2 - bn \<alpha>2" and 2: "(supp x1 - bn \<alpha>1) \<sharp>* p" and 3: "p \<bullet> x1 = x2"
    and 4: "supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2" and 5: "(supp \<alpha>1 - bn \<alpha>1) \<sharp>* p" and 6: "p \<bullet> \<alpha>1 = \<alpha>2"
    by metis
  from 1 2 3 6 have "(bn \<alpha>1, rep_Tree\<^sub>\<alpha> (Rep_formula x1)) \<approx>set (=\<^sub>\<alpha>) (supp_rel (=\<^sub>\<alpha>)) p (bn \<alpha>2, rep_Tree\<^sub>\<alpha> (Rep_formula x2))"
    by (metis (no_types, lifting) Rep_formula_eqvt alpha_Tree_permute_rep_commute alpha_set.simps bn_eqvt supp_Rep_formula supp_alpha_supp_rel)
  moreover from 4 5 6 have "(bn \<alpha>1, \<alpha>1) \<approx>set (=) supp p (bn \<alpha>2, \<alpha>2)"
    by (simp add: alpha_set.simps bn_eqvt)
  ultimately show "Act f1 \<alpha>1 x1 = Act f2 \<alpha>2 x2"
    by (metis Act_eq_iff Act\<^sub>\<alpha>_eq_iff alpha_tAct)
qed

lemma Act_eq_iff_perm_renaming: "Act f1 \<alpha>1 x1 = Act f2 \<alpha>2 x2 \<longleftrightarrow>
  f1 = f2 \<and> (\<exists>p. supp x1 - bn \<alpha>1 = supp x2 - bn \<alpha>2 \<and> (supp x1 - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> x1 = x2 \<and> supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2 \<and> (supp \<alpha>1 - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> \<alpha>1 = \<alpha>2 \<and> supp p \<subseteq> bn \<alpha>1 \<union> p \<bullet> bn \<alpha>1)"
  (is "?l \<longleftrightarrow> ?r")
proof
  assume "?l" then have "f1 = f2"
    by (metis Act_eq_iff_perm)
  moreover from \<open>?l\<close> obtain p where p: "supp x1 - bn \<alpha>1 = supp x2 - bn \<alpha>2 \<and> (supp x1 - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> x1 = x2 \<and> supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2 \<and> (supp \<alpha>1 - bn \<alpha>1) \<sharp>* p \<and> p \<bullet> \<alpha>1 = \<alpha>2"
    by (metis Act_eq_iff_perm)
  moreover obtain q where q_p: "\<forall>b\<in>bn \<alpha>1. q \<bullet> b = p \<bullet> b" and supp_q: "supp q \<subseteq> bn \<alpha>1 \<union> p \<bullet> bn \<alpha>1"
    by (metis set_renaming_perm2)
  have "supp q \<subseteq> supp p"
  proof
    fix a assume *: "a \<in> supp q" then show "a \<in> supp p"
    proof (cases "a \<in> bn \<alpha>1")
      case True then show ?thesis
        using "*" q_p by (metis mem_Collect_eq supp_perm)
    next
      case False then have "a \<in> p \<bullet> bn \<alpha>1"
        using "*" supp_q using UnE subsetCE by blast
      with False have "p \<bullet> a \<noteq> a"
        by (metis mem_permute_iff)
      then show ?thesis
        using fresh_def fresh_perm by blast
    qed
  qed
  with p have "(supp x1 - bn \<alpha>1) \<sharp>* q" and "(supp \<alpha>1 - bn \<alpha>1) \<sharp>* q"
    by (meson fresh_def fresh_star_def subset_iff)+
  moreover with p and q_p have "\<And>a. a \<in> supp \<alpha>1 \<Longrightarrow> q \<bullet> a = p \<bullet> a" and "\<And>a. a \<in> supp x1 \<Longrightarrow> q \<bullet> a = p \<bullet> a"
    by (metis Diff_iff fresh_perm fresh_star_def)+
  then have "q \<bullet> \<alpha>1 = p \<bullet> \<alpha>1" and "q \<bullet> x1 = p \<bullet> x1"
    by (metis supp_perm_perm_eq)+
  ultimately show "?r"
    using supp_q by (metis bn_eqvt)
next
  assume "?r" then show "?l"
    by (meson Act_eq_iff_perm)
qed

text \<open>The lifted constructors are free (except for @{const Act}).\<close>

lemma Tree_free [simp]:
  shows "finite (supp xset) \<Longrightarrow> Conj xset \<noteq> Not x"
  and "finite (supp xset) \<Longrightarrow> Conj xset \<noteq> Pred f \<phi>"
  and "finite (supp xset) \<Longrightarrow> Conj xset \<noteq> Act f \<alpha> x"
  and "Not x \<noteq> Pred f \<phi>"
  and "Not x1 \<noteq> Act f \<alpha> x2"
  and "Pred f1 \<phi> \<noteq> Act f2 \<alpha> x"
proof -
  show "finite (supp xset) \<Longrightarrow> Conj xset \<noteq> Not x"
    by (metis Conj_rep_eq Not.rep_eq Tree\<^sub>\<alpha>_free(1))
next
  show "finite (supp xset) \<Longrightarrow> Conj xset \<noteq> Pred f \<phi>"
    by (metis Conj_rep_eq Pred.rep_eq Tree\<^sub>\<alpha>_free(2))
next
  show "finite (supp xset) \<Longrightarrow> Conj xset \<noteq> Act f \<alpha> x"
    by (metis Conj_rep_eq Act.rep_eq Tree\<^sub>\<alpha>_free(3))
next
  show "Not x \<noteq> Pred f \<phi>"
    by (metis Not.rep_eq Pred.rep_eq Tree\<^sub>\<alpha>_free(4))
next
  show "Not x1 \<noteq> Act f \<alpha> x2"
    by (metis Not.rep_eq Act.rep_eq Tree\<^sub>\<alpha>_free(5))
next
  show "Pred f1 \<phi> \<noteq> Act f2 \<alpha> x"
    by (metis Pred.rep_eq Act.rep_eq Tree\<^sub>\<alpha>_free(6))
qed

subsection \<open>\texorpdfstring{$F/L$}{F/L}-formulas\<close>

context effect_nominal_ts
begin

text \<open>The predicate~@{term is_FL_formula} will characterise exactly those formulas in a particular
set~$A^{F/L}$.\<close>

inductive is_FL_formula :: "'effect first \<Rightarrow> ('idx,'pred,'act,'effect) formula \<Rightarrow> bool"
where
  Conj: "finite (supp xset) \<Longrightarrow> (\<And>x. x \<in> set_bset xset \<Longrightarrow> is_FL_formula F x) \<Longrightarrow> is_FL_formula F (Conj xset)"
| Not:  "is_FL_formula F x \<Longrightarrow> is_FL_formula F (Not x)"
| Pred: "f \<in>\<^sub>f\<^sub>s F \<Longrightarrow> is_FL_formula F (Pred f \<phi>)"
| Act:  "f \<in>\<^sub>f\<^sub>s F \<Longrightarrow> bn \<alpha> \<sharp>* (F,f) \<Longrightarrow> is_FL_formula (L (\<alpha>,F,f)) x \<Longrightarrow> is_FL_formula F (Act f \<alpha> x)"

abbreviation in_\<A> :: "('idx,'pred,'act,'effect) formula \<Rightarrow> 'effect first \<Rightarrow> bool"
  ("_ \<in> \<A>[_]" [51,0] 50) where
  "x \<in> \<A>[F] \<equiv> is_FL_formula F x"

declare is_FL_formula.induct [case_names Conj Not Pred Act, induct type: formula]

lemma is_FL_formula_eqvt [eqvt]: "x \<in> \<A>[F] \<Longrightarrow> p \<bullet> x \<in> \<A>[p \<bullet> F]"
proof (erule is_FL_formula.induct)
  fix xset :: "('a, 'pred, 'act, 'effect) formula set['a]" and F
  assume 1: "finite (supp xset)" and 2: "\<And>x. x \<in> set_bset xset \<Longrightarrow> p \<bullet> x \<in> \<A>[p \<bullet> F]"
  from 1 have "finite (supp (p \<bullet> xset))"
    by (metis permute_finite supp_eqvt)
  moreover from 2 have "\<And>x. x \<in> set_bset (p \<bullet> xset) \<Longrightarrow> x \<in> \<A>[p \<bullet> F]"
    by (metis (mono_tags) imageE permute_set_eq_image set_bset_eqvt)
  ultimately show "p \<bullet> Conj xset \<in> \<A>[p \<bullet> F]"
    using 1 by (simp add: Conj)
next
  fix F and x :: "('a, 'pred, 'act, 'effect) formula"
  assume "p \<bullet> x \<in> \<A>[p \<bullet> F]"
  then show "p \<bullet> Not x \<in> \<A>[p \<bullet> F]"
    by (simp add: Not)
next
  fix f and F :: "'effect first" and \<phi>
  assume "f \<in>\<^sub>f\<^sub>s F"
  then show "p \<bullet> Pred f \<phi> \<in> \<A>[p \<bullet> F]"
    by (simp add: Pred)
next
  fix f F \<alpha> and x :: "('a, 'pred, 'act, 'effect) formula"
  assume "f \<in>\<^sub>f\<^sub>s F" and "bn \<alpha> \<sharp>* (F,f)" and "p \<bullet> x \<in> \<A>[p \<bullet> L (\<alpha>, F, f)]"
  then show "p \<bullet> Act f \<alpha> x \<in> \<A>[p \<bullet> F]"
    by (metis (mono_tags, lifting) Act Act_eqvt L_eqvt' Pair_eqvt bn_eqvt fresh_star_permute_iff member_fs_set_permute_iff)
qed

end

subsection \<open>Induction over infinitary formulas\<close>

(* Not needed yet for F/L-formulas, so not done. *)

subsection \<open>Strong induction over infinitary formulas\<close>

(* Not needed yet for F/L-formulas, so not done. *)

end


theory "Env-Nominal"
  imports Env "Nominal-Utils" "Nominal-HOLCF"
begin

subsubsection \<open>Equivariance lemmas\<close>

lemma edom_perm:
  fixes f :: "'a::pt \<Rightarrow> 'b::{pcpo_pt}"
  shows "edom (\<pi> \<bullet> f) = \<pi> \<bullet> (edom f)"
  by (simp add: edom_def)

lemmas edom_perm_rev[simp,eqvt] = edom_perm[symmetric]

lemma mem_edom_perm[simp]:
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt}"
  shows "xa \<in> edom (p \<bullet> \<rho>) \<longleftrightarrow> - p \<bullet> xa \<in> edom \<rho>"
  by (metis (mono_tags) edom_perm_rev mem_Collect_eq permute_set_eq)

lemma env_restr_eqvt[eqvt]:
  fixes m :: "'a::pt \<Rightarrow> 'b::{cont_pt,pcpo}"
  shows "\<pi> \<bullet> m f|` d = (\<pi> \<bullet> m) f|` (\<pi> \<bullet> d)"
  by (auto simp add: env_restr_def)

lemma esing_eqvt[eqvt]: "\<pi> \<bullet> (esing x) = esing (\<pi> \<bullet> x)"
  unfolding esing_def
  apply perm_simp
  apply (simp add: Abs_cfun_eqvt)
  done

subsubsection \<open>Permutation and restriction\<close>

lemma env_restr_perm:
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt,pure}"
  assumes "supp p \<sharp>* S" and [simp]: "finite S"
  shows "(p \<bullet> \<rho>) f|` S = \<rho> f|` S"
using assms
apply -
apply (rule ext)
apply (case_tac "x \<in> S")
apply (simp)
apply (subst permute_fun_def)
apply (simp add: permute_pure)
apply (subst perm_supp_eq)
apply (auto simp add:perm_supp_eq supp_minus_perm fresh_star_def fresh_def supp_set_elem_finite)
done

lemma env_restr_perm':
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt,pure}"
  assumes "supp p \<sharp>* S" and [simp]: "finite S"
  shows "p \<bullet> (\<rho> f|` S) = \<rho> f|` S"
  by (simp add: perm_supp_eq[OF assms(1)]  env_restr_perm[OF assms])

lemma env_restr_flip:
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt,pure}"
  assumes "x \<notin> S" and "x' \<notin> S"
  shows "((x' \<leftrightarrow> x) \<bullet> \<rho>) f|` S = \<rho> f|` S"
  using assms
  apply -
  apply rule
  apply (auto  simp add: permute_flip_at env_restr_def split:if_splits)
  by (metis eqvt_lambda flip_at_base_simps(3) minus_flip permute_pure unpermute_def)

lemma env_restr_flip':
  fixes \<rho> :: "'a::at_base \<Rightarrow> 'b::{pcpo_pt,pure}"
  assumes "x \<notin> S" and "x' \<notin> S"
  shows "(x' \<leftrightarrow> x) \<bullet> (\<rho> f|` S) = \<rho> f|` S"
  by (simp add: flip_set_both_not_in[OF assms]  env_restr_flip[OF assms])

subsubsection \<open>Pure codomains\<close>
(*
lemma edom_fv_pure:
  fixes f :: "('a::at_base \<Rightarrow> 'b::{pcpo,pure})"
  assumes "finite (edom f)"
  shows  "fv f = edom f"
using assms
proof (induction "edom f" arbitrary: f)
  case empty
  hence "f = \<bottom>" unfolding edom_def by auto
  thus ?case by (auto simp add: fv_def fresh_def supp_def)
next
  case (insert x S)
  have "f = (env_delete x f)(x := f x)" by auto

  from `insert x S = edom f`  and `x \<notin> S`
  have "S = edom (env_delete x f)" by auto
  hence "fv (env_delete x f) = edom (env_delete x f)" by (rule insert)
*)

lemma edom_fv_pure:
  fixes f :: "('a::at_base \<Rightarrow> 'b::{pcpo,pure})"
  assumes "finite (edom f)"
  shows  "fv f \<subseteq> edom f"
using assms
proof (induction "edom f" arbitrary: f)
  case empty
  hence "f = \<bottom>" unfolding edom_def by auto
  thus ?case by (auto simp add: fv_def fresh_def supp_def)
next
  case (insert x S)
  have "f = (env_delete x f)(x := f x)" by auto
  hence "fv f \<subseteq> fv (env_delete x f) \<union> fv x \<union> fv (f x)"
    using eqvt_fresh_cong3[where f = fun_upd and x = "env_delete x f" and y = x and z = "f x", OF fun_upd_eqvt]
    apply (auto simp add: fv_def fresh_def)
    by (metis fresh_def pure_fresh)
  also

  from \<open>insert x S = edom f\<close>  and \<open>x \<notin> S\<close>
  have "S = edom (env_delete x f)" by auto
  hence "fv (env_delete x f) \<subseteq> edom (env_delete x f)" by (rule insert)
  also
  have "fv (f x) = {}" by (rule fv_pure)
  also
  from \<open>insert x S = edom f\<close> have "x \<in> edom f" by auto
  hence "edom (env_delete x f) \<union> fv x \<union> {} \<subseteq> edom f" by auto
  finally
  show ?case by this (intro Un_mono subset_refl)
qed

(*
lemma domA_fresh_pure:
  fixes \<Gamma> :: "('a::at_base \<times> 'b::pure) list"
  shows  "x \<in> domA \<Gamma> \<longleftrightarrow> \<not>(atom x \<sharp> \<Gamma>)"
  unfolding domA_fv_pure[symmetric]
  by (auto simp add: fv_def fresh_def)
*)

end


section \<open>Properties of Sets of IO Sequences\<close>

text \<open>This theory contains various definitions for properties of sets of IO-sequences.\<close>

theory IO_Sequence_Set
imports FSM
begin

fun output_completion :: "('a \<times> 'b) list set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) list set" where
  "output_completion P Out = P \<union> {io@[(fst xy, y)] | io xy y . y \<in> Out \<and> io@[xy] \<in> P \<and> io@[(fst xy, y)] \<notin> P}"

fun output_complete_sequences :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "output_complete_sequences M P = (\<forall> io \<in> P . io = [] \<or> (\<forall> y \<in> (outputs M) . (butlast io)@[(fst (last io), y)] \<in> P))"

fun acyclic_sequences :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "acyclic_sequences M q P = (\<forall> p . (path M q p \<and> p_io p \<in> P) \<longrightarrow> distinct (visited_nodes q p))"

fun acyclic_sequences' :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "acyclic_sequences' M q P = (\<forall> io \<in> P . \<forall> p \<in> (paths_for_io M q io) .  distinct (visited_nodes q p))"

lemma acyclic_sequences_alt_def[code] : "acyclic_sequences M P = acyclic_sequences' M P"
  unfolding acyclic_sequences'.simps acyclic_sequences.simps paths_for_io_def
  by blast

fun single_input_sequences :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "single_input_sequences M P = (\<forall> xys1 xys2 xy1 xy2 . (xys1@[xy1] \<in> P \<and> xys2@[xy2] \<in> P \<and> io_targets M xys1 (initial M) = io_targets M xys2 (initial M)) \<longrightarrow> fst xy1 = fst xy2)"

fun single_input_sequences' :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "single_input_sequences' M P = (\<forall> io1 \<in> P . \<forall> io2 \<in> P . io1 = [] \<or> io2 = [] \<or> ((io_targets M (butlast io1) (initial M) = io_targets M (butlast io2) (initial M)) \<longrightarrow> fst (last io1) = fst (last io2)))"

lemma single_input_sequences_alt_def[code] : "single_input_sequences M P = single_input_sequences' M P"
  unfolding single_input_sequences.simps single_input_sequences'.simps
  by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

fun output_complete_for_FSM_sequences_from_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "output_complete_for_FSM_sequences_from_state M q P = (\<forall> io xy t . io@[xy] \<in> P \<and> t \<in> transitions M \<and> t_source t \<in> io_targets M io q \<and> t_input t = fst xy \<longrightarrow> io@[(fst xy, t_output t)] \<in> P)"

lemma output_complete_for_FSM_sequences_from_state_alt_def :
  shows "output_complete_for_FSM_sequences_from_state M q P = (\<forall> xys xy y . (xys@[xy] \<in> P \<and> (\<exists> q' \<in> (io_targets M xys q) . [(fst xy,y)] \<in> LS M q')) \<longrightarrow> xys@[(fst xy,y)] \<in> P)"
proof -
  have "\<And> xys xy y q' . q' \<in> (io_targets M xys q) \<Longrightarrow> [(fst xy,y)] \<in> LS M q' \<Longrightarrow> \<exists> t . t \<in> transitions M \<and> t_source t \<in> io_targets M xys q \<and> t_input t = fst xy \<and> t_output t = y"
    unfolding io_targets.simps LS.simps
    using path_append path_append_transition_elim(2) by fastforce

  moreover have "\<And> xys xy y t . t \<in> transitions M \<Longrightarrow> t_source t \<in> io_targets M xys q \<Longrightarrow> t_input t = fst xy \<Longrightarrow> t_output t = y \<Longrightarrow> \<exists> q' \<in> (io_targets M xys q) . [(fst xy,y)] \<in> LS M q'"
    unfolding io_targets.simps LS.simps
  proof -
    fix xys :: "('b \<times> 'c) list" and xy :: "'b \<times> 'd" and y :: 'c and t :: "'a \<times> 'b \<times> 'c \<times> 'a"
    assume a1: "t_input t = fst xy"
    assume a2: "t_output t = y"
    assume a3: "t_source t \<in> {target q p |p. path M q p \<and> p_io p = xys}"
    assume a4: "t \<in> FSM.transitions M"
    have "\<forall>p f. [f (p::'a \<times> 'b \<times> 'c \<times> 'a)::'b \<times> 'c] = map f [p]"
      by simp
    then have "\<exists>a. (\<exists>ps. [(t_input t, t_output t)] = p_io ps \<and> path M a ps) \<and> a \<in> {target q ps |ps. path M q ps \<and> p_io ps = xys}"
      using a4 a3 by (meson single_transition_path)
    then have "\<exists>a. [(t_input t, t_output t)] \<in> {p_io ps |ps. path M a ps} \<and> a \<in> {target q ps |ps. path M q ps \<and> p_io ps = xys}"
      by auto
    then show "\<exists>a\<in>{target q ps |ps. path M q ps \<and> p_io ps = xys}. [(fst xy, y)] \<in> {p_io ps |ps. path M a ps}"
      using a2 a1 by (metis (no_types, lifting))
  qed

  ultimately show ?thesis
    unfolding output_complete_for_FSM_sequences_from_state.simps by blast
qed

fun output_complete_for_FSM_sequences_from_state' :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "output_complete_for_FSM_sequences_from_state' M q P = (\<forall> io\<in>P . \<forall> t \<in> transitions M . io = [] \<or> (t_source t \<in> io_targets M (butlast io) q \<and> t_input t = fst (last io) \<longrightarrow> (butlast io)@[(fst (last io), t_output t)] \<in> P))"

lemma output_complete_for_FSM_sequences_alt_def'[code] : "output_complete_for_FSM_sequences_from_state M q P = output_complete_for_FSM_sequences_from_state' M q P"
  unfolding output_complete_for_FSM_sequences_from_state.simps output_complete_for_FSM_sequences_from_state'.simps
  by (metis last_snoc snoc_eq_iff_butlast)

fun deadlock_states_sequences :: "('a,'b,'c) fsm \<Rightarrow> 'a set \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "deadlock_states_sequences M Q P = (\<forall> xys \<in> P .
                                        ((io_targets M xys (initial M) \<subseteq> Q
                                          \<and> \<not> (\<exists> xys' \<in> P . length xys < length xys' \<and> take (length xys) xys' = xys)))
                                      \<or> (\<not> io_targets M xys (initial M) \<inter> Q = {}
                                          \<and> (\<exists> xys' \<in> P . length xys < length xys' \<and> take (length xys) xys' = xys)))"

fun reachable_states_sequences :: "('a,'b,'c) fsm \<Rightarrow> 'a set \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "reachable_states_sequences M Q P = (\<forall> q \<in> Q . \<exists> xys \<in> P . q \<in> io_targets M xys (initial M))"

fun prefix_closed_sequences :: "('b \<times> 'c) list set \<Rightarrow> bool" where
  "prefix_closed_sequences P = (\<forall> xys1 xys2 . xys1@xys2 \<in> P \<longrightarrow> xys1 \<in> P)"

fun prefix_closed_sequences' :: "('b \<times> 'c) list set \<Rightarrow> bool" where
  "prefix_closed_sequences' P = (\<forall> io \<in> P . io = [] \<or> (butlast io) \<in> P)"

lemma prefix_closed_sequences_alt_def[code] : "prefix_closed_sequences P = prefix_closed_sequences' P"
proof
  show "prefix_closed_sequences P \<Longrightarrow> prefix_closed_sequences' P"
    unfolding prefix_closed_sequences.simps prefix_closed_sequences'.simps
    by (metis append_butlast_last_id)

  have "\<And>xys1 xys2. \<forall>io\<in>P. io = [] \<or> butlast io \<in> P \<Longrightarrow> xys1 @ xys2 \<in> P \<Longrightarrow> xys1 \<in> P"
  proof -
    fix xys1 xys2 assume "\<forall>io\<in>P. io = [] \<or> butlast io \<in> P" and "xys1 @ xys2 \<in> P"
    then show "xys1 \<in> P"
    proof (induction xys2 rule: rev_induct)
      case Nil
      then show ?case by auto
    next
      case (snoc a xys2)
      then show ?case
        by (metis append.assoc snoc_eq_iff_butlast)
    qed
  qed

  then show "prefix_closed_sequences' P \<Longrightarrow> prefix_closed_sequences P"
    unfolding prefix_closed_sequences.simps prefix_closed_sequences'.simps by blast
qed

subsection \<open>Completions\<close>

definition prefix_completion :: "'a list set \<Rightarrow> 'a list set" where
  "prefix_completion P = {xs . \<exists> ys . xs@ys \<in> P}"

lemma prefix_completion_closed :
  "prefix_closed_sequences (prefix_completion P)"
  unfolding prefix_closed_sequences.simps prefix_completion_def
  by auto

lemma prefix_completion_source_subset :
  "P \<subseteq> prefix_completion P"
  unfolding prefix_completion_def
  by (metis (no_types, lifting) append_Nil2 mem_Collect_eq subsetI)

definition output_completion_for_FSM :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> ('b \<times> 'c) list set" where
  "output_completion_for_FSM M P = P \<union> { io@[(x,y')] | io x y' . (y' \<in> (outputs M)) \<and> (\<exists> y . io@[(x,y)] \<in> P)}"

lemma output_completion_for_FSM_complete :
  shows "output_complete_sequences M (output_completion_for_FSM M P)"
  unfolding output_completion_for_FSM_def output_complete_sequences.simps
proof
  fix io assume *: "io \<in> P \<union> {io @ [(x, y')] |io x y'. y' \<in> (outputs M) \<and> (\<exists>y. io @ [(x, y)] \<in> P)}"
  show   "io = [] \<or>
          (\<forall>y\<in>(outputs M).
              butlast io @ [(fst (last io), y)]
              \<in> P \<union> {io @ [(x, y')] |io x y'. y' \<in> (outputs M) \<and> (\<exists>y. io @ [(x, y)] \<in> P)})"
  proof (cases io rule: rev_cases)
    case Nil
    then show ?thesis by blast
  next
    case (snoc ys y)
    then show ?thesis proof (cases "io \<in> P")
      case True
      then have "butlast io @ [(fst (last io), (snd (last io)))] \<in> P" using snoc by auto
      then show ?thesis using snoc by blast
    next
      case False
      then show ?thesis
        using "*" by auto
    qed
  qed
qed

lemma output_completion_for_FSM_length :
  assumes "\<forall> io \<in> P . length io \<le> k"
  shows   "\<forall> io \<in> output_completion_for_FSM M P. length io \<le> k"
  using assms unfolding output_completion_for_FSM_def
  by auto

lemma output_completion_for_FSM_code[code] :
  "output_completion_for_FSM M P = P \<union> (\<Union>(image (\<lambda>(y,io) . if length io = 0 then {} else {((butlast io)@[(fst (last io),y)])})  ((outputs M) \<times> P)))"
proof -
  let ?OC = "{io @ [(x, y')] |io x y'. y' \<in> FSM.outputs M \<and> (\<exists>y. io @ [(x, y)] \<in> P)}"
  let ?OC' = "(\<Union>(y, io)\<in>FSM.outputs M \<times> P. if length io = 0 then {} else {butlast io @ [(fst (last io), y)]})"

  have "?OC = ?OC'"
  proof -
    have "?OC \<subseteq> ?OC'"
    proof
      fix io' assume "io' \<in> ?OC"
      then obtain io x y y' where "io' = io @ [(x, y')]"
                            and   "y' \<in> FSM.outputs M"
                            and   "io @ [(x, y)] \<in> P"
        by blast
      then have "(y',io @ [(x, y)]) \<in> FSM.outputs M \<times> P" by blast
      moreover have "length (io @ [(x, y)]) \<noteq> 0" by auto
      ultimately show "io' \<in> ?OC'"
        unfolding \<open>io' = io @ [(x, y')]\<close> by force
    qed
    moreover have "?OC' \<subseteq> ?OC"
    proof
      fix io' assume "io' \<in> ?OC'"
      then obtain y io where "y \<in> outputs M" and "io \<in> P"
                       and "io' \<in> (if length io = 0 then {} else {butlast io @ [(fst (last io), y)]})"
        by auto
      then have "io' = butlast io @ [(fst (last io), y)]"
        by (meson empty_iff singletonD)
      have "io \<noteq> []"
        using \<open>io' \<in> (if length io = 0 then {} else {butlast io @ [(fst (last io), y)]})\<close>
        by auto

      then have "butlast io @ [(fst (last io), snd (last io))] \<in> P"
        by (simp add: \<open>io \<in> P\<close>)

      then show "io' \<in> ?OC"
        using \<open>y \<in> outputs M\<close> \<open>io \<in> P\<close>
        unfolding \<open>io' = butlast io @ [(fst (last io), y)]\<close> by blast
    qed
    ultimately show ?thesis by blast
  qed

  then show ?thesis
    unfolding output_completion_for_FSM_def
    by simp
qed

end