theory FL_Validity
imports
  FL_Transition_System
  FL_Formula
begin

section \<open>Validity With Effects\<close>

text \<open>The following is needed to prove termination of~@{term FL_validTree}.\<close>

definition alpha_Tree_rel where
  "alpha_Tree_rel \<equiv> {(x,y). x =\<^sub>\<alpha> y}"

lemma alpha_Tree_relI [simp]:
  assumes "x =\<^sub>\<alpha> y" shows "(x,y) \<in> alpha_Tree_rel"
using assms unfolding alpha_Tree_rel_def by simp

lemma alpha_Tree_relE:
  assumes "(x,y) \<in> alpha_Tree_rel" and "x =\<^sub>\<alpha> y \<Longrightarrow> P"
  shows P
using assms unfolding alpha_Tree_rel_def by simp

lemma wf_alpha_Tree_rel_hull_rel_Tree_wf:
  "wf (alpha_Tree_rel O hull_rel O Tree_wf)"
proof (rule wf_relcomp_compatible)
  show "wf (hull_rel O Tree_wf)"
    by (metis Tree_wf_eqvt' wf_Tree_wf wf_hull_rel_relcomp)
next
  show "(hull_rel O Tree_wf) O alpha_Tree_rel \<subseteq> alpha_Tree_rel O (hull_rel O Tree_wf)"
  proof
    fix x :: "('e, 'f, 'g, 'h) Tree \<times> ('e, 'f, 'g, 'h) Tree"
    assume "x \<in> (hull_rel O Tree_wf) O alpha_Tree_rel"
    then obtain x1 x2 x3 x4 where x: "x = (x1,x4)" and 1: "(x1,x2) \<in> hull_rel" and 2: "(x2,x3) \<in> Tree_wf" and 3: "(x3,x4) \<in> alpha_Tree_rel"
      by auto
    from 2 have "(x1,x4) \<in> alpha_Tree_rel O hull_rel O Tree_wf"
      using 1 and 3 proof (induct rule: Tree_wf.induct)
        \<comment> \<open>@{const tConj}\<close>
        fix t and tset :: "('e,'f,'g,'h) Tree set['e]"
        assume *: "t \<in> set_bset tset" and **: "(x1,t) \<in> hull_rel" and ***: "(tConj tset, x4) \<in> alpha_Tree_rel"
        from "**" obtain p where x1: "x1 = p \<bullet> t"
          using hull_rel.cases by blast
        from "***" have "tConj tset =\<^sub>\<alpha> x4"
          by (rule alpha_Tree_relE)
        then obtain tset' where x4: "x4 = tConj tset'" and "rel_bset (=\<^sub>\<alpha>) tset tset'"
          by (cases "x4") simp_all
        with "*" obtain t' where t': "t' \<in> set_bset tset'" and "t =\<^sub>\<alpha> t'"
          by (metis rel_bset.rep_eq rel_set_def)
        with x1 have "(x1, p \<bullet> t') \<in> alpha_Tree_rel"
          by (metis Tree\<^sub>\<alpha>.abs_eq_iff alpha_Tree_relI permute_Tree\<^sub>\<alpha>.abs_eq)
        moreover have "(p \<bullet> t', t') \<in> hull_rel"
          by (rule hull_rel.intros)
        moreover from x4 and t' have "(t', x4) \<in> Tree_wf"
          by (simp add: Tree_wf.intros(1))
        ultimately show "(x1,x4) \<in> alpha_Tree_rel O hull_rel O Tree_wf"
          by auto
      next
        \<comment> \<open>@{const tNot}\<close>
        fix t
        assume *: "(x1,t) \<in> hull_rel" and **: "(tNot t, x4) \<in> alpha_Tree_rel"
        from "*" obtain p where x1: "x1 = p \<bullet> t"
          using hull_rel.cases by blast
        from "**" have "tNot t =\<^sub>\<alpha> x4"
          by (rule alpha_Tree_relE)
        then obtain t' where x4: "x4 = tNot t'" and "t =\<^sub>\<alpha> t'"
          by (cases "x4") simp_all
        with x1 have "(x1, p \<bullet> t') \<in> alpha_Tree_rel"
          by (metis Tree\<^sub>\<alpha>.abs_eq_iff alpha_Tree_relI permute_Tree\<^sub>\<alpha>.abs_eq x1)
        moreover have "(p \<bullet> t', t') \<in> hull_rel"
          by (rule hull_rel.intros)
        moreover from x4 have "(t', x4) \<in> Tree_wf"
          using Tree_wf.intros(2) by blast
        ultimately show "(x1,x4) \<in> alpha_Tree_rel O hull_rel O Tree_wf"
          by auto
      next
        \<comment> \<open>@{const tAct}\<close>
        fix f \<alpha> t
        assume *: "(x1,t) \<in> hull_rel" and **: "(tAct f \<alpha> t, x4) \<in> alpha_Tree_rel"
        from "*" obtain p where x1: "x1 = p \<bullet> t"
          using hull_rel.cases by blast
        from "**" have "tAct f \<alpha> t =\<^sub>\<alpha> x4"
          by (rule alpha_Tree_relE)
        then obtain q t' where x4: "x4 = tAct f (q \<bullet> \<alpha>) t'" and "q \<bullet> t =\<^sub>\<alpha> t'"
          by (cases "x4") (auto simp add: alpha_set)
        with x1 have "(x1, p \<bullet> -q \<bullet> t') \<in> alpha_Tree_rel"
          by (metis Tree\<^sub>\<alpha>.abs_eq_iff alpha_Tree_relI permute_Tree\<^sub>\<alpha>.abs_eq permute_minus_cancel(1))
        moreover have "(p \<bullet> -q \<bullet> t', t') \<in> hull_rel"
          by (metis hull_rel.simps permute_plus)
        moreover from x4 have "(t', x4) \<in> Tree_wf"
          by (simp add: Tree_wf.intros(3))
        ultimately show "(x1,x4) \<in> alpha_Tree_rel O hull_rel O Tree_wf"
          by auto
      qed
    with x show "x \<in> alpha_Tree_rel O hull_rel O Tree_wf"
      by simp
  qed
qed

lemma alpha_Tree_rel_relcomp_trivialI [simp]:
  assumes "(x, y) \<in> R"
  shows "(x, y) \<in> alpha_Tree_rel O R"
using assms unfolding alpha_Tree_rel_def
by (metis Tree\<^sub>\<alpha>.abs_eq_iff case_prodI mem_Collect_eq relcomp.relcompI)

lemma alpha_Tree_rel_relcompI [simp]:
  assumes "x =\<^sub>\<alpha> x'" and "(x', y) \<in> R"
  shows "(x, y) \<in> alpha_Tree_rel O R"
using assms unfolding alpha_Tree_rel_def
by (metis case_prodI mem_Collect_eq relcomp.relcompI)

subsection \<open>Validity for infinitely branching trees\<close>

