theory Nominal2_Abs
imports Nominal2_Base
        "HOL-Library.Quotient_List"
        "HOL-Library.Quotient_Product"
begin

section \<open>Abstractions\<close>

fun
  alpha_set
where
  alpha_set[simp del]:
  "alpha_set (bs, x) R f p (cs, y) \<longleftrightarrow>
     f x - bs = f y - cs \<and>
     (f x - bs) \<sharp>* p \<and>
     R (p \<bullet> x) y \<and>
     p \<bullet> bs = cs"

fun
  alpha_res
where
  alpha_res[simp del]:
  "alpha_res (bs, x) R f p (cs, y) \<longleftrightarrow>
     f x - bs = f y - cs \<and>
     (f x - bs) \<sharp>* p \<and>
     R (p \<bullet> x) y"

fun
  alpha_lst
where
  alpha_lst[simp del]:
  "alpha_lst (bs, x) R f p (cs, y) \<longleftrightarrow>
     f x - set bs = f y - set cs \<and>
     (f x - set bs) \<sharp>* p \<and>
     R (p \<bullet> x) y \<and>
     p \<bullet> bs = cs"

lemmas alphas = alpha_set.simps alpha_res.simps alpha_lst.simps

notation
  alpha_set ("_ \<approx>set _ _ _ _" [100, 100, 100, 100, 100] 100) and
  alpha_res ("_ \<approx>res _ _ _ _" [100, 100, 100, 100, 100] 100) and
  alpha_lst ("_ \<approx>lst _ _ _ _" [100, 100, 100, 100, 100] 100)

section \<open>Mono\<close>

lemma [mono]:
  shows "R1 \<le> R2 \<Longrightarrow> alpha_set bs R1 \<le> alpha_set bs R2"
  and   "R1 \<le> R2 \<Longrightarrow> alpha_res bs R1 \<le> alpha_res bs R2"
  and   "R1 \<le> R2 \<Longrightarrow> alpha_lst cs R1 \<le> alpha_lst cs R2"
  by (case_tac [!] bs, case_tac [!] cs)
     (auto simp: le_fun_def le_bool_def alphas)

section \<open>Equivariance\<close>

lemma alpha_eqvt[eqvt]:
  shows "(bs, x) \<approx>set R f q (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>set (p \<bullet> R) (p \<bullet> f) (p \<bullet> q) (p \<bullet> cs, p \<bullet> y)"
  and   "(bs, x) \<approx>res R f q (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>res (p \<bullet> R) (p \<bullet> f) (p \<bullet> q) (p \<bullet> cs, p \<bullet> y)"
  and   "(ds, x) \<approx>lst R f q (es, y) \<Longrightarrow> (p \<bullet> ds, p \<bullet> x) \<approx>lst (p \<bullet> R) (p \<bullet> f) (p \<bullet> q) (p \<bullet> es, p \<bullet> y)"
  unfolding alphas
  unfolding permute_eqvt[symmetric]
  unfolding set_eqvt[symmetric]
  unfolding permute_fun_app_eq[symmetric]
  unfolding Diff_eqvt[symmetric]
  unfolding eq_eqvt[symmetric]
  unfolding fresh_star_eqvt[symmetric]
  by (auto simp only: permute_bool_def)

section \<open>Equivalence\<close>

lemma alpha_refl:
  assumes a: "R x x"
  shows "(bs, x) \<approx>set R f 0 (bs, x)"
  and   "(bs, x) \<approx>res R f 0 (bs, x)"
  and   "(cs, x) \<approx>lst R f 0 (cs, x)"
  using a
  unfolding alphas
  unfolding fresh_star_def
  by (simp_all add: fresh_zero_perm)

lemma alpha_sym:
  assumes a: "R (p \<bullet> x) y \<Longrightarrow> R (- p \<bullet> y) x"
  shows "(bs, x) \<approx>set R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>set R f (- p) (bs, x)"
  and   "(bs, x) \<approx>res R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>res R f (- p) (bs, x)"
  and   "(ds, x) \<approx>lst R f p (es, y) \<Longrightarrow> (es, y) \<approx>lst R f (- p) (ds, x)"
  unfolding alphas fresh_star_def
  using a
  by (auto simp: fresh_minus_perm)

lemma alpha_trans:
  assumes a: "\<lbrakk>R (p \<bullet> x) y; R (q \<bullet> y) z\<rbrakk> \<Longrightarrow> R ((q + p) \<bullet> x) z"
  shows "\<lbrakk>(bs, x) \<approx>set R f p (cs, y); (cs, y) \<approx>set R f q (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>set R f (q + p) (ds, z)"
  and   "\<lbrakk>(bs, x) \<approx>res R f p (cs, y); (cs, y) \<approx>res R f q (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>res R f (q + p) (ds, z)"
  and   "\<lbrakk>(es, x) \<approx>lst R f p (gs, y); (gs, y) \<approx>lst R f q (hs, z)\<rbrakk> \<Longrightarrow> (es, x) \<approx>lst R f (q + p) (hs, z)"
  using a
  unfolding alphas fresh_star_def
  by (simp_all add: fresh_plus_perm)

lemma alpha_sym_eqvt:
  assumes a: "R (p \<bullet> x) y \<Longrightarrow> R y (p \<bullet> x)"
  and     b: "p \<bullet> R = R"
  shows "(bs, x) \<approx>set R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>set R f (- p) (bs, x)"
  and   "(bs, x) \<approx>res R f p (cs, y) \<Longrightarrow> (cs, y) \<approx>res R f (- p) (bs, x)"
  and   "(ds, x) \<approx>lst R f p (es, y) \<Longrightarrow> (es, y) \<approx>lst R f (- p) (ds, x)"
apply(auto intro!: alpha_sym)
apply(drule_tac [!] a)
apply(rule_tac [!] p="p" in permute_boolE)
apply(simp_all add: b permute_self)
done

lemma alpha_set_trans_eqvt:
  assumes b: "(cs, y) \<approx>set R f q (ds, z)"
  and     a: "(bs, x) \<approx>set R f p (cs, y)"
  and     d: "q \<bullet> R = R"
  and     c: "\<lbrakk>R (p \<bullet> x) y; R y (- q \<bullet> z)\<rbrakk> \<Longrightarrow> R (p \<bullet> x) (- q \<bullet> z)"
  shows "(bs, x) \<approx>set R f (q + p) (ds, z)"
apply(rule alpha_trans(1)[OF _ a b])
apply(drule c)
apply(rule_tac p="q" in permute_boolE)
apply(simp add: d permute_self)
apply(rotate_tac -1)
apply(drule_tac p="q" in permute_boolI)
apply(simp add: d permute_self permute_eqvt[symmetric])
done

lemma alpha_res_trans_eqvt:
  assumes  b: "(cs, y) \<approx>res R f q (ds, z)"
  and     a: "(bs, x) \<approx>res R f p (cs, y)"
  and     d: "q \<bullet> R = R"
  and     c: "\<lbrakk>R (p \<bullet> x) y; R y (- q \<bullet> z)\<rbrakk> \<Longrightarrow> R (p \<bullet> x) (- q \<bullet> z)"
  shows "(bs, x) \<approx>res R f (q + p) (ds, z)"
apply(rule alpha_trans(2)[OF _ a b])
apply(drule c)
apply(rule_tac p="q" in permute_boolE)
apply(simp add: d permute_self)
apply(rotate_tac -1)
apply(drule_tac p="q" in permute_boolI)
apply(simp add: d permute_self permute_eqvt[symmetric])
done

lemma alpha_lst_trans_eqvt:
  assumes b: "(cs, y) \<approx>lst R f q (ds, z)"
  and     a: "(bs, x) \<approx>lst R f p (cs, y)"
  and     d: "q \<bullet> R = R"
  and     c: "\<lbrakk>R (p \<bullet> x) y; R y (- q \<bullet> z)\<rbrakk> \<Longrightarrow> R (p \<bullet> x) (- q \<bullet> z)"
  shows "(bs, x) \<approx>lst R f (q + p) (ds, z)"
apply(rule alpha_trans(3)[OF _ a b])
apply(drule c)
apply(rule_tac p="q" in permute_boolE)
apply(simp add: d permute_self)
apply(rotate_tac -1)
apply(drule_tac p="q" in permute_boolI)
apply(simp add: d permute_self permute_eqvt[symmetric])
done

lemmas alpha_trans_eqvt = alpha_set_trans_eqvt alpha_res_trans_eqvt alpha_lst_trans_eqvt

section \<open>General Abstractions\<close>

fun
  alpha_abs_set
where
  [simp del]:
  "alpha_abs_set (bs, x) (cs, y) \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>set ((=)) supp p (cs, y))"

fun
  alpha_abs_lst
where
  [simp del]:
  "alpha_abs_lst (bs, x) (cs, y) \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>lst ((=)) supp p (cs, y))"

fun
  alpha_abs_res
where
  [simp del]:
  "alpha_abs_res (bs, x) (cs, y) \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>res ((=)) supp p (cs, y))"

notation
  alpha_abs_set (infix "\<approx>abs'_set" 50) and
  alpha_abs_lst (infix "\<approx>abs'_lst" 50) and
  alpha_abs_res (infix "\<approx>abs'_res" 50)

lemmas alphas_abs = alpha_abs_set.simps alpha_abs_res.simps alpha_abs_lst.simps

lemma alphas_abs_refl:
  shows "(bs, x) \<approx>abs_set (bs, x)"
  and   "(bs, x) \<approx>abs_res (bs, x)"
  and   "(cs, x) \<approx>abs_lst (cs, x)"
  unfolding alphas_abs
  unfolding alphas
  unfolding fresh_star_def
  by (rule_tac [!] x="0" in exI)
     (simp_all add: fresh_zero_perm)

lemma alphas_abs_sym:
  shows "(bs, x) \<approx>abs_set (cs, y) \<Longrightarrow> (cs, y) \<approx>abs_set (bs, x)"
  and   "(bs, x) \<approx>abs_res (cs, y) \<Longrightarrow> (cs, y) \<approx>abs_res (bs, x)"
  and   "(ds, x) \<approx>abs_lst (es, y) \<Longrightarrow> (es, y) \<approx>abs_lst (ds, x)"
  unfolding alphas_abs
  unfolding alphas
  unfolding fresh_star_def
  by (erule_tac [!] exE, rule_tac [!] x="-p" in exI)
     (auto simp: fresh_minus_perm)