context effect_nominal_ts
begin

  text \<open>Since we defined formulas via a manual quotient construction, we also need to define
  validity via lifting from the underlying type of infinitely branching trees. We cannot use
  {\bf nominal\_function} because that generates proof obligations where, for formulas of the
  form~@{term "Conj xset"}, the assumption that~@{term xset} has finite support is missing.\<close>

  declare conj_cong [fundef_cong]

  function (sequential) FL_valid_Tree :: "'state \<Rightarrow> ('idx,'pred,'act,'effect) Tree \<Rightarrow> bool" where
    "FL_valid_Tree P (tConj tset) \<longleftrightarrow> (\<forall>t\<in>set_bset tset. FL_valid_Tree P t)"
  | "FL_valid_Tree P (tNot t) \<longleftrightarrow> \<not> FL_valid_Tree P t"
  | "FL_valid_Tree P (tPred f \<phi>) \<longleftrightarrow> \<langle>f\<rangle>P \<turnstile> \<phi>"
  | "FL_valid_Tree P (tAct f \<alpha> t) \<longleftrightarrow> (\<exists>\<alpha>' t' P'. tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha>' t' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree P' t')"
  by pat_completeness auto
  termination proof
    let ?R = "inv_image (alpha_Tree_rel O hull_rel O Tree_wf) snd"
    {
      show "wf ?R"
        by (metis wf_alpha_Tree_rel_hull_rel_Tree_wf wf_inv_image)
    next
      fix P :: 'state and tset :: "('idx,'pred,'act,'effect) Tree set['idx]" and t
      assume "t \<in> set_bset tset" then show "((P, t), (P, tConj tset)) \<in> ?R"
        by (simp add: Tree_wf.intros(1))
    next
      fix P :: 'state and t :: "('idx,'pred,'act,'effect) Tree"
      show "((P, t), (P, tNot t)) \<in> ?R"
        by (simp add: Tree_wf.intros(2))
    next
      fix P1 P2 :: 'state and f and \<alpha>1 \<alpha>2 and t1 t2 :: "('idx,'pred,'act,'effect) Tree"
      assume "tAct f \<alpha>1 t1 =\<^sub>\<alpha> tAct f \<alpha>2 t2"
      then obtain p where "t2 =\<^sub>\<alpha> p \<bullet> t1"
        by (auto simp add: alphas) (metis alpha_Tree_symp sympE)
      then show "((P2, t2), (P1, tAct f \<alpha>1 t1)) \<in> ?R"
        by (simp add: Tree_wf.intros(3))
    }
  qed

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

  lemma FL_valid_Tree_eqvt': "FL_valid_Tree P t \<longleftrightarrow> FL_valid_Tree (p \<bullet> P) (p \<bullet> t)"
  proof (induction P t rule: FL_valid_Tree.induct)
    case (1 P tset) show ?case
      proof
        assume *: "FL_valid_Tree P (tConj tset)"
        {
          fix t
          assume "t \<in> p \<bullet> set_bset tset"
          with "1.IH" and "*" have "FL_valid_Tree (p \<bullet> P) t"
            by (metis (no_types, lifting) imageE permute_set_eq_image FL_valid_Tree.simps(1))
        }
        then show "FL_valid_Tree (p \<bullet> P) (p \<bullet> tConj tset)"
          by simp
      next
        assume *: "FL_valid_Tree (p \<bullet> P) (p \<bullet> tConj tset)"
        {
          fix t
          assume "t \<in> set_bset tset"
          with "1.IH" and "*" have "FL_valid_Tree P t"
            by (metis mem_permute_iff permute_Tree_tConj set_bset_eqvt FL_valid_Tree.simps(1))
        }
        then show "FL_valid_Tree P (tConj tset)"
          by simp
      qed
  next
    case 2 then show ?case by simp
  next
    case 3 show ?case by simp (metis effect_apply_eqvt' permute_minus_cancel(2) satisfies_eqvt)
  next
    case (4 P f \<alpha> t) show ?case
      proof
        assume "FL_valid_Tree P (tAct f \<alpha> t)"
        then obtain \<alpha>' t' P' where *: "tAct f \<alpha> t =\<^sub>\<alpha> tAct f \<alpha>' t' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree P' t'"
          by auto
        with "4.IH" have "FL_valid_Tree (p \<bullet> P') (p \<bullet> t')"
          by blast
        moreover from "*" have "p \<bullet> \<langle>f\<rangle>P \<rightarrow> \<langle>p \<bullet> \<alpha>', p \<bullet> P'\<rangle>"
          by (metis transition_eqvt')
        moreover from "*" have "p \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct (p \<bullet> f) (p \<bullet> \<alpha>') (p \<bullet> t')"
          by (metis alpha_Tree_eqvt permute_Tree.simps(4))
        ultimately show "FL_valid_Tree (p \<bullet> P) (p \<bullet> tAct f \<alpha> t)"
          by auto
      next
        assume "FL_valid_Tree (p \<bullet> P) (p \<bullet> tAct f \<alpha> t)"
        then obtain \<alpha>' t' P' where *: "p \<bullet> tAct f \<alpha> t =\<^sub>\<alpha> tAct (p \<bullet> f) \<alpha>' t' \<and> (p \<bullet> \<langle>f\<rangle>P) \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree P' t'"
          by auto
        then have eq: "tAct f \<alpha> t =\<^sub>\<alpha> tAct f (-p \<bullet> \<alpha>') (-p \<bullet> t')"
          by (metis alpha_Tree_eqvt permute_Tree.simps(4) permute_minus_cancel(2))
        moreover from "*" have "\<langle>f\<rangle>P \<rightarrow> \<langle>-p \<bullet> \<alpha>', -p \<bullet> P'\<rangle>"
          by (metis permute_minus_cancel(2) transition_eqvt')
        moreover with "4.IH" have "FL_valid_Tree (-p \<bullet> P') (-p \<bullet> t')"
          using eq and "*" by simp
        ultimately show "FL_valid_Tree P (tAct f \<alpha> t)"
          by auto
      qed
  qed

  lemma FL_valid_Tree_eqvt [eqvt]:
    assumes "FL_valid_Tree P t" shows "FL_valid_Tree (p \<bullet> P) (p \<bullet> t)"
  using assms by (metis FL_valid_Tree_eqvt')

  text \<open>$\alpha$-equivalent trees validate the same states.\<close>

  lemma alpha_Tree_FL_valid_Tree:
    assumes "t1 =\<^sub>\<alpha> t2"
    shows "FL_valid_Tree P t1 \<longleftrightarrow> FL_valid_Tree P t2"
  using assms proof (induction t1 t2 arbitrary: P rule: alpha_Tree_induct)
    case tConj then show ?case
      by auto (metis (mono_tags) rel_bset.rep_eq rel_set_def)+
  next
    case (tAct f1 \<alpha>1 t1 f2 \<alpha>2 t2) show ?case
    proof
      assume "FL_valid_Tree P (tAct f1 \<alpha>1 t1)"
      then obtain \<alpha>' t' P' where "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f1 \<alpha>' t' \<and> \<langle>f1\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree P' t'"
        by auto
      moreover from tAct.hyps have "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2"
        using alpha_tAct by blast
      ultimately show "FL_valid_Tree P (tAct f2 \<alpha>2 t2)"
        using tAct.hyps by (metis Tree\<^sub>\<alpha>.abs_eq_iff FL_valid_Tree.simps(4))
    next
      assume "FL_valid_Tree P (tAct f2 \<alpha>2 t2)"
      then obtain \<alpha>' t' P' where "tAct f2 \<alpha>2 t2 =\<^sub>\<alpha> tAct f2 \<alpha>' t' \<and> \<langle>f2\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree P' t'"
        by auto
      moreover from tAct.hyps have "tAct f1 \<alpha>1 t1 =\<^sub>\<alpha> tAct f2 \<alpha>2 t2"
        using alpha_tAct by blast
      ultimately show "FL_valid_Tree P (tAct f1 \<alpha>1 t1)"
        using tAct.hyps by (metis Tree\<^sub>\<alpha>.abs_eq_iff FL_valid_Tree.simps(4))
    qed
  qed simp_all

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

  lift_definition FL_valid_Tree\<^sub>\<alpha> :: "'state \<Rightarrow> ('idx,'pred,'act,'effect) Tree\<^sub>\<alpha> \<Rightarrow> bool" is
    FL_valid_Tree
  by (fact alpha_Tree_FL_valid_Tree)

  lemma FL_valid_Tree\<^sub>\<alpha>_eqvt [eqvt]:
    assumes "FL_valid_Tree\<^sub>\<alpha> P t" shows "FL_valid_Tree\<^sub>\<alpha> (p \<bullet> P) (p \<bullet> t)"
  using assms by transfer (fact FL_valid_Tree_eqvt)

  lemma FL_valid_Tree\<^sub>\<alpha>_Conj\<^sub>\<alpha> [simp]: "FL_valid_Tree\<^sub>\<alpha> P (Conj\<^sub>\<alpha> tset\<^sub>\<alpha>) \<longleftrightarrow> (\<forall>t\<^sub>\<alpha>\<in>set_bset tset\<^sub>\<alpha>. FL_valid_Tree\<^sub>\<alpha> P t\<^sub>\<alpha>)"
  proof -
    have "FL_valid_Tree P (rep_Tree\<^sub>\<alpha> (abs_Tree\<^sub>\<alpha> (tConj (map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>)))) \<longleftrightarrow> FL_valid_Tree P (tConj (map_bset rep_Tree\<^sub>\<alpha> tset\<^sub>\<alpha>))"
      by (metis Tree\<^sub>\<alpha>_rep_abs alpha_Tree_FL_valid_Tree)
    then show ?thesis
      by (simp add: FL_valid_Tree\<^sub>\<alpha>_def Conj\<^sub>\<alpha>_def map_bset.rep_eq)
  qed

  lemma FL_valid_Tree\<^sub>\<alpha>_Not\<^sub>\<alpha> [simp]: "FL_valid_Tree\<^sub>\<alpha> P (Not\<^sub>\<alpha> t\<^sub>\<alpha>) \<longleftrightarrow> \<not> FL_valid_Tree\<^sub>\<alpha> P t\<^sub>\<alpha>"
  by transfer simp

  lemma FL_valid_Tree\<^sub>\<alpha>_Pred\<^sub>\<alpha> [simp]: "FL_valid_Tree\<^sub>\<alpha> P (Pred\<^sub>\<alpha> f \<phi>) \<longleftrightarrow> \<langle>f\<rangle>P \<turnstile> \<phi>"
  by transfer simp

  lemma FL_valid_Tree\<^sub>\<alpha>_Act\<^sub>\<alpha> [simp]: "FL_valid_Tree\<^sub>\<alpha> P (Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha>) \<longleftrightarrow> (\<exists>\<alpha>' t\<^sub>\<alpha>' P'. Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha> = Act\<^sub>\<alpha> f \<alpha>' t\<^sub>\<alpha>' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree\<^sub>\<alpha> P' t\<^sub>\<alpha>')"
  proof
    assume "FL_valid_Tree\<^sub>\<alpha> P (Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha>)"
    moreover have "Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha> = abs_Tree\<^sub>\<alpha> (tAct f \<alpha> (rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha>))"
      by (metis Act\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>_abs_rep)
    ultimately show "\<exists>\<alpha>' t\<^sub>\<alpha>' P'. Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha> = Act\<^sub>\<alpha> f \<alpha>' t\<^sub>\<alpha>' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree\<^sub>\<alpha> P' t\<^sub>\<alpha>'"
      by (metis Act\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>.abs_eq_iff FL_valid_Tree.simps(4) FL_valid_Tree\<^sub>\<alpha>.abs_eq)
  next
    assume "\<exists>\<alpha>' t\<^sub>\<alpha>' P'. Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha> = Act\<^sub>\<alpha> f \<alpha>' t\<^sub>\<alpha>' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> FL_valid_Tree\<^sub>\<alpha> P' t\<^sub>\<alpha>'"
    moreover have "\<And>\<alpha>' t\<^sub>\<alpha>'. Act\<^sub>\<alpha> f \<alpha>' t\<^sub>\<alpha>' = abs_Tree\<^sub>\<alpha> (tAct f \<alpha>' (rep_Tree\<^sub>\<alpha> t\<^sub>\<alpha>'))"
      by (metis Act\<^sub>\<alpha>.abs_eq Tree\<^sub>\<alpha>_abs_rep)
    ultimately show "FL_valid_Tree\<^sub>\<alpha> P (Act\<^sub>\<alpha> f \<alpha> t\<^sub>\<alpha>)"
      by (metis Tree\<^sub>\<alpha>.abs_eq_iff FL_valid_Tree.simps(4) FL_valid_Tree\<^sub>\<alpha>.abs_eq FL_valid_Tree\<^sub>\<alpha>.rep_eq)
  qed

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

  lift_definition FL_valid :: "'state \<Rightarrow> ('idx,'pred,'act,'effect) formula \<Rightarrow> bool" (infix "\<Turnstile>" 70) is
    FL_valid_Tree\<^sub>\<alpha>
  .

  lemma FL_valid_eqvt [eqvt]:
    assumes "P \<Turnstile> x" shows "(p \<bullet> P) \<Turnstile> (p \<bullet> x)"
  using assms by transfer (metis FL_valid_Tree\<^sub>\<alpha>_eqvt)

  lemma FL_valid_Conj [simp]:
    assumes "finite (supp xset)"
    shows "P \<Turnstile> Conj xset \<longleftrightarrow> (\<forall>x\<in>set_bset xset. P \<Turnstile> x)"
  using assms by (simp add: FL_valid_def Conj_def map_bset.rep_eq)

  lemma FL_valid_Not [simp]: "P \<Turnstile> Not x \<longleftrightarrow> \<not> P \<Turnstile> x"
  by transfer simp

  lemma FL_valid_Pred [simp]: "P \<Turnstile> Pred f \<phi> \<longleftrightarrow> \<langle>f\<rangle>P \<turnstile> \<phi>"
  by transfer simp

  lemma FL_valid_Act: "P \<Turnstile> Act f \<alpha> x \<longleftrightarrow> (\<exists>\<alpha>' x' P'. Act f \<alpha> x = Act f \<alpha>' x' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> P' \<Turnstile> x')"
  proof
    assume "P \<Turnstile> Act f \<alpha> x"
    moreover have "Rep_formula (Abs_formula (Act\<^sub>\<alpha> f \<alpha> (Rep_formula x))) = Act\<^sub>\<alpha> f \<alpha> (Rep_formula x)"
      by (metis Act.rep_eq Rep_formula_inverse)
    ultimately show "\<exists>\<alpha>' x' P'. Act f \<alpha> x = Act f \<alpha>' x' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> P' \<Turnstile> x'"
      by (auto simp add: FL_valid_def Act_def) (metis Abs_formula_inverse Rep_formula' hereditarily_fs_alpha_renaming)
  next
    assume "\<exists>\<alpha>' x' P'. Act f \<alpha> x = Act f \<alpha>' x' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> P' \<Turnstile> x'"
    then show "P \<Turnstile> Act f \<alpha> x"
      by (metis Act.rep_eq FL_valid.rep_eq FL_valid_Tree\<^sub>\<alpha>_Act\<^sub>\<alpha>)
  qed

  text \<open>The binding names in the alpha-variant that witnesses validity may be chosen fresh for any
  finitely supported context.\<close>

  lemma FL_valid_Act_strong:
    assumes "finite (supp X)"
    shows "P \<Turnstile> Act f \<alpha> x \<longleftrightarrow> (\<exists>\<alpha>' x' P'. Act f \<alpha> x = Act f \<alpha>' x' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> P' \<Turnstile> x' \<and> bn \<alpha>' \<sharp>* X)"
  proof
    assume "P \<Turnstile> Act f \<alpha> x"
    then obtain \<alpha>' x' P' where eq: "Act f \<alpha> x = Act f \<alpha>' x'" and trans: "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle>" and valid: "P' \<Turnstile> x'"
      by (metis FL_valid_Act)

    have "finite (bn \<alpha>')"
      by (fact bn_finite)
    moreover note \<open>finite (supp X)\<close>
    moreover have "finite (supp (supp x' - bn \<alpha>', supp \<alpha>' - bn \<alpha>', \<langle>\<alpha>',P'\<rangle>))"
      by (simp add: supp_Pair finite_sets_supp finite_supp)
    moreover have "bn \<alpha>' \<sharp>* (supp x' - bn \<alpha>', supp \<alpha>' - bn \<alpha>', \<langle>\<alpha>',P'\<rangle>)"
      by (simp add: atom_fresh_star_disjoint finite_supp fresh_star_Pair)
    ultimately obtain p where fresh_X: "(p \<bullet> bn \<alpha>') \<sharp>* X" and fresh_p: "supp (supp x' - bn \<alpha>', supp \<alpha>' - bn \<alpha>', \<langle>\<alpha>',P'\<rangle>) \<sharp>* p"
      by (metis at_set_avoiding2)

    from fresh_p have "supp (supp x' - bn \<alpha>') \<sharp>* p" and "supp (supp \<alpha>' - bn \<alpha>') \<sharp>* p" and 1: "supp \<langle>\<alpha>',P'\<rangle> \<sharp>* p"
      by (meson fresh_Pair fresh_def fresh_star_def)+
    then have 2: "(supp x' - bn \<alpha>') \<sharp>* p" and 3: "(supp \<alpha>' - bn \<alpha>') \<sharp>* p"
      by (simp add: finite_supp supp_finite_atom_set)+
    moreover from 2 have "supp (p \<bullet> x') - bn (p \<bullet> \<alpha>') = supp x' - bn \<alpha>'"
      by (metis Diff_eqvt atom_set_perm_eq bn_eqvt supp_eqvt)
    moreover from 3 have "supp (p \<bullet> \<alpha>') - bn (p \<bullet> \<alpha>') = supp \<alpha>' - bn \<alpha>'"
      by (metis (no_types, hide_lams) Diff_eqvt atom_set_perm_eq bn_eqvt supp_eqvt)
    ultimately have "Act f \<alpha>' x' = Act f (p \<bullet> \<alpha>') (p \<bullet> x')"
      by (auto simp add: Act_eq_iff_perm)

    moreover from 1 have "\<langle>p \<bullet> \<alpha>', p \<bullet> P'\<rangle> = \<langle>\<alpha>',P'\<rangle>"
      by (metis abs_residual_pair_eqvt supp_perm_eq)

    ultimately show "\<exists>\<alpha>' x' P'. Act f \<alpha> x = Act f \<alpha>' x' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> P' \<Turnstile> x' \<and> bn \<alpha>' \<sharp>* X"
      using eq and trans and valid and fresh_X by (metis bn_eqvt FL_valid_eqvt)
  next
    assume "\<exists>\<alpha>' x' P'. Act f \<alpha> x = Act f \<alpha>' x' \<and> \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle> \<and> P' \<Turnstile> x' \<and> bn \<alpha>' \<sharp>* X"
    then show "P \<Turnstile> Act f \<alpha> x" by (metis FL_valid_Act)
  qed

  lemma FL_valid_Act_fresh:
    assumes "bn \<alpha> \<sharp>* \<langle>f\<rangle>P"
    shows "P \<Turnstile> Act f \<alpha> x \<longleftrightarrow> (\<exists>P'. \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<and> P' \<Turnstile> x)"
  proof
    assume "P \<Turnstile> Act f \<alpha> x"

    moreover have "finite (supp (\<langle>f\<rangle>P))"
      by (fact finite_supp)
    ultimately obtain \<alpha>' x' P' where
      eq: "Act f \<alpha> x = Act f \<alpha>' x'" and trans: "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>',P'\<rangle>" and valid: "P' \<Turnstile> x'" and fresh: "bn \<alpha>' \<sharp>* \<langle>f\<rangle>P"
      by (metis FL_valid_Act_strong)

    from eq obtain p where p_\<alpha>: "\<alpha>' = p \<bullet> \<alpha>" and p_x: "x' = p \<bullet> x" and supp_p: "supp p \<subseteq> bn \<alpha> \<union> p \<bullet> bn \<alpha>"
      by (metis Act_eq_iff_perm_renaming)

    from assms and fresh have "(bn \<alpha> \<union> p \<bullet> bn \<alpha>) \<sharp>* \<langle>f\<rangle>P"
      using p_\<alpha> by (metis bn_eqvt fresh_star_Un)
    then have "supp p \<sharp>* \<langle>f\<rangle>P"
      using supp_p by (metis fresh_star_def subset_eq)
    then have p_P: "-p \<bullet> \<langle>f\<rangle>P = \<langle>f\<rangle>P"
      by (metis perm_supp_eq supp_minus_perm)

    from trans have "\<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,-p \<bullet> P'\<rangle>"
      using p_P p_\<alpha> by (metis permute_minus_cancel(1) transition_eqvt')
    moreover from valid have "-p \<bullet> P' \<Turnstile> x"
      using p_x by (metis permute_minus_cancel(1) FL_valid_eqvt)
    ultimately show "\<exists>P'. \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<and> P' \<Turnstile> x"
      by meson
  next
    assume "\<exists>P'. \<langle>f\<rangle>P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<and> P' \<Turnstile> x"
    then show "P \<Turnstile> Act f \<alpha> x"
      by (metis FL_valid_Act)
  qed

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory SimpStrategy
imports Main
begin

text \<open>
Support for defining alternative simplifier strategies for some parts of terms
or some premises of rewrite rules. The "name" parameter to the simp_strategy
constant is used to identify which simplification strategy should be used on
this term. Note that, although names have type nat, it is safe for them to all
be defined as 0. The important thing is that the simplifier doesn't know they're
equal.
\<close>

definition
  simp_strategy :: "nat \<Rightarrow> ('a :: {}) \<Rightarrow> 'a"
where
  "simp_strategy name x \<equiv> x"

text \<open>
This congruence rule forbids the simplifier from simplifying the arguments of
simp_strategy normally.
\<close>

lemma simp_strategy_cong[cong]:
  "simp_strategy name x = simp_strategy name x"
  by simp

text \<open>
This strategy, or rather lack thereof, can be used to forbid simplification.
\<close>

definition
  NoSimp :: nat
where "NoSimp = 0"

text \<open>
This strategy indicates that a boolean subterm should be simplified only by
using explicit assumptions of the simpset.
\<close>

definition
  ByAssum :: nat
where "ByAssum = 0"

lemma Eq_TrueI_ByAssum:
  "P \<Longrightarrow> simp_strategy ByAssum P \<equiv> True"
  by (simp add: simp_strategy_def)

simproc_setup simp_strategy_ByAssum ("simp_strategy ByAssum b") =
  \<open>K (fn ss => fn ct => let
      val b = Thm.dest_arg ct
      val t = Thm.instantiate (TVars.empty, Vars.make [((("P",0),@{typ bool}), b)])
        @{thm Eq_TrueI_ByAssum}
      val prems = Raw_Simplifier.prems_of ss
    in get_first (try (fn p => p RS t)) prems end)\<close>

lemma ByAssum:
  "simp_strategy ByAssum P \<Longrightarrow> P"
  by (simp add: simp_strategy_def)

lemma simp_ByAssum_test:
  "P \<Longrightarrow> simp_strategy ByAssum P"
  by simp

text \<open>
Generic framework for instantiating a simproc which simplifies within a
simp_strategy with a given simpset.

The boolean determines whether simp_strategy Name True should be rewritten
to True.
\<close>

lemma simp_strategy_Eq_True:
  "simp_strategy name True \<equiv> True"
  by (simp add: simp_strategy_def)

ML \<open>
fun simp_strategy_True_conv ct = case Thm.term_of ct of
    (Const (@{const_name simp_strategy}, _) $ _ $ @{term True})
      => Thm.instantiate (TVars.empty, Vars.make [((("name",0), @{typ nat}), Thm.dest_arg1 ct)])
          @{thm simp_strategy_Eq_True}
  | _ => Conv.all_conv ct

fun new_simp_strategy thy (name : term) ss rewr_True =
let
  val ctxt = Proof_Context.init_global thy;
  val ss = Simplifier.make_simproc ctxt ("simp_strategy_" ^ fst (dest_Const name))
    {lhss = [@{term simp_strategy} $ name $ @{term x}],
     proc = (fn _ => fn ctxt' => fn ct =>
        ct
        |> (Conv.arg_conv (Simplifier.rewrite (put_simpset ss ctxt'))
          then_conv (if rewr_True then simp_strategy_True_conv
                      else Conv.all_conv))
        |> (fn c => if Thm.is_reflexive c then NONE else SOME c))
     }
in
  ss
end
\<close>

end


(*  Title:      JinjaThreads/Compiler/JJ1WellForm.thy
    Author:     Andreas Lochbihler

    Reminiscent of the Jinja theory Compiler/Correctness1
*)

header {* \isaheader{Preservation of well-formedness from source code to intermediate language} *}

theory JJ1WellForm imports
  "../J/JWellForm"
  "J1WellForm"
  "Compiler1"
begin

text{* The compiler preserves well-formedness. Is less trivial than it
may appear. We start with two simple properties: preservation of
well-typedness *}

lemma assumes wf: "wf_prog wfmd P"
  shows compE1_pres_wt: "\<lbrakk> P,[Vs[\<mapsto>]Ts] \<turnstile> e :: U; size Ts = size Vs \<rbrakk> \<Longrightarrow> compP f P,Ts \<turnstile>1 compE1 Vs e :: U"
  and compEs1_pres_wt: "\<lbrakk> P,[Vs[\<mapsto>]Ts] \<turnstile> es [::] Us; size Ts = size Vs \<rbrakk> \<Longrightarrow> compP f P,Ts \<turnstile>1 compEs1 Vs es [::] Us"
proof(induct Vs e and Vs es arbitrary: Ts U and Ts Us rule: compE1_compEs1_induct)
  case Var thus ?case by(fastforce simp:map_upds_apply_eq_Some split:split_if_asm)
next
  case LAss thus ?case by(fastforce simp:map_upds_apply_eq_Some split:split_if_asm)
next
  case Call thus ?case
    by(fastforce dest: sees_method_compP[where f = f])
next
  case Block thus ?case by(fastforce simp:nth_append)
next
  case (Synchronized Vs V exp1 exp2 Ts U)
  note IH1 = `\<And>Ts U. \<lbrakk>P,[Vs [\<mapsto>] Ts] \<turnstile> exp1 :: U;
    length Ts = length Vs\<rbrakk> \<Longrightarrow> compP f P,Ts \<turnstile>1 compE1 Vs exp1 :: U`
  note IH2 = `\<And>Ts U. \<lbrakk>P,[(Vs @ [fresh_var Vs]) [\<mapsto>] Ts] \<turnstile> exp2 :: U; length Ts = length (Vs @ [fresh_var Vs])\<rbrakk>
      \<Longrightarrow> compP f P,Ts \<turnstile>1 compE1 (Vs @ [fresh_var Vs]) exp2 :: U`
  note length = `length Ts = length Vs`
  from `P,[Vs [\<mapsto>] Ts] \<turnstile> sync\<^bsub>V\<^esub> (exp1) exp2 :: U`
  obtain U1 where wt1: "P,[Vs [\<mapsto>] Ts] \<turnstile> exp1 :: U1"
    and wt2: "P,[Vs [\<mapsto>] Ts] \<turnstile> exp2 :: U"
    and U1: "is_refT U1" "U1 \<noteq> NT"
    by(auto)
  from IH1[of Ts U1] wt1 length
  have wt1': "compP f P,Ts \<turnstile>1 compE1 Vs exp1 :: U1" by simp
  from length fresh_var_fresh[of Vs] have "[Vs [\<mapsto>] Ts] \<subseteq>\<^sub>m [Vs @ [fresh_var Vs] [\<mapsto>] Ts @ [Class Object]]"
    by(auto simp add: map_le_def fun_upd_def)
  with wt2 have "P,[Vs@[fresh_var Vs] [\<mapsto>] Ts @ [Class Object]] \<turnstile> exp2 :: U"
    by(rule wt_env_mono)
  with length IH2[of "Ts @ [Class Object]" U]
  have "compP f P,Ts @ [Class Object] \<turnstile>1 compE1 (Vs @ [fresh_var Vs]) exp2 :: U" by simp
  with wt1' U1 show ?case by(auto)
next
  case (TryCatch Vs exp1 C V exp2)
  note IH1 = `\<And>Ts U. \<lbrakk>P,[Vs [\<mapsto>] Ts] \<turnstile> exp1 :: U; length Ts = length Vs\<rbrakk> \<Longrightarrow> compP f P,Ts \<turnstile>1 compE1 Vs exp1 :: U`
  note IH2 = `\<And>Ts U. \<lbrakk>P,[(Vs @ [V]) [\<mapsto>] Ts] \<turnstile> exp2 :: U; length Ts = length (Vs @ [V])\<rbrakk> \<Longrightarrow> compP f P,Ts \<turnstile>1 compE1 (Vs @ [V]) exp2 :: U`
  note length = `length Ts = length Vs`
  with `P,[Vs [\<mapsto>] Ts] \<turnstile> try exp1 catch(C V) exp2 :: U`
  have wt1: "P,[Vs [\<mapsto>] Ts] \<turnstile> exp1 :: U" and wt2: "P,[(Vs@[V]) [\<mapsto>] (Ts@[Class C])] \<turnstile> exp2 :: U"
    and C: "P \<turnstile> C \<preceq>\<^sup>* Throwable" by(auto simp add: nth_append)
  from wf C have "is_class P C" by(rule is_class_sub_Throwable)
  with IH1[OF wt1 length] IH2[OF wt2] length show ?case by(auto)
qed(fastforce)+

text{*\noindent and the correct block numbering: *}

text{* The main complication is preservation of definite assignment
@{term"\<D>"}. *}

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows A_compE1_None[simp]: "\ e = None \<Longrightarrow> \ (compE1 Vs e) = None"
  and As_compEs1_None: "\s es = None \<Longrightarrow> \s (compEs1 Vs es) = None"
apply(induct Vs e and Vs es rule: compE1_compEs1_induct)
apply(auto simp:hyperset_defs)
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows A_compE1: "\<lbrakk> \ e = \<lfloor>A\<rfloor>; fv e \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \ (compE1 Vs e) = \<lfloor>index Vs ` A\<rfloor>"
  and As_compEs1: "\<lbrakk> \s es = \<lfloor>A\<rfloor>; fvs es \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \s (compEs1 Vs es) = \<lfloor>index Vs ` A\<rfloor>"
proof(induct Vs e and Vs es arbitrary: A and A rule: compE1_compEs1_induct)
  case (Block Vs V' T vo e)
  hence "fv e \<subseteq> set (Vs@[V'])" by fastforce
  moreover obtain B where "\ e = \<lfloor>B\<rfloor>"
    using Block.prems by(simp add: hyperset_defs)
  moreover from calculation have "B \<subseteq> set (Vs@[V'])" by(auto dest!:A_fv)
  ultimately show ?case using Block
    by(auto simp add: hyperset_defs image_index)
next
  case (Synchronized Vs V exp1 exp2 A)
  have IH1: "\<And>A. \<lbrakk>\ exp1 = \<lfloor>A\<rfloor>; fv exp1 \<subseteq> set Vs\<rbrakk> \<Longrightarrow> \ (compE1 Vs exp1) = \<lfloor>index Vs ` A\<rfloor>" by fact
  have IH2: "\<And>A. \<lbrakk>\ exp2 = \<lfloor>A\<rfloor>; fv exp2 \<subseteq> set (Vs @ [fresh_var Vs])\<rbrakk> \<Longrightarrow> \ (compE1 (Vs @ [fresh_var Vs]) exp2) = \<lfloor>index (Vs @ [fresh_var Vs]) ` A\<rfloor>" by fact
  from `fv (sync\<^bsub>V\<^esub> (exp1) exp2) \<subseteq> set Vs`
  have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set Vs" by auto
  from `\<A> (sync\<^bsub>V\<^esub> (exp1) exp2) = \<lfloor>A\<rfloor>` have A: "\ exp1 \<squnion> \ exp2 = \<lfloor>A\<rfloor>" by(simp)
  then obtain A1 A2 where A1: "\ exp1 = \<lfloor>A1\<rfloor>" and A2: "\ exp2 = \<lfloor>A2\<rfloor>" by(auto simp add: hyperset_defs)
  from A2 fv2 have "A2 \<subseteq> set Vs" by(auto dest: A_fv del: subsetI)
  with fresh_var_fresh[of Vs] have "(fresh_var Vs) \<notin> A2" by(auto)
  from fv2 have "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  with IH2[OF A2] have "\ (compE1 (Vs @ [fresh_var Vs]) exp2) = \<lfloor>index (Vs @ [fresh_var Vs]) ` A2\<rfloor>" by(auto)
  with IH1[OF A1 fv1] A[symmetric] `A2 \<subseteq> set Vs` `(fresh_var Vs) \<notin> A2` A1 A2 show ?case
    by(auto simp add: image_index)
next
  case (InSynchronized Vs V a exp A)
  have IH: "\<And>A. \<lbrakk>\ exp = \<lfloor>A\<rfloor>; fv exp \<subseteq> set (Vs @ [fresh_var Vs])\<rbrakk> \<Longrightarrow> \ (compE1 (Vs @ [fresh_var Vs]) exp) = \<lfloor>index (Vs @ [fresh_var Vs]) ` A\<rfloor>" by fact
  from `\<A> (insync\<^bsub>V\<^esub> (a) exp) = \<lfloor>A\<rfloor>` have A: "\ exp = \<lfloor>A\<rfloor>" by simp
  from `fv (insync\<^bsub>V\<^esub> (a) exp) \<subseteq> set Vs` have fv: "fv exp \<subseteq> set Vs" by simp
  from A fv have "A \<subseteq> set Vs" by(auto dest: A_fv del: subsetI)
  with fresh_var_fresh[of Vs] have "(fresh_var Vs) \<notin> A" by(auto)
  from fv IH[OF A] have " \ (compE1 (Vs @ [fresh_var Vs]) exp) = \<lfloor>index (Vs @ [fresh_var Vs]) ` A\<rfloor>" by simp
  with `A \<subseteq> set Vs` `(fresh_var Vs) \<notin> A` show ?case by(simp add: image_index)
next
  case (TryCatch Vs e1 C V' e2)
  hence fve2: "fv e2 \<subseteq> set (Vs@[V'])" by auto
  show ?case
  proof (cases "\ e1")
    assume A1: "\ e1 = None"
    then obtain A2 where A2: "\ e2 = \<lfloor>A2\<rfloor>" using TryCatch
      by(simp add:hyperset_defs)
    hence "A2 \<subseteq> set (Vs@[V'])" using TryCatch.prems A_fv[OF A2] by simp blast
    thus ?thesis using TryCatch fve2 A1 A2
      by(auto simp add:hyperset_defs image_index)
  next
    fix A1 assume A1: "\ e1 =  \<lfloor>A1\<rfloor>"
    show ?thesis
    proof (cases  "\ e2")
      assume A2: "\ e2 = None"
      then show ?case using TryCatch A1 by(simp add:hyperset_defs)
    next
      fix A2 assume A2: "\ e2 = \<lfloor>A2\<rfloor>"
      have "A1 \<subseteq> set Vs" using TryCatch.prems A_fv[OF A1] by simp blast
      moreover
      have "A2 \<subseteq> set (Vs@[V'])" using TryCatch.prems A_fv[OF A2] by simp blast
      ultimately show ?thesis using TryCatch A1 A2
        by(fastforce simp add: hyperset_defs image_index
          Diff_subset_conv inj_on_image_Int[OF inj_on_index])
    qed
  qed
next
  case (Cond Vs e e1 e2)
  { assume "\ e = None \<or> \ e1 = None \<or> \ e2 = None"
    hence ?case using Cond by(auto simp add:hyperset_defs image_Un)
  }
  moreover
  { fix A A1 A2
    assume "\ e = \<lfloor>A\<rfloor>" and A1: "\ e1 = \<lfloor>A1\<rfloor>" and A2: "\ e2 = \<lfloor>A2\<rfloor>"
    moreover
    have "A1 \<subseteq> set Vs" using Cond.prems A_fv[OF A1] by simp blast
    moreover
    have "A2 \<subseteq> set Vs" using Cond.prems A_fv[OF A2] by simp blast
    ultimately have ?case using Cond
      by(auto simp add:hyperset_defs image_Un
          inj_on_image_Int[OF inj_on_index])
  }
  ultimately show ?case by fastforce
qed (auto simp add:hyperset_defs)

lemma fixes e :: "('a, 'b, 'addr) exp" and es :: "('a, 'b, 'addr) exp list"
  shows D_None [iff]: "\<D> e None"
  and Ds_None [iff]: "\<D>s es None"
by(induct e and es rule: \<D>.induct \<D>s.induct)(simp_all)

declare Un_ac [simp]

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows D_index_compE1: "\<lbrakk> A \<subseteq> set Vs; fv e \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \<D> e \<lfloor>A\<rfloor> \<Longrightarrow> \<D> (compE1 Vs e) \<lfloor>index Vs ` A\<rfloor>"
  and Ds_index_compEs1: "\<lbrakk> A \<subseteq> set Vs; fvs es \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \<D>s es \<lfloor>A\<rfloor> \<Longrightarrow> \<D>s (compEs1 Vs es) \<lfloor>index Vs ` A\<rfloor>"
proof(induct e and es arbitrary: A Vs and A Vs rule: \<D>.induct \<D>s.induct)
  case (BinOp e1 bop e2)
  hence IH1: "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e1")
    case None thus ?thesis using BinOp by simp
  next
    case (Some A1)
    have indexA1: "\ (compE1 Vs e1) = \<lfloor>index Vs ` A1\<rfloor>"
      using A_compE1[OF Some] BinOp.prems  by auto
    have "A \<union> A1 \<subseteq> set Vs" using BinOp.prems A_fv[OF Some] by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` (A1 \<union> A)\<rfloor>" using BinOp Some by(auto)
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` A1 \<union> index Vs ` A\<rfloor>"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (AAcc a i A Vs)
  have IH1: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv a \<subseteq> set Vs; \<D> a \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs a) \<lfloor>index Vs ` A\<rfloor>" by fact
  have IH2: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv i \<subseteq> set Vs; \<D> i \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs i) \<lfloor>index Vs ` A\<rfloor>" by fact
  from `\<D> (a\<lfloor>i\<rceil>) \<lfloor>A\<rfloor>` have D1: "\<D> a \<lfloor>A\<rfloor>" and D2: "\<D> i (\<lfloor>A\<rfloor> \<squnion> \ a)" by auto
  from `fv (a\<lfloor>i\<rceil>) \<subseteq> set Vs` have fv1: "fv a \<subseteq> set Vs" and fv2: "fv i \<subseteq> set Vs" by auto
  show ?case
  proof(cases "\ a")
    case None thus ?thesis using AAcc by simp
  next
    case (Some A1)
    with fv1 have "\ (compE1 Vs a) = \<lfloor>index Vs ` A1\<rfloor>" by-(rule A_compE1)
    moreover from A_fv[OF Some] fv1 `A \<subseteq> set Vs` have "A1 \<union> A \<subseteq> set Vs" by auto
    from IH2[OF this fv2] Some D2 have "\<D> (compE1 Vs i) \<lfloor>index Vs ` A1 \<union> index Vs ` A\<rfloor>"
      by(simp add: image_Un)
    ultimately show ?thesis using IH1[OF `A \<subseteq> set Vs` fv1 D1] by(simp)
  qed
next
  case (AAss a i e A Vs)
  have IH1: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv a \<subseteq> set Vs; \<D> a \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs a) \<lfloor>index Vs ` A\<rfloor>" by fact
  have IH2: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv i \<subseteq> set Vs; \<D> i \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs i) \<lfloor>index Vs ` A\<rfloor>" by fact
  have IH3: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv e \<subseteq> set Vs; \<D> e \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs e) \<lfloor>index Vs ` A\<rfloor>" by fact
  from `\<D> (a\<lfloor>i\<rceil>:=e) \<lfloor>A\<rfloor>` have D1: "\<D> a \<lfloor>A\<rfloor>" and D2: "\<D> i (\<lfloor>A\<rfloor> \<squnion> \ a)"
    and D3: "\<D> e (\<lfloor>A\<rfloor> \<squnion> \ a \<squnion> \ i)" by auto
  from `fv (a\<lfloor>i\<rceil> := e) \<subseteq> set Vs`
  have fv1: "fv a \<subseteq> set Vs" and fv2: "fv i \<subseteq> set Vs" and fv3: "fv e \<subseteq> set Vs" by auto
  show ?case
  proof(cases "\ a")
    case None thus ?thesis using AAss by simp
  next
    case (Some A1)
    with fv1 have A1: "\ (compE1 Vs a) = \<lfloor>index Vs ` A1\<rfloor>" by-(rule A_compE1)
    from A_fv[OF Some] fv1 `A \<subseteq> set Vs` have "A1 \<union> A \<subseteq> set Vs" by auto
    from IH2[OF this fv2] Some D2 have D2': "\<D> (compE1 Vs i) \<lfloor>index Vs ` A1 \<union> index Vs ` A\<rfloor>"
      by(simp add: image_Un)
    show ?thesis
    proof(cases "\ i")
      case None thus ?thesis using AAss D2' Some A1 by simp
    next
      case (Some A2)
      with fv2 have A2: "\ (compE1 Vs i) = \<lfloor>index Vs ` A2\<rfloor>" by-(rule A_compE1)
      moreover from A_fv[OF Some] fv2 `A1 \<union> A \<subseteq> set Vs` have "A1 \<union> A \<union> A2 \<subseteq> set Vs" by auto
      from IH3[OF this fv3] Some `\<A> a = \<lfloor>A1\<rfloor>` D3
      have "\<D> (compE1 Vs e) \<lfloor>index Vs ` A1 \<union> index Vs ` A \<union> index Vs ` A2\<rfloor>"
        by(simp add: image_Un Un_commute Un_assoc)
      ultimately show ?thesis using IH1[OF `A \<subseteq> set Vs` fv1 D1] D2' A1 A2 by(simp)
    qed
  qed
next
  case (FAss e1 F D e2)
  hence IH1: "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e1")
    case None thus ?thesis using FAss by simp
  next
    case (Some A1)
    have indexA1: "\ (compE1 Vs e1) = \<lfloor>index Vs ` A1\<rfloor>"
      using A_compE1[OF Some] FAss.prems  by auto
    have "A \<union> A1 \<subseteq> set Vs" using FAss.prems A_fv[OF Some] by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` (A \<union> A1)\<rfloor>" using FAss Some by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` A \<union> index Vs ` A1\<rfloor>"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Call e1 M es)
  hence IH1: "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e1")
    case None thus ?thesis using Call by simp
  next
    case (Some A1)
    have indexA1: "\ (compE1 Vs e1) = \<lfloor>index Vs ` A1\<rfloor>"
      using A_compE1[OF Some] Call.prems  by auto
    have "A \<union> A1 \<subseteq> set Vs" using Call.prems A_fv[OF Some] by auto
    hence "\<D>s (compEs1 Vs es) \<lfloor>index Vs ` (A \<union> A1)\<rfloor>" using Call Some by auto
    hence "\<D>s (compEs1 Vs es) \<lfloor>index Vs ` A \<union> index Vs ` A1\<rfloor>"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Synchronized V exp1 exp2 A Vs)
  have IH1: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv exp1 \<subseteq> set Vs; \<D> exp1 \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs exp1) \<lfloor>index Vs ` A\<rfloor>" by fact
  have IH2: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv exp2 \<subseteq> set Vs; \<D> exp2 \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs exp2) \<lfloor>index Vs ` A\<rfloor>" by fact
  from `\<D> (sync\<^bsub>V\<^esub> (exp1) exp2) \<lfloor>A\<rfloor>` have D1: "\<D> exp1 \<lfloor>A\<rfloor>" and D2: "\<D> exp2 (\<lfloor>A\<rfloor> \<squnion> \ exp1)" by auto
  from `fv (sync\<^bsub>V\<^esub> (exp1) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs" and fv2: "fv exp2 \<subseteq> set Vs" by auto
  show ?case
  proof(cases "\ exp1")
    case None thus ?thesis using Synchronized by(simp)
  next
    case (Some A1)
    with fv1 have A1: "\ (compE1 Vs exp1) = \<lfloor>index Vs ` A1\<rfloor>" by-(rule A_compE1)
    from A_fv[OF Some] fv1 `A \<subseteq> set Vs` have "A \<union> A1 \<subseteq> set Vs" by auto
    hence "A \<union> A1 \<subseteq> set (Vs @ [fresh_var Vs])" by simp
    from IH2[OF this] fv2 Some D2
    have D2': "\<D> (compE1 (Vs @ [fresh_var Vs]) exp2) \<lfloor>index (Vs @ [fresh_var Vs]) ` (A \<union> A1)\<rfloor>"
      by(simp)
    moreover from fresh_var_fresh[of Vs] `A \<union> A1 \<subseteq> set Vs`
    have "(fresh_var Vs) \<notin> A \<union> A1" by auto
    with `A \<union> A1 \<subseteq> set Vs`
    have "index (Vs @ [fresh_var Vs]) ` (A \<union> A1) = index Vs ` A \<union> index Vs ` A1"
      by(simp add: image_index image_Un)
    ultimately show ?thesis using IH1[OF `A \<subseteq> set Vs` fv1 D1] D2' A1 by(simp)
  qed
next
  case (InSynchronized V a e A Vs)
  have IH: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv e \<subseteq> set Vs; \<D> e \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs e) \<lfloor>index Vs ` A\<rfloor>" by fact
  from IH[of A "Vs @ [fresh_var Vs]"] `A \<subseteq> set Vs` `fv (insync\<^bsub>V\<^esub> (a) e) \<subseteq> set Vs` `\<D> (insync\<^bsub>V\<^esub> (a) e) \<lfloor>A\<rfloor>`
  have "\<D> (compE1 (Vs @ [fresh_var Vs]) e) \<lfloor>index (Vs @ [fresh_var Vs]) ` A\<rfloor>" by(auto)
  moreover from fresh_var_fresh[of Vs] `A \<subseteq> set Vs` have "(fresh_var Vs) \<notin> A" by auto
  with `A \<subseteq> set Vs` have "index (Vs @ [fresh_var Vs]) ` A = index Vs ` A" by(simp add: image_index)
  ultimately show ?case by(simp)
next
  case (TryCatch e1 C V e2)
  have "\<lbrakk> A\<union>{V} \<subseteq> set(Vs@[V]); fv e2 \<subseteq> set(Vs@[V]); \<D> e2 \<lfloor>A\<union>{V}\<rfloor>\<rbrakk> \<Longrightarrow>
        \<D> (compE1 (Vs@[V]) e2) \<lfloor>index (Vs@[V]) ` (A\<union>{V})\<rfloor>" by fact
  hence "\<D> (compE1 (Vs@[V]) e2) \<lfloor>index (Vs@[V]) ` (A\<union>{V})\<rfloor>"
    using TryCatch.prems by(simp add:Diff_subset_conv)
  moreover have "index (Vs@[V]) ` A \<subseteq> index Vs ` A \<union> {size Vs}"
    using TryCatch.prems by(auto simp add: image_index split:split_if_asm)
  ultimately show ?case using TryCatch by(auto simp:hyperset_defs elim!:D_mono')
next
  case (Seq e1 e2)
  hence IH1: "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e1")
    case None thus ?thesis using Seq by simp
  next
    case (Some A1)
    have indexA1: "\ (compE1 Vs e1) = \<lfloor>index Vs ` A1\<rfloor>"
      using A_compE1[OF Some] Seq.prems  by auto
    have "A \<union> A1 \<subseteq> set Vs" using Seq.prems A_fv[OF Some] by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` (A \<union> A1)\<rfloor>" using Seq Some by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` A \<union> index Vs ` A1\<rfloor>"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Cond e e1 e2)
  hence IH1: "\<D> (compE1 Vs e) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e")
    case None thus ?thesis using Cond by simp
  next
    case (Some B)
    have indexB: "\ (compE1 Vs e) = \<lfloor>index Vs ` B\<rfloor>"
      using A_compE1[OF Some] Cond.prems  by auto
    have "A \<union> B \<subseteq> set Vs" using Cond.prems A_fv[OF Some] by auto
    hence "\<D> (compE1 Vs e1) \<lfloor>index Vs ` (A \<union> B)\<rfloor>"
      and "\<D> (compE1 Vs e2) \<lfloor>index Vs ` (A \<union> B)\<rfloor>"
      using Cond Some by auto
    hence "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A \<union> index Vs ` B\<rfloor>"
      and "\<D> (compE1 Vs e2) \<lfloor>index Vs ` A \<union> index Vs ` B\<rfloor>"
      by(simp add: image_Un)+
    thus ?thesis using IH1 indexB by auto
  qed
next
  case (While e1 e2)
  hence IH1: "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e1")
    case None thus ?thesis using While by simp
  next
    case (Some A1)
    have indexA1: "\ (compE1 Vs e1) = \<lfloor>index Vs ` A1\<rfloor>"
      using A_compE1[OF Some] While.prems  by auto
    have "A \<union> A1 \<subseteq> set Vs" using While.prems A_fv[OF Some] by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` (A \<union> A1)\<rfloor>" using While Some by auto
    hence "\<D> (compE1 Vs e2) \<lfloor>index Vs ` A \<union> index Vs ` A1\<rfloor>"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
next
  case (Block V T vo e A Vs)
  have IH: "\<And>A Vs. \<lbrakk>A \<subseteq> set Vs; fv e \<subseteq> set Vs; \<D> e \<lfloor>A\<rfloor>\<rbrakk> \<Longrightarrow> \<D> (compE1 Vs e) \<lfloor>index Vs ` A\<rfloor>" by fact
  from `fv {V:T=vo; e} \<subseteq> set Vs` have fv: "fv e \<subseteq> set (Vs @ [V])" by auto
  show ?case
  proof(cases vo)
    case None
    with `\<D> {V:T=vo; e} \<lfloor>A\<rfloor>` have D: "\<D> e \<lfloor>A - {V}\<rfloor>" by(auto)
    from `A \<subseteq> set Vs` have "A - {V} \<subseteq> set (Vs @ [V])" by auto
    from IH[OF this fv D] have "\<D> (compE1 (Vs @ [V]) e) \<lfloor>index (Vs @ [V]) ` (A - {V})\<rfloor>" .
    moreover from `A \<subseteq> set Vs` have size: "size Vs \<notin> index Vs ` A" by(auto simp add: image_def)
    hence "\<lfloor>index Vs ` (A - {V})\<rfloor> \<sqsubseteq> \<lfloor>index Vs ` A\<rfloor>" by(auto simp add: hyperset_defs)
    ultimately have "\<D> (compE1 (Vs @ [V]) e) \<lfloor>index Vs ` A\<rfloor>" using `A - {V} \<subseteq> set (Vs @ [V])`
      by(simp add: image_index)(erule D_mono', auto)
    thus ?thesis using None size by(simp)
  next
    case (Some v)
    with `\<D> {V:T=vo; e} \<lfloor>A\<rfloor>` have D: "\<D> e \<lfloor>insert V A\<rfloor>" by(auto)
    from `A \<subseteq> set Vs` have "insert V A \<subseteq> set (Vs @ [V])" by auto
    from IH[OF this fv D] have "\<D> (compE1 (Vs @ [V]) e) \<lfloor>index (Vs @ [V]) ` insert V A\<rfloor>" by simp
    moreover from `A \<subseteq> set Vs` have "index (Vs @ [V]) ` insert V A \<subseteq> insert (length Vs) (index Vs ` A)"
      by(auto simp add: image_index)
    ultimately show ?thesis using Some by(auto elim!: D_mono' simp add: hyperset_defs)
  qed
next
  case (Cons_exp e1 es)
  hence IH1: "\<D> (compE1 Vs e1) \<lfloor>index Vs ` A\<rfloor>" by simp
  show ?case
  proof (cases "\ e1")
    case None thus ?thesis using Cons_exp by simp
  next
    case (Some A1)
    have indexA1: "\ (compE1 Vs e1) = \<lfloor>index Vs ` A1\<rfloor>"
      using A_compE1[OF Some] Cons_exp.prems  by auto
    have "A \<union> A1 \<subseteq> set Vs" using Cons_exp.prems A_fv[OF Some] by auto
    hence "\<D>s (compEs1 Vs es) \<lfloor>index Vs ` (A \<union> A1)\<rfloor>" using Cons_exp Some by auto
    hence "\<D>s (compEs1 Vs es) \<lfloor>index Vs ` A \<union> index Vs ` A1\<rfloor>"
      by(simp add: image_Un)
    thus ?thesis using IH1 indexA1 by auto
  qed
qed (simp_all add:hyperset_defs)

declare Un_ac [simp del]

lemma index_image_set: "distinct xs \<Longrightarrow> index xs ` set xs = {..<size xs}"
by(induct xs rule:rev_induct) (auto simp add: image_index)

lemma D_compE1:
  "\<lbrakk> \<D> e \<lfloor>set Vs\<rfloor>; fv e \<subseteq> set Vs; distinct Vs \<rbrakk> \<Longrightarrow> \<D> (compE1 Vs e) \<lfloor>{..<length Vs}\<rfloor>"
by(fastforce dest!: D_index_compE1[OF subset_refl] simp add:index_image_set)

lemma D_compE1':
  assumes "\<D> e \<lfloor>set(V#Vs)\<rfloor>" and "fv e \<subseteq> set(V#Vs)" and "distinct(V#Vs)"
  shows "\<D> (compE1 (V#Vs) e) \<lfloor>{..length Vs}\<rfloor>"
proof -
  have "{..size Vs} = {..<size(V#Vs)}" by auto
  thus ?thesis using assms by (simp only:)(rule D_compE1)
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Sep_MP_Example
imports Sep_MP
begin

lemma "((P \<and>* Q \<and>* R \<longrightarrow>* B) \<and>* P \<and>* A \<and>* R \<and>* Q) s \<Longrightarrow> (A \<and>* B) s"
  (* sep_mp attempts to solve goals that could be solved by careful use of the sep_mp theorem *)
  apply (sep_mp)
  apply (clarsimp simp: sep_conj_ac)
  done

(* Sep_mp uses the sep_cancel set to solve goals *)

axiomatization
  Moo :: "'a :: stronger_sep_algebra => bool" and
  Bar :: "'a :: stronger_sep_algebra => bool"
where  Moo_Bar[sep_cancel] : "Moo s \<Longrightarrow> Bar s"

lemma "((Bar \<and>* Q \<and>* R \<longrightarrow>* B) \<and>* Moo \<and>* A \<and>* R \<and>* Q) s \<Longrightarrow> (A \<and>* B) s"
  apply (sep_mp)
  apply (clarsimp simp: sep_conj_ac)
  done

end