lemma alphas_abs_trans:
  shows "\<lbrakk>(bs, x) \<approx>abs_set (cs, y); (cs, y) \<approx>abs_set (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>abs_set (ds, z)"
  and   "\<lbrakk>(bs, x) \<approx>abs_res (cs, y); (cs, y) \<approx>abs_res (ds, z)\<rbrakk> \<Longrightarrow> (bs, x) \<approx>abs_res (ds, z)"
  and   "\<lbrakk>(es, x) \<approx>abs_lst (gs, y); (gs, y) \<approx>abs_lst (hs, z)\<rbrakk> \<Longrightarrow> (es, x) \<approx>abs_lst (hs, z)"
  unfolding alphas_abs
  unfolding alphas
  unfolding fresh_star_def
  apply(erule_tac [!] exE, erule_tac [!] exE)
  apply(rule_tac [!] x="pa + p" in exI)
  by (simp_all add: fresh_plus_perm)

lemma alphas_abs_eqvt:
  shows "(bs, x) \<approx>abs_set (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>abs_set (p \<bullet> cs, p \<bullet> y)"
  and   "(bs, x) \<approx>abs_res (cs, y) \<Longrightarrow> (p \<bullet> bs, p \<bullet> x) \<approx>abs_res (p \<bullet> cs, p \<bullet> y)"
  and   "(ds, x) \<approx>abs_lst (es, y) \<Longrightarrow> (p \<bullet> ds, p \<bullet> x) \<approx>abs_lst (p \<bullet> es, p \<bullet> y)"
  unfolding alphas_abs
  unfolding alphas
  unfolding set_eqvt[symmetric]
  unfolding supp_eqvt[symmetric]
  unfolding Diff_eqvt[symmetric]
  apply(erule_tac [!] exE)
  apply(rule_tac [!] x="p \<bullet> pa" in exI)
  by (auto simp only: fresh_star_permute_iff permute_eqvt[symmetric])

section \<open>Strengthening the equivalence\<close>

lemma disjoint_right_eq:
  assumes a: "A \<union> B1 = A \<union> B2"
  and     b: "A \<inter> B1 = {}" "A \<inter> B2 = {}"
  shows "B1 = B2"
using a b
by (metis Int_Un_distrib2 Int_absorb2 Int_commute Un_upper2)

lemma supp_property_res:
  assumes a: "(as, x) \<approx>res (=) supp p (as', x')"
  shows "p \<bullet> (supp x \<inter> as) = supp x' \<inter> as'"
proof -
  from a have "(supp x - as) \<sharp>* p" by  (auto simp only: alphas)
  then have *: "p \<bullet> (supp x - as) = (supp x - as)"
    by (simp add: atom_set_perm_eq)
  have "(supp x' - as') \<union> (supp x' \<inter> as') = supp x'" by auto
  also have "\<dots> = supp (p \<bullet> x)" using a by (simp add: alphas)
  also have "\<dots> = p \<bullet> (supp x)" by (simp add: supp_eqvt)
  also have "\<dots> = p \<bullet> ((supp x - as) \<union> (supp x \<inter> as))" by auto
  also have "\<dots> = (p \<bullet> (supp x - as)) \<union> (p \<bullet> (supp x \<inter> as))" by (simp add: union_eqvt)
  also have "\<dots> = (supp x - as) \<union> (p \<bullet> (supp x \<inter> as))" using * by simp
  also have "\<dots> = (supp x' - as') \<union> (p \<bullet> (supp x \<inter> as))" using a by (simp add: alphas)
  finally have "(supp x' - as') \<union> (supp x' \<inter> as') = (supp x' - as') \<union> (p \<bullet> (supp x \<inter> as))" .
  moreover
  have "(supp x' - as') \<inter> (supp x' \<inter> as') = {}" by auto
  moreover
  have "(supp x - as) \<inter> (supp x \<inter> as) = {}" by auto
  then have "p \<bullet> ((supp x - as) \<inter> (supp x \<inter> as) = {})" by (simp add: permute_bool_def)
  then have "(p \<bullet> (supp x - as)) \<inter> (p \<bullet> (supp x \<inter> as)) = {}" by (perm_simp) (simp)
  then have "(supp x - as) \<inter> (p \<bullet> (supp x \<inter> as)) = {}" using * by simp
  then have "(supp x' - as') \<inter> (p \<bullet> (supp x \<inter> as)) = {}" using a by (simp add: alphas)
  ultimately show "p \<bullet> (supp x \<inter> as) = supp x' \<inter> as'"
    by (auto dest: disjoint_right_eq)
qed

lemma alpha_abs_res_stronger1_aux:
  assumes asm: "(as, x) \<approx>res (=) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>res (=) supp p (as', x') \<and> supp p \<subseteq> (supp x \<inter> as) \<union> (supp x' \<inter> as')"
proof -
  from asm have 0: "(supp x - as) \<sharp>* p'" by  (auto simp only: alphas)
  then have #: "p' \<bullet> (supp x - as) = (supp x - as)"
    by (simp add: atom_set_perm_eq)
  obtain p where *: "\<forall>b \<in> supp x. p \<bullet> b = p' \<bullet> b" and **: "supp p \<subseteq> supp x \<union> p' \<bullet> supp x"
    using set_renaming_perm2 by blast
  from * have a: "p \<bullet> x = p' \<bullet> x" using supp_perm_perm_eq by auto
  from 0 have 1: "(supp x - as) \<sharp>* p" using *
    by (auto simp: fresh_star_def fresh_perm)
  then have 2: "(supp x - as) \<inter> supp p = {}"
    by (auto simp: fresh_star_def fresh_def)
  have b: "supp x = (supp x - as) \<union> (supp x \<inter> as)" by auto
  have "supp p \<subseteq> supp x \<union> p' \<bullet> supp x" using ** by simp
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> (p' \<bullet> ((supp x - as) \<union> (supp x \<inter> as)))"
    using b by simp
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> ((p' \<bullet> (supp x - as)) \<union> (p' \<bullet> (supp x \<inter> as)))"
    by (simp add: union_eqvt)
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> (p' \<bullet> (supp x \<inter> as))"
    using # by auto
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> (supp x' \<inter> as')" using asm
    by (simp add: supp_property_res)
  finally have "supp p \<subseteq> (supp x - as) \<union> (supp x \<inter> as) \<union> (supp x' \<inter> as')" .
  then
  have "supp p \<subseteq> (supp x \<inter> as) \<union> (supp x' \<inter> as')" using 2 by auto
  moreover
  have "(as, x) \<approx>res (=) supp p (as', x')" using asm 1 a by (simp add: alphas)
  ultimately
  show "\<exists>p. (as, x) \<approx>res (=) supp p (as', x') \<and> supp p \<subseteq> (supp x \<inter> as) \<union> (supp x' \<inter> as')" by blast
qed

lemma alpha_abs_res_minimal:
  assumes asm: "(as, x) \<approx>res (=) supp p (as', x')"
  shows "(as \<inter> supp x, x) \<approx>res (=) supp p (as' \<inter> supp x', x')"
  using asm unfolding alpha_res by (auto simp: Diff_Int)

lemma alpha_abs_res_abs_set:
  assumes asm: "(as, x) \<approx>res (=) supp p (as', x')"
  shows "(as \<inter> supp x, x) \<approx>set (=) supp p (as' \<inter> supp x', x')"
proof -
  have c: "p \<bullet> x = x'"
    using alpha_abs_res_minimal[OF asm] unfolding alpha_res by clarify
  then have a: "supp x - as \<inter> supp x = supp (p \<bullet> x) - as' \<inter> supp (p \<bullet> x)"
    using alpha_abs_res_minimal[OF asm] by (simp add: alpha_res)
  have b: "(supp x - as \<inter> supp x) \<sharp>* p"
    using alpha_abs_res_minimal[OF asm] unfolding alpha_res by clarify
  have "p \<bullet> (as \<inter> supp x) = as' \<inter> supp (p \<bullet> x)"
    by (metis Int_commute asm c supp_property_res)
  then show ?thesis using a b c unfolding alpha_set by simp
qed

lemma alpha_abs_set_abs_res:
  assumes asm: "(as \<inter> supp x, x) \<approx>set (=) supp p (as' \<inter> supp x', x')"
  shows "(as, x) \<approx>res (=) supp p (as', x')"
  using asm unfolding alphas by (auto simp: Diff_Int)

lemma alpha_abs_res_stronger1:
  assumes asm: "(as, x) \<approx>res (=) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>res (=) supp p (as', x') \<and> supp p \<subseteq> as \<union> as'"
using alpha_abs_res_stronger1_aux[OF asm] by auto

lemma alpha_abs_set_stronger1:
  assumes asm: "(as, x) \<approx>set (=) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>set (=) supp p (as', x') \<and> supp p \<subseteq> as \<union> as'"
proof -
  from asm have 0: "(supp x - as) \<sharp>* p'" by  (auto simp only: alphas)
  then have #: "p' \<bullet> (supp x - as) = (supp x - as)"
    by (simp add: atom_set_perm_eq)
  obtain p where *: "\<forall>b \<in> (supp x \<union> as). p \<bullet> b = p' \<bullet> b"
    and **: "supp p \<subseteq> (supp x \<union> as) \<union> p' \<bullet> (supp x \<union> as)"
    using set_renaming_perm2 by blast
  from * have "\<forall>b \<in> supp x. p \<bullet> b = p' \<bullet> b" by blast
  then have a: "p \<bullet> x = p' \<bullet> x" using supp_perm_perm_eq by auto
  from * have "\<forall>b \<in> as. p \<bullet> b = p' \<bullet> b" by blast
  then have zb: "p \<bullet> as = p' \<bullet> as"
    apply(auto simp: permute_set_def)
    apply(rule_tac x="xa" in exI)
    apply(simp)
    done
  have zc: "p' \<bullet> as = as'" using asm by (simp add: alphas)
  from 0 have 1: "(supp x - as) \<sharp>* p" using *
    by (auto simp: fresh_star_def fresh_perm)
  then have 2: "(supp x - as) \<inter> supp p = {}"
    by (auto simp: fresh_star_def fresh_def)
  have b: "supp x = (supp x - as) \<union> (supp x \<inter> as)" by auto
  have "supp p \<subseteq> supp x \<union> as \<union> p' \<bullet> supp x \<union> p' \<bullet> as" using ** using union_eqvt by blast
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> (p' \<bullet> ((supp x - as) \<union> (supp x \<inter> as))) \<union> p' \<bullet> as"
    using b by simp
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union>
    ((p' \<bullet> (supp x - as)) \<union> (p' \<bullet> (supp x \<inter> as))) \<union> p' \<bullet> as" by (simp add: union_eqvt)
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> (p' \<bullet> (supp x \<inter> as)) \<union> p' \<bullet> as"
    using # by auto
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> p' \<bullet> ((supp x \<inter> as) \<union> as)" using union_eqvt
    by auto
  also have "\<dots> = (supp x - as) \<union> (supp x \<inter> as) \<union> as \<union> p' \<bullet> as"
    by (metis Int_commute Un_commute sup_inf_absorb)
  also have "\<dots> = (supp x - as) \<union> as \<union> p' \<bullet> as" by blast
  finally have "supp p \<subseteq> (supp x - as) \<union> as \<union> p' \<bullet> as" .
  then have "supp p \<subseteq> as \<union> p' \<bullet> as" using 2 by blast
  moreover
  have "(as, x) \<approx>set (=) supp p (as', x')" using asm 1 a zb by (simp add: alphas)
  ultimately
  show "\<exists>p. (as, x) \<approx>set (=) supp p (as', x') \<and> supp p \<subseteq> as \<union> as'" using zc by blast
qed

lemma alpha_abs_lst_stronger1:
  assumes asm: "(as, x) \<approx>lst (=) supp p' (as', x')"
  shows "\<exists>p. (as, x) \<approx>lst (=) supp p (as', x') \<and> supp p \<subseteq> set as \<union> set as'"
proof -
  from asm have 0: "(supp x - set as) \<sharp>* p'" by  (auto simp only: alphas)
  then have #: "p' \<bullet> (supp x - set as) = (supp x - set as)"
    by (simp add: atom_set_perm_eq)
  obtain p where *: "\<forall>b \<in> (supp x \<union> set as). p \<bullet> b = p' \<bullet> b"
    and **: "supp p \<subseteq> (supp x \<union> set as) \<union> p' \<bullet> (supp x \<union> set as)"
    using set_renaming_perm2 by blast
  from * have "\<forall>b \<in> supp x. p \<bullet> b = p' \<bullet> b" by blast
  then have a: "p \<bullet> x = p' \<bullet> x" using supp_perm_perm_eq by auto
  from * have "\<forall>b \<in> set as. p \<bullet> b = p' \<bullet> b" by blast
  then have zb: "p \<bullet> as = p' \<bullet> as" by (induct as) (auto)
  have zc: "p' \<bullet> set as = set as'" using asm by (simp add: alphas set_eqvt)
  from 0 have 1: "(supp x - set as) \<sharp>* p" using *
    by (auto simp: fresh_star_def fresh_perm)
  then have 2: "(supp x - set as) \<inter> supp p = {}"
    by (auto simp: fresh_star_def fresh_def)
  have b: "supp x = (supp x - set as) \<union> (supp x \<inter> set as)" by auto
  have "supp p \<subseteq> supp x \<union> set as \<union> p' \<bullet> supp x \<union> p' \<bullet> set as" using ** using union_eqvt by blast
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union>
    (p' \<bullet> ((supp x - set as) \<union> (supp x \<inter> set as))) \<union> p' \<bullet> set as" using b by simp
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union>
    ((p' \<bullet> (supp x - set as)) \<union> (p' \<bullet> (supp x \<inter> set as))) \<union> p' \<bullet> set as" by (simp add: union_eqvt)
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union>
    (p' \<bullet> (supp x \<inter> set as)) \<union> p' \<bullet> set as" using # by auto
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union> p' \<bullet> ((supp x \<inter> set as) \<union> set as)"
    using union_eqvt by auto
  also have "\<dots> = (supp x - set as) \<union> (supp x \<inter> set as) \<union> set as \<union> p' \<bullet> set as"
    by (metis Int_commute Un_commute sup_inf_absorb)
  also have "\<dots> = (supp x - set as) \<union> set as \<union> p' \<bullet> set as" by blast
  finally have "supp p \<subseteq> (supp x - set as) \<union> set as \<union> p' \<bullet> set as" .
  then have "supp p \<subseteq> set as \<union> p' \<bullet> set as" using 2 by blast
  moreover
  have "(as, x) \<approx>lst (=) supp p (as', x')" using asm 1 a zb by (simp add: alphas)
  ultimately
  show "\<exists>p. (as, x) \<approx>lst (=) supp p (as', x') \<and> supp p \<subseteq> set as \<union> set as'" using zc by blast
qed

lemma alphas_abs_stronger:
  shows "(as, x) \<approx>abs_set (as', x') \<longleftrightarrow> (\<exists>p. (as, x) \<approx>set (=) supp p (as', x') \<and> supp p \<subseteq> as \<union> as')"
  and   "(as, x) \<approx>abs_res (as', x') \<longleftrightarrow> (\<exists>p. (as, x) \<approx>res (=) supp p (as', x') \<and> supp p \<subseteq> as \<union> as')"
  and   "(bs, x) \<approx>abs_lst (bs', x') \<longleftrightarrow>
   (\<exists>p. (bs, x) \<approx>lst (=) supp p (bs', x') \<and> supp p \<subseteq> set bs \<union> set bs')"
apply(rule iffI)
apply(auto simp: alphas_abs alpha_abs_set_stronger1)[1]
apply(auto simp: alphas_abs)[1]
apply(rule iffI)
apply(auto simp: alphas_abs alpha_abs_res_stronger1)[1]
apply(auto simp: alphas_abs)[1]
apply(rule iffI)
apply(auto simp: alphas_abs alpha_abs_lst_stronger1)[1]
apply(auto simp: alphas_abs)[1]
done

lemma alpha_res_alpha_set:
  "(bs, x) \<approx>res (=) supp p (cs, y) \<longleftrightarrow> (bs \<inter> supp x, x) \<approx>set (=) supp p (cs \<inter> supp y, y)"
  using alpha_abs_set_abs_res alpha_abs_res_abs_set by blast

section \<open>Quotient types\<close>

quotient_type
    'a abs_set = "(atom set \<times> 'a::pt)" / "alpha_abs_set"
  apply(rule equivpI)
  unfolding reflp_def refl_on_def symp_def sym_def transp_def trans_def
  by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:)

quotient_type
    'b abs_res = "(atom set \<times> 'b::pt)" / "alpha_abs_res"
  apply(rule equivpI)
  unfolding reflp_def refl_on_def symp_def sym_def transp_def trans_def
  by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:)

quotient_type
   'c abs_lst = "(atom list \<times> 'c::pt)" / "alpha_abs_lst"
  apply(rule_tac [!] equivpI)
  unfolding reflp_def refl_on_def symp_def sym_def transp_def trans_def
  by (auto intro: alphas_abs_sym alphas_abs_refl alphas_abs_trans simp only:)

quotient_definition
  Abs_set ("[_]set. _" [60, 60] 60)
where
  "Abs_set::atom set \<Rightarrow> ('a::pt) \<Rightarrow> 'a abs_set"
is
  "Pair::atom set \<Rightarrow> ('a::pt) \<Rightarrow> (atom set \<times> 'a)" .

quotient_definition
  Abs_res ("[_]res. _" [60, 60] 60)
where
  "Abs_res::atom set \<Rightarrow> ('a::pt) \<Rightarrow> 'a abs_res"
is
  "Pair::atom set \<Rightarrow> ('a::pt) \<Rightarrow> (atom set \<times> 'a)" .

quotient_definition
  Abs_lst ("[_]lst. _" [60, 60] 60)
where
  "Abs_lst::atom list \<Rightarrow> ('a::pt) \<Rightarrow> 'a abs_lst"
is
  "Pair::atom list \<Rightarrow> ('a::pt) \<Rightarrow> (atom list \<times> 'a)" .

lemma [quot_respect]:
  shows "((=) ===> (=) ===> alpha_abs_set) Pair Pair"
  and   "((=) ===> (=) ===> alpha_abs_res) Pair Pair"
  and   "((=) ===> (=) ===> alpha_abs_lst) Pair Pair"
  unfolding rel_fun_def
  by (auto intro: alphas_abs_refl)

lemma [quot_respect]:
  shows "((=) ===> alpha_abs_set ===> alpha_abs_set) permute permute"
  and   "((=) ===> alpha_abs_res ===> alpha_abs_res) permute permute"
  and   "((=) ===> alpha_abs_lst ===> alpha_abs_lst) permute permute"
  unfolding rel_fun_def
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma Abs_eq_iff:
  shows "[bs]set. x = [bs']set. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>set (=) supp p (bs', y))"
  and   "[bs]res. x = [bs']res. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>res (=) supp p (bs', y))"
  and   "[cs]lst. x = [cs']lst. y \<longleftrightarrow> (\<exists>p. (cs, x) \<approx>lst (=) supp p (cs', y))"
  by (lifting alphas_abs)

lemma Abs_eq_iff2:
  shows "[bs]set. x = [bs']set. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>set ((=)) supp p (bs', y) \<and> supp p \<subseteq> bs \<union> bs')"
  and   "[bs]res. x = [bs']res. y \<longleftrightarrow> (\<exists>p. (bs, x) \<approx>res ((=)) supp p (bs', y) \<and> supp p \<subseteq> bs \<union> bs')"
  and   "[cs]lst. x = [cs']lst. y \<longleftrightarrow> (\<exists>p. (cs, x) \<approx>lst ((=)) supp p (cs', y) \<and> supp p \<subseteq> set cs \<union> set cs')"
  by (lifting alphas_abs_stronger)

lemma Abs_eq_res_set:
  shows "[bs]res. x = [cs]res. y \<longleftrightarrow> [bs \<inter> supp x]set. x = [cs \<inter> supp y]set. y"
  unfolding Abs_eq_iff alpha_res_alpha_set by rule

lemma Abs_eq_res_supp:
  assumes asm: "supp x \<subseteq> bs"
  shows "[as]res. x = [as \<inter> bs]res. x"
  unfolding Abs_eq_iff alphas
  apply (rule_tac x="0::perm" in exI)
  apply (simp add: fresh_star_zero)
  using asm by blast

lemma Abs_exhausts[cases type]:
  shows "(\<And>as (x::'a::pt). y1 = [as]set. x \<Longrightarrow> P1) \<Longrightarrow> P1"
  and   "(\<And>as (x::'a::pt). y2 = [as]res. x \<Longrightarrow> P2) \<Longrightarrow> P2"
  and   "(\<And>bs (x::'a::pt). y3 = [bs]lst. x \<Longrightarrow> P3) \<Longrightarrow> P3"
  by (lifting prod.exhaust[where 'a="atom set" and 'b="'a"]
              prod.exhaust[where 'a="atom set" and 'b="'a"]
              prod.exhaust[where 'a="atom list" and 'b="'a"])

instantiation abs_set :: (pt) pt
begin

quotient_definition
  "permute_abs_set::perm \<Rightarrow> ('a::pt abs_set) \<Rightarrow> 'a abs_set"
is
  "permute:: perm \<Rightarrow> (atom set \<times> 'a::pt) \<Rightarrow> (atom set \<times> 'a::pt)"
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma permute_Abs_set[simp]:
  fixes x::"'a::pt"
  shows "(p \<bullet> ([as]set. x)) = [p \<bullet> as]set. (p \<bullet> x)"
  by (lifting permute_prod.simps[where 'a="atom set" and 'b="'a"])

instance
  apply standard
  apply(case_tac [!] x)
  apply(simp_all)
  done

end

instantiation abs_res :: (pt) pt
begin

quotient_definition
  "permute_abs_res::perm \<Rightarrow> ('a::pt abs_res) \<Rightarrow> 'a abs_res"
is
  "permute:: perm \<Rightarrow> (atom set \<times> 'a::pt) \<Rightarrow> (atom set \<times> 'a::pt)"
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma permute_Abs_res[simp]:
  fixes x::"'a::pt"
  shows "(p \<bullet> ([as]res. x)) = [p \<bullet> as]res. (p \<bullet> x)"
  by (lifting permute_prod.simps[where 'a="atom set" and 'b="'a"])

instance
  apply standard
  apply(case_tac [!] x)
  apply(simp_all)
  done

end

instantiation abs_lst :: (pt) pt
begin

quotient_definition
  "permute_abs_lst::perm \<Rightarrow> ('a::pt abs_lst) \<Rightarrow> 'a abs_lst"
is
  "permute:: perm \<Rightarrow> (atom list \<times> 'a::pt) \<Rightarrow> (atom list \<times> 'a::pt)"
  by (auto intro: alphas_abs_eqvt simp only: Pair_eqvt)

lemma permute_Abs_lst[simp]:
  fixes x::"'a::pt"
  shows "(p \<bullet> ([as]lst. x)) = [p \<bullet> as]lst. (p \<bullet> x)"
  by (lifting permute_prod.simps[where 'a="atom list" and 'b="'a"])

instance
  apply standard
  apply(case_tac [!] x)
  apply(simp_all)
  done

end

lemmas permute_Abs[eqvt] = permute_Abs_set permute_Abs_res permute_Abs_lst

lemma Abs_swap1:
  assumes a1: "a \<notin> (supp x) - bs"
  and     a2: "b \<notin> (supp x) - bs"
  shows "[bs]set. x = [(a \<rightleftharpoons> b) \<bullet> bs]set. ((a \<rightleftharpoons> b) \<bullet> x)"
  and   "[bs]res. x = [(a \<rightleftharpoons> b) \<bullet> bs]res. ((a \<rightleftharpoons> b) \<bullet> x)"
  unfolding Abs_eq_iff
  unfolding alphas
  unfolding supp_eqvt[symmetric] Diff_eqvt[symmetric]
  unfolding fresh_star_def fresh_def
  unfolding swap_set_not_in[OF a1 a2]
  using a1 a2
  by (rule_tac [!] x="(a \<rightleftharpoons> b)" in exI)
     (auto simp: supp_perm swap_atom)

lemma Abs_swap2:
  assumes a1: "a \<notin> (supp x) - (set bs)"
  and     a2: "b \<notin> (supp x) - (set bs)"
  shows "[bs]lst. x = [(a \<rightleftharpoons> b) \<bullet> bs]lst. ((a \<rightleftharpoons> b) \<bullet> x)"
  unfolding Abs_eq_iff
  unfolding alphas
  unfolding supp_eqvt[symmetric] Diff_eqvt[symmetric] set_eqvt[symmetric]
  unfolding fresh_star_def fresh_def
  unfolding swap_set_not_in[OF a1 a2]
  using a1 a2
  by (rule_tac [!] x="(a \<rightleftharpoons> b)" in exI)
     (auto simp: supp_perm swap_atom)

lemma Abs_supports:
  shows "((supp x) - as) supports ([as]set. x)"
  and   "((supp x) - as) supports ([as]res. x)"
  and   "((supp x) - set bs) supports ([bs]lst. x)"
  unfolding supports_def
  unfolding permute_Abs
  by (simp_all add: Abs_swap1[symmetric] Abs_swap2[symmetric])

function
  supp_set  :: "('a::pt) abs_set \<Rightarrow> atom set" and
  supp_res :: "('a::pt) abs_res \<Rightarrow> atom set" and
  supp_lst :: "('a::pt) abs_lst \<Rightarrow> atom set"
where
  "supp_set ([as]set. x) = supp x - as"
| "supp_res ([as]res. x) = supp x - as"
| "supp_lst (Abs_lst cs x) = (supp x) - (set cs)"
apply(simp_all add: Abs_eq_iff alphas_abs alphas)
apply(case_tac x)
apply(case_tac a)
apply(simp)
apply(case_tac b)
apply(case_tac a)
apply(simp)
apply(case_tac ba)
apply(simp)
done

termination
  by lexicographic_order

lemma supp_funs_eqvt[eqvt]:
  shows "(p \<bullet> supp_set x) = supp_set (p \<bullet> x)"
  and   "(p \<bullet> supp_res y) = supp_res (p \<bullet> y)"
  and   "(p \<bullet> supp_lst z) = supp_lst (p \<bullet> z)"
  apply(case_tac x)
  apply(simp)
  apply(case_tac y)
  apply(simp)
  apply(case_tac z)
  apply(simp)
  done

lemma Abs_fresh_aux:
  shows "a \<sharp> [bs]set. x \<Longrightarrow> a \<sharp> supp_set ([bs]set. x)"
  and   "a \<sharp> [bs]res. x \<Longrightarrow> a \<sharp> supp_res ([bs]res. x)"
  and   "a \<sharp> [cs]lst. x \<Longrightarrow> a \<sharp> supp_lst ([cs]lst. x)"
  by (rule_tac [!] fresh_fun_eqvt_app)
     (auto simp only: eqvt_def eqvts_raw)

lemma Abs_supp_subset1:
  assumes a: "finite (supp x)"
  shows "(supp x) - as \<subseteq> supp ([as]set. x)"
  and   "(supp x) - as \<subseteq> supp ([as]res. x)"
  and   "(supp x) - (set bs) \<subseteq> supp ([bs]lst. x)"
  unfolding supp_conv_fresh
  by (auto dest!: Abs_fresh_aux)
     (simp_all add: fresh_def supp_finite_atom_set a)

lemma Abs_supp_subset2:
  assumes a: "finite (supp x)"
  shows "supp ([as]set. x) \<subseteq> (supp x) - as"
  and   "supp ([as]res. x) \<subseteq> (supp x) - as"
  and   "supp ([bs]lst. x) \<subseteq> (supp x) - (set bs)"
  by (rule_tac [!] supp_is_subset)
     (simp_all add: Abs_supports a)

lemma Abs_finite_supp:
  assumes a: "finite (supp x)"
  shows "supp ([as]set. x) = (supp x) - as"
  and   "supp ([as]res. x) = (supp x) - as"
  and   "supp ([bs]lst. x) = (supp x) - (set bs)"
using Abs_supp_subset1[OF a] Abs_supp_subset2[OF a]
  by blast+

lemma supp_Abs:
  fixes x::"'a::fs"
  shows "supp ([as]set. x) = (supp x) - as"
  and   "supp ([as]res. x) = (supp x) - as"
  and   "supp ([bs]lst. x) = (supp x) - (set bs)"
by (simp_all add: Abs_finite_supp finite_supp)

instance abs_set :: (fs) fs
  apply standard
  apply(case_tac x)
  apply(simp add: supp_Abs finite_supp)
  done

instance abs_res :: (fs) fs
  apply standard
  apply(case_tac x)
  apply(simp add: supp_Abs finite_supp)
  done

instance abs_lst :: (fs) fs
  apply standard
  apply(case_tac x)
  apply(simp add: supp_Abs finite_supp)
  done

lemma Abs_fresh_iff:
  fixes x::"'a::fs"
  shows "a \<sharp> [bs]set. x \<longleftrightarrow> a \<in> bs \<or> (a \<notin> bs \<and> a \<sharp> x)"
  and   "a \<sharp> [bs]res. x \<longleftrightarrow> a \<in> bs \<or> (a \<notin> bs \<and> a \<sharp> x)"
  and   "a \<sharp> [cs]lst. x \<longleftrightarrow> a \<in> (set cs) \<or> (a \<notin> (set cs) \<and> a \<sharp> x)"
  unfolding fresh_def
  unfolding supp_Abs
  by auto

lemma Abs_fresh_star_iff:
  fixes x::"'a::fs"
  shows "as \<sharp>* ([bs]set. x) \<longleftrightarrow> (as - bs) \<sharp>* x"
  and   "as \<sharp>* ([bs]res. x) \<longleftrightarrow> (as - bs) \<sharp>* x"
  and   "as \<sharp>* ([cs]lst. x) \<longleftrightarrow> (as - set cs) \<sharp>* x"
  unfolding fresh_star_def
  by (auto simp: Abs_fresh_iff)

lemma Abs_fresh_star:
  fixes x::"'a::fs"
  shows "as \<subseteq> as' \<Longrightarrow> as \<sharp>* ([as']set. x)"
  and   "as \<subseteq> as' \<Longrightarrow> as \<sharp>* ([as']res. x)"
  and   "bs \<subseteq> set bs' \<Longrightarrow> bs \<sharp>* ([bs']lst. x)"
  unfolding fresh_star_def
  by(auto simp: Abs_fresh_iff)

lemma Abs_fresh_star2:
  fixes x::"'a::fs"
  shows "as \<inter> bs = {} \<Longrightarrow> as \<sharp>* ([bs]set. x) \<longleftrightarrow> as \<sharp>* x"
  and   "as \<inter> bs = {} \<Longrightarrow> as \<sharp>* ([bs]res. x) \<longleftrightarrow> as \<sharp>* x"
  and   "cs \<inter> set ds = {} \<Longrightarrow> cs \<sharp>* ([ds]lst. x) \<longleftrightarrow> cs \<sharp>* x"
  unfolding fresh_star_def Abs_fresh_iff
  by auto

section \<open>Abstractions of single atoms\<close>

lemma Abs1_eq:
  fixes x y::"'a::fs"
  shows "[{atom a}]set. x = [{atom a}]set. y \<longleftrightarrow> x = y"
  and   "[{atom a}]res. x = [{atom a}]res. y \<longleftrightarrow> x = y"
  and   "[[atom a]]lst. x = [[atom a]]lst. y \<longleftrightarrow> x = y"
unfolding Abs_eq_iff2 alphas
by (auto simp: supp_perm_singleton fresh_star_def fresh_zero_perm)

lemma Abs1_eq_iff_fresh:
  fixes x y::"'a::fs"
  and a b c::"'b::at"
  assumes "atom c \<sharp> (a, b, x, y)"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
proof -
  have "[{atom a}]set. x = (a \<leftrightarrow> c) \<bullet> ([{atom a}]set. x)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom a}]set. x = [{atom c}]set. ((a \<leftrightarrow> c) \<bullet> x)" by simp
  moreover
  have "[{atom b}]set. y = (b \<leftrightarrow> c) \<bullet> ([{atom b}]set. y)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom b}]set. y = [{atom c}]set. ((b \<leftrightarrow> c) \<bullet> y)" by simp
  ultimately
  show "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
    by (simp add: Abs1_eq)
next
  have "[{atom a}]res. x = (a \<leftrightarrow> c) \<bullet> ([{atom a}]res. x)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom a}]res. x = [{atom c}]res. ((a \<leftrightarrow> c) \<bullet> x)" by simp
  moreover
  have "[{atom b}]res. y = (b \<leftrightarrow> c) \<bullet> ([{atom b}]res. y)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[{atom b}]res. y = [{atom c}]res. ((b \<leftrightarrow> c) \<bullet> y)" by simp
  ultimately
  show "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
    by (simp add: Abs1_eq)
next
  have "[[atom a]]lst. x = (a \<leftrightarrow> c) \<bullet> ([[atom a]]lst. x)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[[atom a]]lst. x = [[atom c]]lst. ((a \<leftrightarrow> c) \<bullet> x)" by simp
  moreover
  have "[[atom b]]lst. y = (b \<leftrightarrow> c) \<bullet> ([[atom b]]lst. y)"
    by (rule_tac flip_fresh_fresh[symmetric]) (simp_all add: Abs_fresh_iff assms)
  then have "[[atom b]]lst. y = [[atom c]]lst. ((b \<leftrightarrow> c) \<bullet> y)" by simp
  ultimately
  show "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y"
    by (simp add: Abs1_eq)
qed

lemma Abs1_eq_iff_all:
  fixes x y::"'a::fs"
  and z::"'c::fs"
  and a b::"'b::at"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (\<forall>c. atom c \<sharp> z \<longrightarrow> atom c \<sharp> (a, b, x, y) \<longrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y)"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (\<forall>c. atom c \<sharp> z \<longrightarrow> atom c \<sharp> (a, b, x, y) \<longrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y)"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (\<forall>c. atom c \<sharp> z \<longrightarrow> atom c \<sharp> (a, b, x, y) \<longrightarrow> (a \<leftrightarrow> c) \<bullet> x = (b \<leftrightarrow> c) \<bullet> y)"
apply(auto)
apply(simp add: Abs1_eq_iff_fresh(1)[symmetric])
apply(rule_tac ?'a="'b::at" and x="(a, b, x, y, z)" in obtain_fresh)
apply(drule_tac x="aa" in spec)
apply(simp)
apply(subst Abs1_eq_iff_fresh(1))
apply(auto simp: fresh_Pair)[2]
apply(simp add: Abs1_eq_iff_fresh(2)[symmetric])
apply(rule_tac ?'a="'b::at" and x="(a, b, x, y, z)" in obtain_fresh)
apply(drule_tac x="aa" in spec)
apply(simp)
apply(subst Abs1_eq_iff_fresh(2))
apply(auto simp: fresh_Pair)[2]
apply(simp add: Abs1_eq_iff_fresh(3)[symmetric])
apply(rule_tac ?'a="'b::at" and x="(a, b, x, y, z)" in obtain_fresh)
apply(drule_tac x="aa" in spec)
apply(simp)
apply(subst Abs1_eq_iff_fresh(3))
apply(auto simp: fresh_Pair)[2]
done

lemma Abs1_eq_iff:
  fixes x y::"'a::fs"
  and a b::"'b::at"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
proof -
  { assume "a = b"
    then have "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y)" by (simp add: Abs1_eq)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "[{atom a}]set. x = [{atom b}]set. y"
    have #: "atom a \<sharp> [{atom b}]set. y" by (simp add: **[symmetric] Abs_fresh_iff)
    have "[{atom a}]set. ((a \<leftrightarrow> b) \<bullet> y) = (a \<leftrightarrow> b) \<bullet> ([{atom b}]set. y)" by (simp)
    also have "\<dots> = [{atom b}]set. y"
      by (rule flip_fresh_fresh) (simp add: #, simp add: Abs_fresh_iff)
    also have "\<dots> = [{atom a}]set. x" using ** by simp
    finally have "a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y" using # * by (simp add: Abs1_eq Abs_fresh_iff)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y"
    have "[{atom a}]set. x = [{atom a}]set. ((a \<leftrightarrow> b) \<bullet> y)" using ** by simp
    also have "\<dots> = (a \<leftrightarrow> b) \<bullet> ([{atom b}]set. y)" by (simp add: permute_set_def)
    also have "\<dots> = [{atom b}]set. y"
      by (rule flip_fresh_fresh) (simp add: Abs_fresh_iff **, simp add: Abs_fresh_iff)
    finally have "[{atom a}]set. x = [{atom b}]set. y" .
  }
  ultimately
  show "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
    by blast
next
  { assume "a = b"
    then have "Abs_res {atom a} x = Abs_res {atom b} y \<longleftrightarrow> (a = b \<and> x = y)" by (simp add: Abs1_eq)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "Abs_res {atom a} x = Abs_res {atom b} y"
    have #: "atom a \<sharp> Abs_res {atom b} y" by (simp add: **[symmetric] Abs_fresh_iff)
    have "Abs_res {atom a} ((a \<leftrightarrow> b) \<bullet> y) = (a \<leftrightarrow> b) \<bullet> (Abs_res {atom b} y)" by simp
    also have "\<dots> = Abs_res {atom b} y"
      by (rule flip_fresh_fresh) (simp add: #, simp add: Abs_fresh_iff)
    also have "\<dots> = Abs_res {atom a} x" using ** by simp
    finally have "a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y" using # * by (simp add: Abs1_eq Abs_fresh_iff)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y"
    have "Abs_res {atom a} x = Abs_res {atom a} ((a \<leftrightarrow> b) \<bullet> y)" using ** by simp
    also have "\<dots> = (a \<leftrightarrow> b) \<bullet> Abs_res {atom b} y" by (simp add: permute_set_def)
    also have "\<dots> = Abs_res {atom b} y"
      by (rule flip_fresh_fresh) (simp add: Abs_fresh_iff **, simp add: Abs_fresh_iff)
    finally have "Abs_res {atom a} x = Abs_res {atom b} y" .
  }
  ultimately
  show "Abs_res {atom a} x = Abs_res {atom b} y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
    by blast
next
  { assume "a = b"
    then have "Abs_lst [atom a] x = Abs_lst [atom b] y \<longleftrightarrow> (a = b \<and> x = y)" by (simp add: Abs1_eq)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "Abs_lst [atom a] x = Abs_lst [atom b] y"
    have #: "atom a \<sharp> Abs_lst [atom b] y" by (simp add: **[symmetric] Abs_fresh_iff)
    have "Abs_lst [atom a] ((a \<leftrightarrow> b) \<bullet> y) = (a \<leftrightarrow> b) \<bullet> (Abs_lst [atom b] y)" by simp
    also have "\<dots> = Abs_lst [atom b] y"
      by (rule flip_fresh_fresh) (simp add: #, simp add: Abs_fresh_iff)
    also have "\<dots> = Abs_lst [atom a] x" using ** by simp
    finally have "a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y" using # * by (simp add: Abs1_eq Abs_fresh_iff)
  }
  moreover
  { assume *: "a \<noteq> b" and **: "x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y"
    have "Abs_lst [atom a] x = Abs_lst [atom a] ((a \<leftrightarrow> b) \<bullet> y)" using ** by simp
    also have "\<dots> = (a \<leftrightarrow> b) \<bullet> Abs_lst [atom b] y" by simp
    also have "\<dots> = Abs_lst [atom b] y"
      by (rule flip_fresh_fresh) (simp add: Abs_fresh_iff **, simp add: Abs_fresh_iff)
    finally have "Abs_lst [atom a] x = Abs_lst [atom b] y" .
  }
  ultimately
  show "Abs_lst [atom a] x = Abs_lst [atom b] y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> x = (a \<leftrightarrow> b) \<bullet> y \<and> atom a \<sharp> y)"
    by blast
qed

lemma Abs1_eq_iff':
  fixes x::"'a::fs"
  and a b::"'b::at"
  shows "[{atom a}]set. x = [{atom b}]set. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> (b \<leftrightarrow> a) \<bullet> x = y \<and> atom b \<sharp> x)"
  and   "[{atom a}]res. x = [{atom b}]res. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> (b \<leftrightarrow> a) \<bullet> x = y \<and> atom b \<sharp> x)"
  and   "[[atom a]]lst. x = [[atom b]]lst. y \<longleftrightarrow> (a = b \<and> x = y) \<or> (a \<noteq> b \<and> (b \<leftrightarrow> a) \<bullet> x = y \<and> atom b \<sharp> x)"
by (auto simp: Abs1_eq_iff fresh_permute_left)

ML \<open>
fun alpha_single_simproc thm _ ctxt ctrm =
  let
    val thy = Proof_Context.theory_of ctxt
    val _ $ (_ $ x) $ (_ $ y) = Thm.term_of ctrm
    val cvrs = union (op =) (Term.add_frees x []) (Term.add_frees y [])
      |> filter (fn (_, ty) => Sign.of_sort thy (ty, @{sort fs}))
      |> map Free
      |> HOLogic.mk_tuple
      |> Thm.cterm_of ctxt
    val cvrs_ty = Thm.ctyp_of_cterm cvrs
    val thm' = thm
      |> Thm.instantiate' [NONE, NONE, SOME cvrs_ty] [NONE, NONE, NONE, NONE, SOME cvrs]
  in
    SOME thm'
  end
\<close>

simproc_setup alpha_set ("[{atom a}]set. x = [{atom b}]set. y") =
  \<open>alpha_single_simproc @{thm Abs1_eq_iff_all(1)[THEN eq_reflection]}\<close>

simproc_setup alpha_res ("[{atom a}]res. x = [{atom b}]res. y") =
  \<open>alpha_single_simproc @{thm Abs1_eq_iff_all(2)[THEN eq_reflection]}\<close>

simproc_setup alpha_lst ("[[atom a]]lst. x = [[atom b]]lst. y") =
  \<open>alpha_single_simproc @{thm Abs1_eq_iff_all(3)[THEN eq_reflection]}\<close>

subsection \<open>Renaming of bodies of abstractions\<close>

lemma Abs_rename_set:
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]set. x = [p \<bullet> bs]set. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
proof -
  from set_renaming_perm2
  obtain q where *: "\<forall>b \<in> bs. q \<bullet> b = p \<bullet> b" and **: "supp q \<subseteq> bs \<union> (p \<bullet> bs)" by blast
  have ***: "q \<bullet> bs = p \<bullet> bs" using *
    unfolding permute_set_eq_image image_def by auto
  have "[bs]set. x =  q \<bullet> ([bs]set. x)"
    apply(rule perm_supp_eq[symmetric])
    using a **
    unfolding Abs_fresh_star_iff
    unfolding fresh_star_def
    by auto
  also have "\<dots> = [q \<bullet> bs]set. (q \<bullet> x)" by simp
  finally have "[bs]set. x = [p \<bullet> bs]set. (q \<bullet> x)" by (simp add: ***)
  then show "\<exists>q. [bs]set. x = [p \<bullet> bs]set. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs" using *** by metis
qed

lemma Abs_rename_res:
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]res. x = [p \<bullet> bs]res. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
proof -
  from set_renaming_perm2
  obtain q where *: "\<forall>b \<in> bs. q \<bullet> b = p \<bullet> b" and **: "supp q \<subseteq> bs \<union> (p \<bullet> bs)" by blast
  have ***: "q \<bullet> bs = p \<bullet> bs" using *
    unfolding permute_set_eq_image image_def by auto
  have "[bs]res. x =  q \<bullet> ([bs]res. x)"
    apply(rule perm_supp_eq[symmetric])
    using a **
    unfolding Abs_fresh_star_iff
    unfolding fresh_star_def
    by auto
  also have "\<dots> = [q \<bullet> bs]res. (q \<bullet> x)" by simp
  finally have "[bs]res. x = [p \<bullet> bs]res. (q \<bullet> x)" by (simp add: ***)
  then show "\<exists>q. [bs]res. x = [p \<bullet> bs]res. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs" using *** by metis
qed

lemma Abs_rename_lst:
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> (set bs)) \<sharp>* x"
  shows "\<exists>q. [bs]lst. x = [p \<bullet> bs]lst. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
proof -
  from list_renaming_perm
  obtain q where *: "\<forall>b \<in> set bs. q \<bullet> b = p \<bullet> b" and **: "supp q \<subseteq> set bs \<union> (p \<bullet> set bs)" by blast
  have ***: "q \<bullet> bs = p \<bullet> bs" using * by (induct bs) (simp_all add: insert_eqvt)
  have "[bs]lst. x =  q \<bullet> ([bs]lst. x)"
    apply(rule perm_supp_eq[symmetric])
    using a **
    unfolding Abs_fresh_star_iff
    unfolding fresh_star_def
    by auto
  also have "\<dots> = [q \<bullet> bs]lst. (q \<bullet> x)" by simp
  finally have "[bs]lst. x = [p \<bullet> bs]lst. (q \<bullet> x)" by (simp add: ***)
  then show "\<exists>q. [bs]lst. x = [p \<bullet> bs]lst. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs" using *** by metis
qed

text \<open>for deep recursive binders\<close>

lemma Abs_rename_set':
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]set. x = [q \<bullet> bs]set. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
using Abs_rename_set[OF a] by metis

lemma Abs_rename_res':
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> bs) \<sharp>* x"
  (*and     b: "finite bs"*)
  shows "\<exists>q. [bs]res. x = [q \<bullet> bs]res. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
using Abs_rename_res[OF a] by metis

lemma Abs_rename_lst':
  fixes x::"'a::fs"
  assumes a: "(p \<bullet> (set bs)) \<sharp>* x"
  shows "\<exists>q. [bs]lst. x = [q \<bullet> bs]lst. (q \<bullet> x) \<and> q \<bullet> bs = p \<bullet> bs"
using Abs_rename_lst[OF a] by metis

section \<open>Infrastructure for building tuples of relations and functions\<close>

fun
  prod_fv :: "('a \<Rightarrow> atom set) \<Rightarrow> ('b \<Rightarrow> atom set) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> atom set"
where
  "prod_fv fv1 fv2 (x, y) = fv1 x \<union> fv2 y"

definition
  prod_alpha :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool)"
where
 "prod_alpha = rel_prod"

lemma [quot_respect]:
  shows "((R1 ===> (=)) ===> (R2 ===> (=)) ===> rel_prod R1 R2 ===> (=)) prod_fv prod_fv"
  unfolding rel_fun_def
  by auto

lemma [quot_preserve]:
  assumes q1: "Quotient3 R1 abs1 rep1"
  and     q2: "Quotient3 R2 abs2 rep2"
  shows "((abs1 ---> id) ---> (abs2 ---> id) ---> map_prod rep1 rep2 ---> id) prod_fv = prod_fv"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])

lemma [mono]:
  shows "A <= B \<Longrightarrow> C <= D ==> prod_alpha A C <= prod_alpha B D"
  unfolding prod_alpha_def
  by auto

lemma [eqvt]:
  shows "p \<bullet> prod_alpha A B x y = prod_alpha (p \<bullet> A) (p \<bullet> B) (p \<bullet> x) (p \<bullet> y)"
  unfolding prod_alpha_def
  unfolding rel_prod_conv
  by (perm_simp) (rule refl)

lemma [eqvt]:
  shows "p \<bullet> prod_fv A B (x, y) = prod_fv (p \<bullet> A) (p \<bullet> B) (p \<bullet> x, p \<bullet> y)"
  unfolding prod_fv.simps
  by (perm_simp) (rule refl)

lemma prod_fv_supp:
  shows "prod_fv supp supp = supp"
by (rule ext)
   (auto simp: supp_Pair)

lemma prod_alpha_eq:
  shows "prod_alpha ((=)) ((=)) = ((=))"
  unfolding prod_alpha_def
  by (auto intro!: ext)

end


(*
    Author:     David Sanan
    Maintainer:  David Sanan, sanan at ntu edu sg
    License:     LGPL
*)

(*  Title:      StateSpace.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section {* State Space Template *}
theory StateSpaceProduct imports EmbSimpl.Hoare
begin

type_synonym ('g, 'n, 'val) stateSP = "'g \<times> ('n \<Rightarrow> 'val)"

definition
  upd_globals:: "('g \<Rightarrow> 'g) \<Rightarrow> 'g \<times> 'l \<Rightarrow> 'g \<times> 'l"
where
  "upd_globals upd s = (upd (fst s), snd s)"

definition
  globals_update:: "('g \<Rightarrow> 'g) \<Rightarrow> 'g \<times> 'l \<Rightarrow> 'g \<times> 'l"
where
  "globals_update upd s = (upd (fst s), snd s)"

declare globals_update_def[simp]

definition globals ::"'g \<times> 'l \<Rightarrow> 'g"
  where "globals s \<equiv> fst s"

definition locals :: " ('g, 'n, 'val) stateSP \<Rightarrow> ('n \<Rightarrow> 'val)"
  where
"locals s \<equiv> snd s"

definition upd_locals::"( ('n \<Rightarrow> 'val) \<Rightarrow>  ('n \<Rightarrow> 'val)) \<Rightarrow> ('g, 'n, 'val) stateSP \<Rightarrow> ('g, 'n, 'val) stateSP"
  where
"upd_locals upd s = (fst s, upd (snd s))"

definition locals_update::"( ('n \<Rightarrow> 'val) \<Rightarrow>  ('n \<Rightarrow> 'val)) \<Rightarrow> ('g, 'n, 'val) stateSP \<Rightarrow> ('g, 'n, 'val) stateSP"
  where
"locals_update upd s = (fst s, upd (snd s))"

declare locals_update_def[simp]

lemma upd_globals_conv: "upd_globals f = (\<lambda>s. (f (fst s), snd s))"
  by (rule ext) (simp add: upd_globals_def)

lemma globals_updates_conv: "globals_update f = (\<lambda>s. (f (fst s), snd s))"
  by (rule ext) (simp)

lemma upd_locals_conv: "upd_locals f = (\<lambda>s. (fst s, f (snd s)))"
  by (rule ext) (simp add: upd_locals_def)

lemma locals_updates_conv: "locals_update f = (\<lambda>s. (fst s, f (snd s)))"
  by (rule ext) (simp)

end


theory InstanceBags
imports NonFreeAnimation
begin

(*
datatype 'a bag = Emp | Ins 'a ('a bag)
where
  Ins a1 (Ins a2 s) = Ins a2 (Ins a1 s)
*)

locale results =
  fixes alpha :: tyvar
    and bag_name :: tyco
    and ins_name :: oper
    and emp_name :: oper
    and dummy :: 'a
begin

lemma [ffact]: "decl_tyvars () [alpha]" ..
lemma [ffact]: "alpha tyinterpr TYPE('a)" ..

lemma [ffact]: "bag_name tycohaskind (ExtType =K=> IntType)" ..

lemma [ffact]: "ins_name operhasty (alpha =T=> bag_name ** alpha =T=> bag_name ** alpha)" ..
lemma [ffact]: "emp_name operhasty (bag_name ** alpha)" ..

definition "ins_clause_name = (0::nat)"

lemma [ffact]: "decl_hcl ins_clause_name (QUANT a:alpha. QUANT a2:alpha. QUANT S: bag_name**alpha.
  ins_name $ a $ (ins_name $ a2 $ S) === ins_name $ a2 $ (ins_name $ a $ S))" ..

local_setup {* MetaRec.run_expl_frules *}

end

thm results.ins_clause

locale algebra_results = results  alpha bag_name ins_name emp_name dummy
    for alpha :: tyvar
    and bag_name :: tyco
    and emp_name :: oper
    and ins_name :: oper
    and dummy :: 'a
begin

lemma [ffact]: "(bag_name ** alpha) alginterpr TYPE('a set)" ..
lemma [ffact]: "ins_name operalginterpr (% (x::'a) (xs :: 'a set). {x} Un xs)" ..
lemma [ffact]: "emp_name operalginterpr ({} :: 'a set)" ..

lemma [ffact]: "proven_hcl (ALL (x::'a) (x2::'a) (S::'a set). {x} Un ({x2} Un S) = {x2} Un ({x} Un S))"
  unfolding proven_hcl_def by blast

local_setup {* MetaRec.run_expl_frules *}

end

thm algebra_results.iter_op_clauses0

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005 - 2008  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>First Order Logic\<close>

theory Fol1 imports ZF.Trancl

begin

text\<open>Isabelle/ZF builds on the first order logic. Almost everything
  one would like to have in this area is covered in the standard Isabelle
  libraries. The material in this theory provides some lemmas that are
  missing or allow for a more readable proof style.\<close>

subsection\<open>Notions and lemmas in FOL\<close>

text\<open>This section contains mostly shortcuts and workarounds
  that allow to use more readable coding style.\<close>

text\<open>The next lemma serves as a workaround to problems with applying
  the definition of transitivity (of a relation) in our coding style
  (any attempt to do
  something like \<open>using trans_def\<close> puts Isabelle in an
  infinite loop).\<close>

lemma Fol1_L2: assumes
  A1: "\<forall> x y z. \<langle>x, y\<rangle> \<in> r \<and> \<langle>y, z\<rangle> \<in> r \<longrightarrow> \<langle>x, z\<rangle> \<in> r"
  shows "trans(r)"
proof -
  from A1 have
    "\<forall> x y z. \<langle>x, y\<rangle> \<in> r \<longrightarrow> \<langle>y, z\<rangle> \<in> r \<longrightarrow> \<langle>x, z\<rangle> \<in> r"
    using imp_conj by blast
  then show ?thesis unfolding trans_def by blast
qed

text\<open>Another workaround for the problem of Isabelle simplifier looping when
  the transitivity definition is used.\<close>

lemma Fol1_L3: assumes A1: "trans(r)" and A2: "\<langle> a,b\<rangle> \<in> r  \<and> \<langle> b,c\<rangle> \<in> r"
  shows "\<langle> a,c\<rangle> \<in> r"
proof -
  from A1 have  "\<forall>x y z. \<langle>x, y\<rangle> \<in> r \<longrightarrow> \<langle>y, z\<rangle> \<in> r \<longrightarrow> \<langle>x, z\<rangle> \<in> r"
   unfolding trans_def by blast
  with A2 show ?thesis using imp_conj by fast
qed

text\<open>There is a problem with application of the definition of asymetry for
  relations. The next lemma is a workaround.\<close>

lemma Fol1_L4:
  assumes A1: "antisym(r)" and A2: "\<langle> a,b\<rangle> \<in> r"   "\<langle> b,a\<rangle> \<in> r"
  shows "a=b"
proof -
  from A1 have "\<forall> x y. \<langle> x,y\<rangle> \<in> r \<longrightarrow> \<langle> y,x\<rangle> \<in> r \<longrightarrow> x=y"
    unfolding antisym_def by blast
  with A2 show "a=b" using imp_conj by fast
qed

text\<open>The definition below implements a common idiom that states that
  (perhaps under some assumptions) exactly one of given three statements
  is true.\<close>

definition
  "Exactly_1_of_3_holds(p,q,r) \<equiv>
  (p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"

text\<open>The next lemma allows to prove statements of the form
  \<open>Exactly_1_of_3_holds(p,q,r)\<close>.\<close>

lemma Fol1_L5:
  assumes "p\<or>q\<or>r"
  and "p \<longrightarrow> \<not>q \<and> \<not>r"
  and "q \<longrightarrow> \<not>p \<and> \<not>r"
  and "r \<longrightarrow> \<not>p \<and> \<not>q"
  shows "Exactly_1_of_3_holds(p,q,r)"
proof -
  from assms have
    "(p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"
    by blast
  then show "Exactly_1_of_3_holds (p,q,r)"
    unfolding Exactly_1_of_3_holds_def by fast
qed

text\<open>If exactly one of $p,q,r$ holds and $p$ is not true, then
  $q$ or $r$.\<close>

lemma Fol1_L6:
  assumes A1: "\<not>p" and A2: "Exactly_1_of_3_holds(p,q,r)"
  shows "q\<or>r"
proof -
  from A2 have
    "(p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"
    unfolding Exactly_1_of_3_holds_def by fast
  hence "p \<or> q \<or> r" by blast
  with A1 show "q \<or> r" by simp
qed

text\<open>If exactly one of $p,q,r$ holds and $q$ is true, then
  $r$ can not be true.\<close>

lemma Fol1_L7:
  assumes A1: "q" and A2: "Exactly_1_of_3_holds(p,q,r)"
  shows "\<not>r"
proof -
   from A2 have
    "(p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"
    unfolding Exactly_1_of_3_holds_def by fast
  with A1 show "\<not>r" by blast
qed

text\<open>The next lemma demonstrates an elegant form of the
  \<open>Exactly_1_of_3_holds(p,q,r)\<close> predicate.\<close>

lemma Fol1_L8:
  shows "Exactly_1_of_3_holds(p,q,r) \<longleftrightarrow> (p\<longleftrightarrow>q\<longleftrightarrow>r) \<and> \<not>(p\<and>q\<and>r)"
proof
  assume "Exactly_1_of_3_holds(p,q,r)"
  then have
    "(p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"
    unfolding Exactly_1_of_3_holds_def by fast
  thus "(p\<longleftrightarrow>q\<longleftrightarrow>r) \<and> \<not>(p\<and>q\<and>r)" by blast
next assume "(p\<longleftrightarrow>q\<longleftrightarrow>r) \<and> \<not>(p\<and>q\<and>r)"
  hence
    "(p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"
    by auto
  then show "Exactly_1_of_3_holds(p,q,r)"
    unfolding Exactly_1_of_3_holds_def by fast
qed

text\<open>A property of the \<open>Exactly_1_of_3_holds\<close> predicate.\<close>

lemma Fol1_L8A: assumes A1: "Exactly_1_of_3_holds(p,q,r)"
  shows "p \<longleftrightarrow> \<not>(q \<or> r)"
proof -
  from A1 have "(p\<or>q\<or>r) \<and> (p \<longrightarrow> \<not>q \<and> \<not>r) \<and> (q \<longrightarrow> \<not>p \<and> \<not>r) \<and> (r \<longrightarrow> \<not>p \<and> \<not>q)"
    unfolding Exactly_1_of_3_holds_def by fast
  then show "p \<longleftrightarrow> \<not>(q \<or> r)" by blast
qed

text\<open>Exclusive or definition. There is one also defined in the standard
  Isabelle, denoted \<open>xor\<close>, but it relates to boolean values,
  which are sets. Here we define a logical functor.\<close>

definition
  Xor (infixl "Xor" 66) where
  "p Xor q \<equiv> (p\<or>q) \<and> \<not>(p \<and> q)"

text\<open>The "exclusive or" is the same as negation of equivalence.\<close>

lemma Fol1_L9: shows "p Xor q \<longleftrightarrow> \<not>(p\<longleftrightarrow>q)"
  using Xor_def by auto

text\<open>Equivalence relations are symmetric.\<close>

lemma equiv_is_sym: assumes A1: "equiv(X,r)" and A2: "\<langle>x,y\<rangle> \<in> r"
  shows  "\<langle>y,x\<rangle> \<in> r"
proof -
  from A1 have "sym(r)" using equiv_def by simp
  then have "\<forall>x y. \<langle>x,y\<rangle> \<in> r \<longrightarrow> \<langle>y,x\<rangle> \<in> r"
    unfolding sym_def by fast
  with A2 show "\<langle>y,x\<rangle> \<in> r" by blast
qed

(* In Isabelle/ZF conjunction associates to the right!.
lemma test: assumes A1: "P" "Q\<and>R"
  shows "P\<and>Q\<and>R"
proof -
  from A1 show "P\<and>Q\<and>R" by (rule one_more_conj);
qed;

*)
end


theory Proof_5_13
  imports Proofs_5
begin

abbreviation s where "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value \<equiv>
 (toEnv
   (setPstate
     (setVarBool
       (setVarBool
         (setVarBool (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value)
           up' DOWN')
         moving' DOWN')
       direction'
       (getVarBool
         (setVarBool
           (setVarBool (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value)
             up' DOWN')
           moving' DOWN')
         directionSwitch'))
     ERROR Ctrl'motionless))"

theorem proof_5_13: "VC13 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC13_def inv5_def R5_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
   apply((drule conjE)+)
                      prefer 33
                      apply assumption
                      prefer 32
                      apply assumption
                      prefer 31
                      apply assumption
                     prefer 30
                      apply assumption
                      prefer 29
                      apply assumption
                      prefer 28
                      apply assumption
                      prefer 27
                      apply assumption
                      prefer 26
                      apply assumption
                      prefer 25
                      apply assumption
                      prefer 24
                      apply assumption
                      prefer 23
                      apply assumption
                      prefer 22
                      apply assumption
                      prefer 21
                      apply assumption
                      prefer 20
                      apply assumption
                     prefer 19
                     apply assumption
                    prefer 18
                    apply assumption
                   prefer 17
                   apply assumption
                  prefer 16
                  apply assumption
                 prefer 15
                 apply assumption
                prefer 14
                apply assumption
               prefer 13
               apply assumption
              prefer 12
              apply assumption
             prefer 11
             apply assumption
            prefer 10
            apply assumption
           prefer 9
           apply assumption
          prefer 8
          apply assumption
         prefer 7
         apply assumption
        prefer 6
        apply assumption
       prefer 5
       apply assumption
      prefer 4
      apply assumption
     prefer 3
     apply assumption
    prefer 2
    apply assumption
  subgoal premises prems for s1 s2
    apply(rule disjE[OF le_imp_less_or_eq[OF prems(12)]])
 apply(rule cut_rl[of " \<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4  s0 \<and>
         toEnvNum s2 s4 \<le> ERROR \<and>
         getVarBool s4 up' = DOWN' \<and>
         getVarBool s4 down' = DOWN' \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 up' = UP' \<or> getVarBool s3 down' = UP')"])
      apply(drule exE)
       prefer 2
       apply assumption
    subgoal for s4
      apply(rule exI[of _ s4])
      by simp
    using prems(2) prems(4) prems(6) prems(8) prems(10) prems(16) prems(13) prems(14) apply -[1]
     apply(drule allE[of _ s1])
      prefer 2
      apply assumption
     apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply(simp split: if_splits)
    apply(rule cut_rl[of "\<forall> s5. toEnvP s5 \<and> substate s2 s5 \<and> substate s5
 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) \<longrightarrow>
 pred5 s1 s2
 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) s5"])
     apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply(drule impE)
       prefer 3
       apply assumption
    using prems(4,8) substate_refl apply fast
     apply(simp only: pred5_def)
     apply(drule impE)
       prefer 3
       apply assumption
    using prems(2)  prems(4) prems(6) prems(8) prems(10) prems(13) prems(14) substate_refl substate_trans substate_antisym
      apply blast
     apply fast
      apply(rule allI)
    subgoal premises toEnvNums2s for s5
      apply(induction rule: state_down_ind)
      using prems(8) apply simp
      apply(simp only: pred5_def)
       apply(rule impI)
       apply((drule conjE)+)
                  prefer 12
                  apply assumption
                 prefer 11
                 apply assumption
                prefer 10
                apply assumption
               prefer 9
               apply assumption
              prefer 8
              apply assumption
             prefer 7
             apply assumption
            prefer 6
            apply assumption
           prefer 5
           apply assumption
          prefer 4
          apply assumption
         prefer 3
         apply assumption
        prefer 2
        apply assumption

       apply(rule exI[of _ "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"])
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
        apply simp
       apply(rule conjI)
      using prems(9) apply(simp split: if_splits)
      using prems
        apply (metis substate_refl)
      using substate_trans substate_antisym apply blast

      subgoal for s5
        apply(simp only: pred5_def)
        apply(rule impI)
        apply(cases "getVarBool (predEnv s5) up' = False  \<and> getVarBool (predEnv s5) down' = False")
       apply(rule exI[of _ "predEnv s5"])
       apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
        apply blast
       apply(rule conjI)
      using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) "]
        apply force
       apply(rule conjI)
        apply fast
       apply(rule conjI)
        apply fast
      using substate_antisym apply fast
      apply(drule impE)
        apply(((rule conjI),blast)+)
      using substate_eq_or_predEnv apply blast
      prefer 2
       apply assumption
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
       apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        apply((drule conjE)+)
                          prefer 20
                           apply assumption
                          prefer 19
                          apply assumption
                         prefer 18
                         apply assumption
                        prefer 17
                        apply assumption
                       prefer 16
                       apply assumption
                      prefer 15
                      apply assumption
                     prefer 14
                     apply assumption
                    prefer 13
                    apply assumption
                   prefer 12
                   apply assumption
                  prefer 11
                  apply assumption
                 prefer 10
                 apply assumption
                prefer 9
                apply assumption
               prefer 8
               apply assumption
              prefer 7
              apply assumption
             prefer 6
             apply assumption
            prefer 5
            apply assumption
           prefer 4
           apply assumption
          prefer 3
          apply assumption
         prefer 2
         apply assumption
        using predEnv_substate_imp_eq_or_substate by blast
      done
    done
  done


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nat_min_max_distrib
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun le :: "Nat => Nat => bool" where
"le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

theorem property0 :
  "((let y2 :: Nat = (if le y z then y else z)
     in (if le x y2 then y2 else x)) =
      (if le x z then
         (let x3 :: Nat = (if le x y then y else x)
          in % (y4 :: Nat) => (if le x3 y4 then x3 else y4))
         z
         else
         (let x2 :: Nat = (if le x y then y else x)
          in % (y3 :: Nat) => (if le x2 y3 then x2 else y3))
         x))"
  oops

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005 (modified)    |
            |                 August 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_mono
imports CSP_F_domain CSP_T.CSP_T_mono
begin

(*****************************************************************

         1. mono check of failuresfun
         2.
         3.
         4.

 *****************************************************************)

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

lemma mono_failures_STOP: "mono (failures (STOP))"
by (simp add: mono_def failures_iff)

lemma mono_failures_SKIP: "mono (failures (SKIP))"
by (simp add: mono_def failures_iff)

lemma mono_failures_DIV: "mono (failures (DIV))"
by (simp add: mono_def failures_iff)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma mono_failures_Act_prefix:
 "mono (failures P) ==> mono (failures (a -> P))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (simp)
apply (rule)
apply (simp add: in_failures)
apply (auto)
done

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

lemma mono_failures_Ext_pre_choice:
 "ALL a. mono (failures (Pf a))
  ==> mono (failures (? a:X -> (Pf a)))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (erule disjE, simp)
apply (rule disjI2)
apply (elim conjE exE)
apply (drule_tac x="a" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (auto)
done

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

lemma mono_failures_Ext_choice:
 "[| mono (traces P) ; mono (traces Q) ;
     mono (failures P) ; mono (failures Q) |]
  ==> mono (failures (P [+] Q))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="(fstF o x)" in spec)
apply (drule_tac x="(fstF o x)" in spec)
apply (drule_tac x="(fstF o y)" in spec)
apply (drule_tac x="(fstF o y)" in spec)
apply (simp add: order_prod_def mono_fstF[simplified mono_def])
apply (elim conjE disjE)
apply (force)+
done

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

lemma mono_failures_Int_choice:
 "[| mono (failures P) ; mono (failures Q) |]
  ==> mono (failures (P |~| Q))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (elim disjE)
apply (force)
apply (force)
done

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

lemma mono_failures_Rep_int_choice:
 "ALL c. mono (failures (Pf c))
  ==> mono (failures (!! c:C .. (Pf c)))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (elim conjE bexE)
apply (drule_tac x="c" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (auto)
done

(*--------------------------------*
 |              IF                |
 *--------------------------------*)

lemma mono_failures_IF:
 "[| mono (failures P) ; mono (failures Q) |]
  ==> mono (failures (IF b THEN P ELSE Q))"
apply (simp add: mono_def)
apply (auto simp add: in_failures subsetF_iff)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

lemma mono_failures_Parallel:
 "[| mono (failures P) ; mono (failures Q) |]
  ==> mono (failures (P |[X]| Q))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (elim conjE exE)
apply (rule_tac x="Y" in exI)
apply (rule_tac x="Z" in exI)
apply (simp)
apply (rule_tac x="sa" in exI)
apply (rule_tac x="t" in exI)
apply (auto simp add: subsetF_iff)
done

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

lemma mono_failures_Hiding:
 "mono (failures P)
  ==> mono (failures (P -- X))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (auto simp add: subsetF_iff)
done

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

lemma mono_failures_Renaming:
 "mono (failures P)
  ==> mono (failures (P [[r]]))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (auto simp add: subsetF_iff)
done

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

lemma mono_failures_Seq_compo:
 "[| mono (failures P) ; mono (failures Q) |]
  ==> mono (failures (P ;; Q))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)

apply (erule disjE)
apply (simp add: subsetF_iff)
apply (elim conjE exE)
apply (rule disjI2)
apply (rule_tac x="sa" in exI)
apply (rule_tac x="t" in exI)
apply (drule_tac x="x" in spec)
apply (drule_tac x="x" in spec)
apply (drule_tac x="y" in spec)
apply (drule_tac x="y" in spec)
apply (simp)

apply (subgoal_tac "traces P (fstF o x) <= traces P (fstF o y)")
apply (force)
apply (subgoal_tac "fstF o x <= fstF o y")
apply (simp add: mono_traces[simplified mono_def])
apply (simp add: order_prod_def)
apply (rule allI)
apply (drule_tac x="xa" in spec)
apply (simp add: mono_fstF[simplified mono_def])
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

lemma mono_failures_Depth_rest:
 "mono (failures P)
  ==> mono (failures (P |. n))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (elim conjE exE disjE)
apply (force)
apply (force)
done

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

lemma mono_failures_variable:
   "mono (failures ($p))"
apply (simp add: mono_def)
apply (intro allI impI)
apply (rule)
apply (simp add: in_failures)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)
apply (insert mono_sndF)
apply (simp add: mono_def)
apply (drule_tac x="x p" in spec)
apply (drule_tac x="y p" in spec)
apply (simp add: subsetF_iff order_prod_def)
done

(*--------------------------------*
 |            Procfun             |
 *--------------------------------*)

lemma mono_failures: "mono (failures P)"
apply (induct_tac P)
apply (simp add: mono_failures_STOP)
apply (simp add: mono_failures_SKIP)
apply (simp add: mono_failures_DIV)
apply (simp add: mono_failures_Act_prefix)
apply (simp add: mono_failures_Ext_pre_choice)
apply (simp add: mono_failures_Ext_choice mono_traces)
apply (simp add: mono_failures_Int_choice)
apply (simp add: mono_failures_Rep_int_choice)
apply (simp add: mono_failures_IF)
apply (simp add: mono_failures_Parallel)
apply (simp add: mono_failures_Hiding)
apply (simp add: mono_failures_Renaming)
apply (simp add: mono_failures_Seq_compo mono_traces)
apply (simp add: mono_failures_Depth_rest)
apply (simp add: mono_failures_variable)
done

(*=============================================================*
 |                         [[P]]Ff                             |
 *=============================================================*)

lemma mono_semFf: "mono [[Pf]]Ff"
apply (simp add: mono_def)
apply (simp add: subdomF_decompo)
apply (intro allI impI)

apply (simp add: mono_failures[simplified mono_def])

apply (subgoal_tac "mono (traces Pf)")
apply (simp add: mono_def)
apply (drule_tac x="fstF o x" in spec)
apply (drule_tac x="fstF o y" in spec)
apply (drule mp)

 apply (simp add: order_prod_def)
 apply (simp add: mono_fstF[simplified mono_def])
 apply (simp)

apply (simp add: mono_traces)
done

(*=============================================================*
 |                         [[P]]Ffun                           |
 *=============================================================*)

lemma mono_semFfun: "mono [[PF]]Ffun"
apply (simp add: prod_mono)
apply (simp add: semFfun_def)
apply (simp add: comp_def)
apply (simp add: proj_fun_def)
apply (simp add: mono_semFf)
done

end