(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Chain
  imports "HOL-Nominal.Nominal"
begin

lemma pt_set_nil:
  fixes Xs :: "'a set"
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "([]::'x prm)\<bullet>Xs = Xs"
by(auto simp add: perm_set_def pt1[OF pt])

lemma pt_set_append:
  fixes pi1 :: "'x prm"
  and   pi2 :: "'x prm"
  and   Xs  :: "'a set"
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "(pi1@pi2)\<bullet>Xs = pi1\<bullet>(pi2\<bullet>Xs)"
by(auto simp add: perm_set_def pt2[OF pt])

lemma pt_set_prm_eq:
  fixes pi1 :: "'x prm"
  and   pi2 :: "'x prm"
  and   Xs  :: "'a set"
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "pi1 \<triangleq> pi2  \<Longrightarrow> pi1\<bullet>Xs = pi2\<bullet>Xs"
by(auto simp add: perm_set_def pt3[OF pt])

lemma pt_set_inst:
  assumes pt: "pt TYPE('a) TYPE ('x)"
  and     at: "at TYPE('x)"

  shows "pt TYPE('a set) TYPE('x)"
apply(simp add: pt_def pt_set_nil[OF pt, OF at] pt_set_append[OF pt, OF at])
apply(clarify)
by(rule pt_set_prm_eq[OF pt, OF at])

lemma pt_ball_eqvt:
  fixes pi :: "'a prm"
  and   Xs :: "'b set"
  and   P :: "'b \<Rightarrow> bool"

  assumes pt: "pt TYPE('b) TYPE('a)"
  and     at: "at TYPE('a)"

  shows "(pi \<bullet> (\<forall>x \<in> Xs. P x)) = (\<forall>x \<in> (pi \<bullet> Xs). pi \<bullet> P (rev pi \<bullet> x))"
apply(auto simp add: perm_bool)
apply(drule_tac pi="rev pi" in pt_set_bij2[OF pt, OF at])
apply(simp add: pt_rev_pi[OF pt_set_inst[OF pt, OF at], OF at])
apply(drule_tac pi="pi" in pt_set_bij2[OF pt, OF at])
apply(erule_tac x="pi \<bullet> x" in ballE)
apply(simp add: pt_rev_pi[OF pt, OF at])
by simp

lemma perm_cart_prod:
  fixes Xs :: "'b set"
  and   Ys :: "'c set"
  and   p  :: "'a prm"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"

  shows "(p \<bullet> (Xs \<times> Ys)) = (((p \<bullet> Xs) \<times> (p \<bullet> Ys))::(('b \<times> 'c) set))"
by(auto simp add: perm_set_def)

lemma supp_member:
  fixes Xs :: "'b set"
  and   x  :: 'a

  assumes pt: "pt TYPE('b) TYPE('a)"
  and     at: "at TYPE('a)"
  and     fs: "fs TYPE('b) TYPE('a)"
  and     "finite Xs"
  and     "x \<in> ((supp Xs)::'a set)"

  obtains X where "(X::'b) \<in> Xs" and "x \<in> supp X"
proof -
  from \<open>finite Xs\<close> \<open>x \<in> supp Xs\<close> have "\<exists>X::'b. (X \<in> Xs) \<and> (x \<in> (supp X))"
  proof(induct rule: finite_induct)
    case empty
    from \<open>x \<in> ((supp {})::'a set)\<close> have False
      by(simp add: supp_set_empty)
    thus ?case by simp
  next
    case(insert y Xs)
    show ?case
    proof(case_tac "x \<in> supp y")
      assume "x \<in> supp y"
      thus ?case by force
    next
      assume "x \<notin> supp y"
      with \<open>x \<in> supp(insert y Xs)\<close> have "x \<in> supp Xs"
        by(simp add: supp_fin_insert[OF pt, OF at, OF fs, OF \<open>finite Xs\<close>])
      with \<open>x \<in> supp Xs \<Longrightarrow> \<exists>X. X \<in> Xs \<and> x \<in> supp X\<close>
      show ?case by force
    qed
  qed
  with that show ?thesis by blast
qed

lemma supp_cart_prod_empty[simp]:
  fixes Xs :: "'b set"

  shows "supp (Xs \<times> {}) = ({}::'a set)"
  and   "supp ({} \<times> Xs) = ({}::'a set)"
by(auto simp add: supp_set_empty)

lemma supp_cart_prod:
  fixes Xs :: "'b set"
  and   Ys :: "'c set"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     fs1: "fs TYPE('b) TYPE('a)"
  and     fs2: "fs TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"
  and     f1:  "finite Xs"
  and     f2:  "finite Ys"
  and     a:   "Xs \<noteq> {}"
  and     b:   "Ys \<noteq> {}"

  shows "((supp (Xs \<times> Ys))::'a set) = ((supp Xs) \<union> (supp Ys))"
proof -
  from f1 f2 have f3: "finite(Xs \<times> Ys)" by simp
  show ?thesis
    apply(simp add: supp_of_fin_sets[OF pt_prod_inst[OF pt1, OF pt2], OF at, OF fs_prod_inst[OF fs1, OF fs2], OF f3] supp_prod)
    apply(rule equalityI)
    using Union_included_in_supp[OF pt1, OF at, OF fs1, OF f1] Union_included_in_supp[OF pt2, OF at, OF fs2, OF f2]
    apply(force simp add: supp_prod)
    using a b
    apply(auto simp add: supp_prod)
    using supp_member[OF pt1, OF at, OF fs1, OF f1]
    apply blast
    using supp_member[OF pt2, OF at, OF fs2, OF f2]
    by blast
qed

lemma fresh_cart_prod:
  fixes x  :: 'a
  and   Xs :: "'b set"
  and   Ys :: "'c set"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     fs1: "fs TYPE('b) TYPE('a)"
  and     fs2: "fs TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"
  and     f1:  "finite Xs"
  and     f2:  "finite Ys"
  and     a:   "Xs \<noteq> {}"
  and     b:   "Ys \<noteq> {}"

  shows "(x \<sharp> (Xs \<times> Ys)) = (x \<sharp> Xs \<and> x \<sharp> Ys)"
using assms
by(simp add: supp_cart_prod fresh_def)

lemma fresh_star_cart_prod:
  fixes Zs   :: "'a set"
  and   xvec :: "'a list"
  and   Xs   :: "'b set"
  and   Ys   :: "'c set"

  assumes pt1: "pt TYPE('b) TYPE('a)"
  and     pt2: "pt TYPE('c) TYPE('a)"
  and     fs1: "fs TYPE('b) TYPE('a)"
  and     fs2: "fs TYPE('c) TYPE('a)"
  and     at:  "at TYPE('a)"
  and     f1:  "finite Xs"
  and     f2:  "finite Ys"
  and     a:   "Xs \<noteq> {}"
  and     b:   "Ys \<noteq> {}"

  shows "(Zs \<sharp>* (Xs \<times> Ys)) = (Zs \<sharp>* Xs \<and> Zs \<sharp>* Ys)"
  and   "(xvec \<sharp>* (Xs \<times> Ys)) = (xvec \<sharp>* Xs \<and> xvec \<sharp>* Ys)"
using assms
by(force simp add: fresh_cart_prod fresh_star_def)+

lemma permCommute:
  fixes p  :: "'a prm"
  and   q  :: "'a prm"
  and   P  :: 'x
  and   Xs :: "'a set"
  and   Ys :: "'a set"

  assumes pt: "pt TYPE('x) TYPE('a)"
  and     at: "at TYPE('a)"
  and     a: "(set p) \<subseteq> Xs \<times> Ys"
  and     b: "Xs \<sharp>* q"
  and     c: "Ys \<sharp>* q"

  shows "p \<bullet> q \<bullet> P = q \<bullet> p \<bullet> P"
proof -
  have "p \<bullet> q \<bullet> P = (p \<bullet> q) \<bullet> p \<bullet> P"
    by(rule pt_perm_compose[OF pt, OF at])
  moreover from at have "pt TYPE('a) TYPE('a)"
    by(rule at_pt_inst)
  hence "pt TYPE(('a \<times> 'a) list) TYPE('a)"
    by(force intro: pt_prod_inst pt_list_inst)
  hence "p \<bullet> q = q" using at a b c
    by(rule pt_freshs_freshs)
  ultimately show ?thesis by simp
qed

definition
  distinctPerm :: "'a prm \<Rightarrow> bool" where
  "distinctPerm p \<equiv> distinct((map fst p)@(map snd p))"

lemma at_set_avoiding_aux':
  fixes Xs::"'a set"
  and   As::"'a set"
  assumes at: "at TYPE('a)"
  and     a: "finite Xs"
  and     b: "Xs \<subseteq> As"
  and     c: "finite As"
  and     d: "finite ((supp c)::'a set)"
  shows "\<exists>(Ys::'a set) (pi::'a prm). Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> (pi\<bullet>Xs=Ys) \<and>
          set pi \<subseteq> Xs \<times> Ys \<and> finite Ys \<and> (distinctPerm pi)"
using a b c
proof (induct)
  case empty
  have "({}::'a set)\<sharp>*c" by (simp add: fresh_star_def)
  moreover
  have "({}::'a set) \<inter> As = {}" by simp
  moreover
  have "([]::'a prm)\<bullet>{} = ({}::'a set)"
    by(rule pt1) (metis Nominal.pt_set_inst at at_pt_inst)
  moreover
  have "set ([]::'a prm) \<subseteq> {} \<times> {}" by simp
  moreover
  have "finite ({}::'a set)" by simp
  moreover have "distinctPerm([]::'a prm)"
    by(simp add: distinctPerm_def)
  ultimately show ?case by blast
next
  case (insert x Xs)
  then have ih: "\<exists>Ys pi. Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> pi\<bullet>Xs = Ys \<and> set pi \<subseteq> Xs \<times> Ys \<and> finite Ys \<and> distinctPerm pi" by simp
  then obtain Ys pi where a1: "Ys\<sharp>*c" and a2: "Ys \<inter> As = {}" and a3: "(pi::'a prm)\<bullet>Xs = Ys" and
                          a4: "set pi \<subseteq> Xs \<times> Ys" and a5: "finite Ys"
                      and a6: "distinctPerm pi" by blast
  have b: "x\<notin>Xs" by fact
  have d1: "finite As" by fact
  have d2: "finite Xs" by fact
  have d3: "insert x Xs \<subseteq> As" by fact
  have d4: "finite((supp pi)::'a set)"
    by(induct pi)
      (auto simp add: supp_list_nil supp_prod at_fin_set_supp[OF at]
                      supp_list_cons at_supp[OF at])
  have "\<exists>y::'a. y\<sharp>(c,x,Ys,As,pi)" using d d1 a5 d4
    by (rule_tac at_exists_fresh'[OF at])
       (simp add: supp_prod at_supp[OF at] at_fin_set_supp[OF at])
  then obtain y::"'a" where  e: "y\<sharp>(c,x,Ys,As,pi)" by blast
  have "({y}\<union>Ys)\<sharp>*c" using a1 e by (simp add: fresh_star_def)
  moreover
  have "({y}\<union>Ys)\<inter>As = {}" using a2 d1 e by (simp add: fresh_prod at_fin_set_fresh[OF at])
  moreover
  have "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys"
  proof -
    have eq: "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
    proof -
      have "(pi\<bullet>x)\<sharp>Ys" using a3[symmetric] b d2
        by(simp add: pt_fresh_bij[OF pt_set_inst, OF at_pt_inst[OF at], OF at, OF at]
                     at_fin_set_fresh[OF at d2])
      moreover
      have "y\<sharp>Ys" using e by simp
      ultimately show "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
        by (simp add: pt_fresh_fresh[OF pt_set_inst, OF at_pt_inst[OF at], OF at, OF at])
    qed
    have "(((pi\<bullet>x,y)#pi)\<bullet>({x}\<union>Xs)) = ([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>({x}\<union>Xs)))"
      by (simp add: pt2[symmetric, OF pt_set_inst, OF at_pt_inst[OF at], OF at])
    also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs))"
      by (simp only: union_eqvt perm_set_def at_calc[OF at])(auto)
    also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>Ys)" using a3 by simp
    also have "\<dots> = {y}\<union>Ys" using eq by simp
    finally show "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys" by auto
  qed
  moreover
  have "pi\<bullet>x=x" using a4 b a2 a3 d3 by (rule_tac at_prm_fresh2[OF at]) (auto)
  then have "set ((pi\<bullet>x,y)#pi) \<subseteq> (insert x Xs) \<times> ({y}\<union>Ys)" using a4 by auto
  moreover
  have "finite ({y}\<union>Ys)" using a5 by simp
  moreover from \<open>Ys \<inter> As = {}\<close> \<open>(insert x Xs) \<subseteq> As\<close> \<open>finite Ys\<close> have "x \<notin> Ys"
    by(auto simp add: fresh_def at_fin_set_supp[OF at])
  with a6 \<open>pi \<bullet> x = x\<close> \<open>x \<notin> Xs\<close> \<open>(set pi) \<subseteq> Xs \<times> Ys\<close> e have "distinctPerm((pi \<bullet> x, y)#pi)"
    apply(auto simp add: distinctPerm_def fresh_prod at_fresh[OF at])
    proof -
      fix a b
      assume "b \<sharp> pi" and "(a, b) \<in> set pi"
      thus False
        by(induct pi)
          (auto simp add: supp_list_cons supp_prod at_supp[OF at] fresh_list_cons fresh_prod at_fresh[OF at])
    next
      fix a b
      assume "a \<sharp> pi" and "(a, b) \<in> set pi"
      thus False
        by(induct pi)
          (auto simp add: supp_list_cons supp_prod at_supp[OF at] fresh_list_cons fresh_prod at_fresh[OF at])
    qed
  ultimately
  show ?case by blast
qed

lemma at_set_avoiding:
  fixes Xs::"'a set"
  assumes at: "at TYPE('a)"
  and     a: "finite Xs"
  and     b: "finite ((supp c)::'a set)"
  obtains pi::"'a prm" where "(pi \<bullet> Xs) \<sharp>* c" and "set pi \<subseteq> Xs \<times> (pi \<bullet> Xs)" and "distinctPerm pi"
  using a b
  by (frule_tac As="Xs" in at_set_avoiding_aux'[OF at]) auto

lemma pt_swap:
  fixes x :: 'a
  and a :: 'x
  and b :: 'x

  assumes pt: "pt TYPE('a) TYPE('x)"
  and     at: "at TYPE('x)"

  shows "[(a, b)] \<bullet> x = [(b, a)] \<bullet> x"
proof -
  show ?thesis by(simp add: pt3[OF pt] at_ds5[OF at])
qed

atom_decl name

lemma supp_subset:
  fixes Xs :: "'a::fs_name set"
  and   Ys :: "'a::fs_name set"

  assumes "Xs \<subseteq> Ys"
  and     "finite Xs"
  and     "finite Ys"

  shows "(supp Xs) \<subseteq> ((supp Ys)::name set)"
proof(rule subsetI)
  fix x
  assume "x \<in> ((supp Xs)::name set)"
  with \<open>finite Xs\<close> obtain X where "X \<in> Xs" and "x \<in> supp X"
    by(rule supp_member[OF pt_name_inst, OF at_name_inst, OF fs_name_inst])
  from \<open>X \<in> Xs\<close> \<open>Xs \<subseteq> Ys\<close> have "X \<in> Ys" by auto
  with \<open>finite Ys\<close> \<open>x \<in> supp X\<close> show "x \<in> supp Ys"
    by(induct rule: finite_induct)
      (auto simp add: supp_fin_insert[OF pt_name_inst, OF at_name_inst, OF fs_name_inst])
qed

abbreviation mem_def :: "'a \<Rightarrow> 'a list \<Rightarrow> bool" ("_ mem _" [80, 80] 80)  where
  "x mem xs \<equiv> x \<in> set xs"

lemma memFresh:
  fixes x :: name
  and   p :: "'a::fs_name"
  and   l :: "('a::fs_name) list"

  assumes "x \<sharp> l"
  and     "p mem l"

  shows "x \<sharp> p"
using assms
by(induct l, auto simp add: fresh_list_cons)

lemma memFreshChain:
  fixes xvec :: "name list"
  and   p    :: "'a::fs_name"
  and   l    :: "'a::fs_name list"
  and   Xs   :: "name set"

  assumes "p mem l"

  shows "xvec \<sharp>* l \<Longrightarrow> xvec \<sharp>* p"
  and   "Xs \<sharp>* l \<Longrightarrow> Xs \<sharp>* p"
using assms
by(auto simp add: fresh_star_def intro: memFresh)

lemma fresh_star_list_append[simp]:
  fixes A :: "name list"
  and   B :: "name list"
  and   C :: "name list"

  shows "(A \<sharp>* (B @ C)) = ((A \<sharp>* B) \<and> (A \<sharp>* C))"
by(auto simp add: fresh_star_def fresh_list_append)

lemma unionSimps[simp]:
  fixes Xs :: "name set"
  and   Ys :: "name set"
  and   C  :: "'a::fs_name"

  shows "((Xs \<union> Ys) \<sharp>* C) = ((Xs \<sharp>* C) \<and> (Ys \<sharp>* C))"
by(auto simp add: fresh_star_def)

lemma substFreshAux[simp]:
  fixes C    :: "'a::fs_name"
  and   xvec :: "name list"

  shows "xvec \<sharp>* (supp C - set xvec)"
by(auto simp add: fresh_star_def fresh_def at_fin_set_supp[OF at_name_inst] fs_name1)

lemma fresh_star_perm_app[simp]:
  fixes Xs :: "name set"
  and   xvec :: "name list"
  and   p  :: "name prm"
  and   C  :: "'d::fs_name"

  shows "\<lbrakk>Xs \<sharp>* p; Xs \<sharp>* C\<rbrakk> \<Longrightarrow> Xs \<sharp>* (p \<bullet> C)"
  and   "\<lbrakk>xvec \<sharp>* p; xvec \<sharp>* C\<rbrakk> \<Longrightarrow> xvec \<sharp>* (p \<bullet> C)"
by(auto simp add: fresh_star_def fresh_perm_app)

lemma freshSets[simp]:
  fixes x    :: name
  and   y    :: name
  and   xvec :: "name list"
  and   X    :: "name set"
  and   C    :: 'a

  shows "([]::name list) \<sharp>* C"
  and   "([]::name list) \<sharp>* [y].C"
  and   "({}::name set) \<sharp>* C"
  and   "({}::name set) \<sharp>* [y].C"
  and   "((x#xvec) \<sharp>* C) = (x \<sharp> C \<and> xvec \<sharp>* C)"
  and   "((x#xvec) \<sharp>* ([y].C)) = (x \<sharp> ([y].C) \<and> xvec \<sharp>* ([y].C))"
  and   "((insert x X) \<sharp>* C) = (x \<sharp> C \<and> X \<sharp>* C)"
  and   "((insert x X) \<sharp>* ([y].C)) = (x \<sharp> ([y].C) \<and> X \<sharp>* ([y].C))"
by(auto simp add: fresh_star_def)

lemma freshStarAtom[simp]: "(xvec::name list) \<sharp>* (x::name) = x \<sharp> xvec"
by(induct xvec)
  (auto simp add: fresh_list_nil fresh_list_cons fresh_atm)

lemma name_list_set_fresh[simp]:
  fixes xvec :: "name list"
  and   x    :: "'a::fs_name"

  shows "(set xvec) \<sharp>* x = xvec \<sharp>* x"
by(auto simp add: fresh_star_def)

lemma name_list_supp:
  fixes xvec :: "name list"

  shows "set xvec = supp xvec"
proof -
  have "set xvec = supp(set xvec)"
    by(simp add: at_fin_set_supp[OF at_name_inst])
  moreover have "\<dots> = supp xvec"
    by(simp add: pt_list_set_supp[OF pt_name_inst, OF at_name_inst, OF fs_name_inst])
  ultimately show ?thesis
    by simp
qed

lemma abs_fresh_list_star:
  fixes xvec :: "name list"
  and   a    :: name
  and   P    :: "'a::fs_name"

  shows "(xvec \<sharp>* [a].P) = ((set xvec) - {a}) \<sharp>* P"
by(induct xvec) (auto simp add: fresh_star_def abs_fresh)

lemma abs_fresh_set_star:
  fixes X :: "name set"
  and   a :: name
  and   P :: "'a::fs_name"

  shows "(X \<sharp>* [a].P) = (X - {a}) \<sharp>* P"
by(auto simp add: fresh_star_def abs_fresh)

lemmas abs_fresh_star = abs_fresh_list_star abs_fresh_set_star

lemma abs_fresh_list_star'[simp]:
  fixes xvec :: "name list"
  and   a    :: name
  and   P    :: "'a::fs_name"

  assumes "a \<sharp> xvec"

  shows "xvec \<sharp>* [a].P = xvec \<sharp>* P"
using assms
by(induct xvec) (auto simp add: abs_fresh fresh_list_cons fresh_atm)

lemma freshChainSym[simp]:
  fixes xvec :: "name list"
  and   yvec :: "name list"

  shows   "xvec \<sharp>* yvec = yvec \<sharp>* xvec"
by(auto simp add: fresh_star_def fresh_def name_list_supp)

lemmas [eqvt] = perm_cart_prod[OF pt_name_inst, OF pt_name_inst, OF at_name_inst]

lemma name_set_avoiding:
  fixes c :: "'a::fs_name"
  and   X :: "name set"

  assumes "finite X"
  and     "\<And>pi::name prm. \<lbrakk>(pi \<bullet> X) \<sharp>* c; distinctPerm pi; set pi \<subseteq> X \<times> (pi \<bullet> X)\<rbrakk> \<Longrightarrow> thesis"

  shows thesis
using assms
by(rule_tac c=c in at_set_avoiding[OF at_name_inst]) (simp_all add: fs_name1)

lemmas simps[simp] = fresh_atm fresh_prod
                     pt3[OF pt_name_inst, OF at_ds1, OF at_name_inst]
                     pt_fresh_fresh[OF pt_name_inst, OF at_name_inst]
                     pt_rev_pi[OF pt_name_inst, OF at_name_inst]
                     pt_pi_rev[OF pt_name_inst, OF at_name_inst]

lemmas name_supp_cart_prod = supp_cart_prod[OF pt_name_inst, OF pt_name_inst, OF fs_name_inst, OF fs_name_inst, OF at_name_inst]
lemmas name_fresh_cart_prod = fresh_cart_prod[OF pt_name_inst, OF pt_name_inst, OF fs_name_inst, OF fs_name_inst, OF at_name_inst]
lemmas name_fresh_star_cart_prod = fresh_star_cart_prod[OF pt_name_inst, OF pt_name_inst, OF fs_name_inst, OF fs_name_inst, OF at_name_inst]

lemmas name_swap_bij[simp] = pt_swap_bij[OF pt_name_inst, OF at_name_inst]
lemmas name_swap = pt_swap[OF pt_name_inst, OF at_name_inst]
lemmas name_set_fresh_fresh[simp] = pt_freshs_freshs[OF pt_name_inst, OF at_name_inst]
lemmas list_fresh[simp] = fresh_list_nil fresh_list_cons fresh_list_append

definition  eqvt :: "'a::fs_name set \<Rightarrow> bool" where
                  "eqvt X \<equiv> \<forall>x \<in> X. \<forall>p::name prm. p \<bullet> x \<in> X"

lemma eqvtUnion[intro]:
  fixes Rel  :: "('d::fs_name) set"
  and   Rel' :: "'d set"

  assumes EqvtRel:  "eqvt Rel"
  and     EqvtRel': "eqvt Rel'"

  shows "eqvt (Rel \<union> Rel')"
using assms
by(force simp add: eqvt_def)

lemma eqvtPerm[simp]:
  fixes X :: "('d::fs_name) set"
  and   x :: name
  and   y :: name

  assumes "eqvt X"

  shows "([(x, y)] \<bullet> X) = X"
using assms
apply(auto simp add: eqvt_def)
apply(erule_tac x="[(x, y)] \<bullet> xa" in ballE)
apply(erule_tac x="[(x, y)]" in allE)
apply simp
apply(drule_tac pi="[(x, y)]" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply simp
apply(erule_tac x=xa in ballE)
apply(erule_tac x="[(x, y)]" in allE)
apply(drule_tac pi="[(x, y)]" and x="[(x, y)] \<bullet> xa" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply simp
by simp

lemma eqvtI:
  fixes X :: "'d::fs_name set"
  and   x :: 'd
  and   p :: "name prm"

  assumes "eqvt X"
  and     "x \<in> X"

  shows "(p \<bullet> x) \<in> X"
using assms
by(unfold eqvt_def) auto

lemma fresh_star_list_nil[simp]:
  fixes xvec :: "name list"
  and   Xs   :: "name set"

  shows "xvec \<sharp>* []"
  and   "Xs \<sharp>* []"
by(auto simp add: fresh_star_def)

lemma fresh_star_list_cons[simp]:
  fixes xvec :: "name list"
  and   Xs   :: "name set"
  and   x    :: "'a::fs_name"
  and   xs   :: "'a list"

  shows "(xvec \<sharp>* (x#xs)) = ((xvec \<sharp>* x) \<and> xvec \<sharp>* xs)"
  and   "(Xs \<sharp>* (x#xs)) = ((Xs \<sharp>* x) \<and> (Xs \<sharp>* xs))"
by(auto simp add: fresh_star_def)

lemma freshStarPair[simp]:
  fixes X    :: "name set"
  and   xvec :: "name list"
  and   x    :: "'a::fs_name"
  and   y    :: "'b::fs_name"

  shows "(X \<sharp>* (x, y)) = (X \<sharp>* x \<and> X \<sharp>* y)"
  and   "(xvec \<sharp>* (x, y)) = (xvec \<sharp>* x \<and> xvec \<sharp>* y)"
by(auto simp add: fresh_star_def)
lemma name_list_avoiding:
  fixes c    :: "'a::fs_name"
  and   xvec :: "name list"

  assumes "\<And>pi::name prm. \<lbrakk>(pi \<bullet> xvec) \<sharp>* c; distinctPerm pi; set pi \<subseteq> (set xvec) \<times> (set (pi \<bullet> xvec))\<rbrakk> \<Longrightarrow> thesis"

  shows thesis
proof -
  have "finite(set xvec)" by simp
  thus ?thesis using assms
    by(rule name_set_avoiding) (auto simp add: eqvts fresh_star_def)
qed

lemma distinctPermSimps[simp]:
  fixes p :: "name prm"
  and   a :: name
  and   b :: name

  shows "distinctPerm([]::name prm)"
  and   "(distinctPerm((a, b)#p)) = (distinctPerm p \<and> a \<noteq> b \<and> a \<sharp> p \<and> b \<sharp> p)"
apply(simp add: distinctPerm_def)
apply(induct p)
apply(unfold distinctPerm_def)
apply(clarsimp)
apply(rule iffI, erule iffE)
by(clarsimp)+

lemma map_eqvt[eqvt]:
  fixes p   :: "name prm"
  and   lst :: "'a::pt_name list"

  shows "(p \<bullet> (map f lst)) = map (p \<bullet> f) (p \<bullet> lst)"
apply(induct lst, auto)
by(simp add: pt_fun_app_eq[OF pt_name_inst, OF at_name_inst])

lemma consPerm:
  fixes x :: name
  and   y :: name
  and   p :: "name prm"
  and   C :: "'a::pt_name"

  shows "((x, y)#p) \<bullet> C = [(x, y)] \<bullet> p \<bullet> C"
by(simp add: pt2[OF pt_name_inst, THEN sym])

simproc_setup consPerm ("((x, y)#p) \<bullet> C") = \<open>
  fn _ => fn _ => fn ct =>
    case Thm.term_of ct of
      Const (@{const_name perm}, _ ) $ (Const (@{const_name Cons}, _) $ _ $ p) $ _ =>
        (case p of
          Const (@{const_name Nil}, _) => NONE
        | _ => SOME(mk_meta_eq @{thm consPerm}))
    | _ => NONE
\<close>

lemma distinctEqvt[eqvt]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "(p \<bullet> (distinct xs)) = distinct (p \<bullet> xs)"
by(induct xs) (auto simp add: eqvts)

lemma distinctClosed[simp]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "distinct (p \<bullet> xs) = distinct xs"
apply(induct xs)
apply(auto simp add: eqvts)
apply(drule_tac pi=p in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply(simp add: eqvts)
apply(drule_tac pi="rev p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
by(simp add: eqvts)

lemma lengthEqvt[eqvt]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "p \<bullet> (length xs) = length (p \<bullet> xs)"
by(induct xs) (auto simp add: eqvts)

lemma lengthClosed[simp]:
  fixes p  :: "name prm"
  and   xs :: "'a::pt_name list"

  shows "length (p \<bullet> xs) = length xs"
by(induct xs) (auto simp add: eqvts)

lemma subsetEqvt[eqvt]:
  fixes p :: "name prm"
  and   S :: "('a::pt_name) set"
  and   T :: "('a::pt_name) set"

  shows "(p \<bullet> (S \<subseteq> T)) = ((p \<bullet> S) \<subseteq> (p \<bullet> T))"
by(rule pt_subseteq_eqvt[OF pt_name_inst, OF at_name_inst])

lemma subsetClosed[simp]:
  fixes p :: "name prm"
  and   S :: "('a::pt_name) set"
  and   T :: "('a::pt_name) set"

  shows "((p \<bullet> S) \<subseteq> (p \<bullet> T)) = (S \<subseteq> T)"
apply auto
apply(drule_tac pi=p in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply(insert pt_set_bij[OF pt_name_inst, OF at_name_inst])
apply auto
apply(drule_tac pi="rev p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply auto
apply(subgoal_tac "rev p \<bullet> x \<in> T")
apply auto
apply(drule_tac pi="p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
apply auto
apply(drule_tac pi="p" in pt_set_bij2[OF pt_name_inst, OF at_name_inst])
by auto

  shows "(set (p \<bullet> xvec) \<subseteq> supp (p \<bullet> P)) = (set xvec \<subseteq> supp P)"
by(simp add: eqvts[THEN sym])

lemma memEqvt[eqvt]:
  fixes p  :: "name prm"
  and   x  :: "'a::pt_name"
  and   xs :: "('a::pt_name) list"

  shows "(p \<bullet> (x mem xs)) = ((p \<bullet> x) mem (p \<bullet> xs))"
by(induct xs)
  (auto simp add: pt_bij[OF pt_name_inst, OF at_name_inst] eqvts)

lemma memClosed[simp]:
  fixes p  :: "name prm"
  and   x  :: "'a::pt_name"
  and   xs :: "('a::pt_name) list"

  shows "(p \<bullet> x) mem (p \<bullet> xs) = (x mem xs)"
proof -
  have "x mem xs = p \<bullet> (x mem xs)"
    by(case_tac "x mem xs") auto
  thus ?thesis by(simp add: eqvts)
qed

lemma memClosed'[simp]:
  fixes p  :: "name prm"
  and   x  :: "'a::pt_name"
  and   y  :: "'b::pt_name"
  and   xs :: "('a \<times>  'b) list"

  shows "((p \<bullet> x, p \<bullet> y) mem (p \<bullet> xs)) = ((x, y) mem xs)"
apply(subgoal_tac "((x, y) mem xs) = (p \<bullet> (x, y)) mem (p \<bullet> xs)")
apply force
by(force simp del: eqvts)

lemma freshPerm:
  fixes x :: name
  and   p :: "name prm"

  assumes "x \<sharp> p"

  shows "p \<bullet> x = x"
using assms
apply(rule_tac pt_pi_fresh_fresh[OF pt_name_inst, OF at_name_inst])
by(induct p, auto simp add: fresh_list_cons fresh_prod)

lemma freshChainPermSimp:
  fixes xvec :: "name list"
  and   p    :: "name prm"

  assumes "xvec \<sharp>* p"

  shows "p \<bullet> xvec = xvec"
  and   "rev p \<bullet> xvec = xvec"
using assms
by(induct xvec) (auto simp add: freshPerm pt_bij1[OF pt_name_inst, OF at_name_inst, THEN sym])

lemma freshChainAppend[simp]:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   C    :: "'a::fs_name"

  shows "(xvec@yvec) \<sharp>* C = ((xvec \<sharp>* C) \<and> (yvec \<sharp>* C))"
by(force simp add: fresh_star_def)

lemma subsetFresh:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   C    :: "'d::fs_name"

  assumes "set xvec \<subseteq> set yvec"
  and     "yvec \<sharp>* C"

  shows "xvec \<sharp>* C"
using assms
by(auto simp add: fresh_star_def)

lemma distinctPermCancel[simp]:
  fixes p :: "name prm"
  and   T :: "'a::pt_name"

  assumes "distinctPerm p"

  shows "(p \<bullet> (p \<bullet> T)) = T"
using assms
proof(induct p)
  case Nil
  show ?case by simp
next
  case(Cons a p)
  thus ?case
  proof(case_tac a, auto)
    fix a b
    assume "(a::name) \<sharp> (p::name prm)" "b \<sharp> p" "p \<bullet> p \<bullet> T = T" "a \<noteq> b"
    thus "[(a, b)] \<bullet> p \<bullet> [(a, b)] \<bullet> p \<bullet> T = T"
      by(subst pt_perm_compose[OF pt_name_inst, OF at_name_inst]) simp
  qed
qed

fun composePerm :: "name list \<Rightarrow> name list \<Rightarrow> name prm"
where
  Base:  "composePerm [] [] = []"
| Step:  "composePerm (x#xs) (y#ys) = (x, y)#(composePerm xs ys)"
| Empty: "composePerm _ _= []"

lemma composePermInduct[consumes 1, case_names cBase cStep]:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   P    :: "name list \<Rightarrow> name list \<Rightarrow> bool"

  assumes L: "length xvec = length yvec"
  and     rBase: "P [] []"
  and     rStep: "\<And>x xvec y yvec. \<lbrakk>length xvec = length yvec; P xvec yvec\<rbrakk> \<Longrightarrow> P (x # xvec) (y # yvec)"

  shows "P xvec yvec"
using assms
by(induct rule: composePerm.induct) auto

lemma composePermEqvt[eqvt]:
  fixes p    :: "name prm"
  and   xvec :: "name list"
  and   yvec :: "name list"

  shows "(p \<bullet> (composePerm xvec yvec)) = composePerm (p \<bullet> xvec) (p \<bullet> yvec)"
by(induct xvec yvec rule: composePerm.induct) auto

abbreviation
  composePermJudge ("[_ _] \<bullet>\<^sub>v _" [80, 80, 80] 80) where "[xvec yvec] \<bullet>\<^sub>v p \<equiv> (composePerm xvec yvec) \<bullet> p"

abbreviation
  composePermInvJudge ("[_ _]\<^sup>- \<bullet>\<^sub>v _" [80, 80, 80] 80) where "[xvec yvec]\<^sup>- \<bullet>\<^sub>v p \<equiv> (rev (composePerm xvec yvec)) \<bullet> p"

lemma permChainSimps[simp]:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   perm :: "name prm"
  and   p    :: "'a::pt_name"

  shows "((composePerm xvec yvec) @ perm) \<bullet> p = [xvec yvec] \<bullet>\<^sub>v (perm \<bullet> p)"
by(simp add: pt2[OF pt_name_inst])

lemma permChainEqvt[eqvt]:
  fixes p    :: "name prm"
  and   xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: "'a::pt_name"

  shows "(p \<bullet> ([xvec yvec] \<bullet>\<^sub>v x)) = [(p \<bullet> xvec) (p \<bullet> yvec)] \<bullet>\<^sub>v (p \<bullet> x)"
  and   "(p \<bullet> ([xvec yvec]\<^sup>- \<bullet>\<^sub>v x)) = [(p \<bullet> xvec) (p \<bullet> yvec)]\<^sup>- \<bullet>\<^sub>v (p \<bullet> x)"
by(subst pt_perm_compose[OF pt_name_inst, OF at_name_inst], simp add: eqvts rev_eqvt)+

lemma permChainBij:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"
  and   q    :: "'a::pt_name"

  assumes "length xvec = length yvec"

  shows "(([xvec yvec] \<bullet>\<^sub>v p) = ([xvec yvec] \<bullet>\<^sub>v q)) = (p = q)"
  and   "(([xvec yvec]\<^sup>- \<bullet>\<^sub>v p) = ([xvec yvec]\<^sup>- \<bullet>\<^sub>v q)) = (p = q)"
using assms
by(induct rule: composePermInduct)
  (auto simp add: pt_bij[OF pt_name_inst, OF at_name_inst])

lemma permChainAppend:
  fixes xvec1 :: "name list"
  and   yvec1 :: "name list"
  and   xvec2 :: "name list"
  and   yvec2 :: "name list"
  and   p     :: "'a::pt_name"

  assumes "length xvec1 = length yvec1"

  shows "([(xvec1@xvec2) (yvec1@yvec2)] \<bullet>\<^sub>v p) = [xvec1 yvec1] \<bullet>\<^sub>v [xvec2 yvec2] \<bullet>\<^sub>v p"
  and   "([(xvec1@xvec2) (yvec1@yvec2)]\<^sup>- \<bullet>\<^sub>v p) = [xvec2 yvec2]\<^sup>- \<bullet>\<^sub>v [xvec1 yvec1]\<^sup>- \<bullet>\<^sub>v p"
using assms
by(induct arbitrary: p rule: composePermInduct, auto) (simp add: pt2[OF pt_name_inst])

lemma calcChainAtom:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: name

  assumes "length xvec = length yvec"
  and     "x \<sharp> xvec"
  and     "x \<sharp> yvec"

  shows "[xvec yvec] \<bullet>\<^sub>v x = x"
using assms
by(induct rule: composePermInduct, auto)

lemma calcChainAtomRev:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: name

  assumes "length xvec = length yvec"
  and     "x \<sharp> xvec"
  and     "x \<sharp> yvec"

  shows "[xvec yvec]\<^sup>- \<bullet>\<^sub>v x = x"
using assms
by(induct rule: composePermInduct, auto)
  (auto simp add: pt2[OF pt_name_inst] fresh_list_cons calc_atm)

lemma permChainFresh[simp]:
  fixes x    :: name
  and   xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "x \<sharp> xvec"
  and     "x \<sharp> yvec"
  and     "length xvec = length yvec"

  shows "x \<sharp> [xvec yvec] \<bullet>\<^sub>v p = x \<sharp> p"
  and   "x \<sharp> [xvec yvec]\<^sup>- \<bullet>\<^sub>v p = x \<sharp> p"
using assms
by(auto simp add: fresh_left calcChainAtomRev calcChainAtom)

lemma chainFreshFresh:
  fixes x    :: name
  and   y    :: name
  and   xvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "x \<sharp> xvec"
  and     "y \<sharp> xvec"

  shows "xvec \<sharp>* ([(x, y)] \<bullet> p) = (xvec \<sharp>* p)"
using assms
by(induct xvec) (auto simp add: fresh_list_cons fresh_left)

lemma permChainFreshFresh:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "xvec \<sharp>* p"
  and     "yvec \<sharp>* p"
  and     "length xvec = length yvec"

  shows "[xvec yvec] \<bullet>\<^sub>v p = p"
  and   "[xvec yvec]\<^sup>- \<bullet>\<^sub>v p = p"
using assms
by(induct rule: composePerm.induct, auto) (simp add: pt2[OF pt_name_inst])

lemma setFresh[simp]:
  fixes x    :: name
  and   xvec :: "name list"

  shows "x \<notin> set xvec = x \<sharp> xvec"
by(simp add: name_list_supp fresh_def)

lemma calcChain:
  fixes xvec :: "name list"
  and   yvec :: "name list"

  assumes "yvec \<sharp>* xvec"
  and     "length xvec = length yvec"
  and     "distinct xvec"
  and     "distinct yvec"

  shows "[xvec yvec] \<bullet>\<^sub>v xvec = yvec"
using assms
by(induct xvec yvec rule: composePerm.induct, auto)
  (subst consPerm, simp add: calcChainAtom calc_atm name_list_supp fresh_def[symmetric])+

lemma freshChainPerm:
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   x    :: name
  and   C    :: "'a::pt_name"

  assumes "length xvec = length yvec"
  and     "yvec \<sharp>* C"
  and     "xvec \<sharp>* yvec"
  and     "x mem xvec"
  and     "distinct yvec"

  shows "x \<sharp> [xvec yvec] \<bullet>\<^sub>v C"
using assms
proof(induct rule: composePermInduct)
  case cBase
  have "x mem []" by fact
  hence False by simp
  thus ?case by simp
next
  case(cStep x' xvec y yvec)
  have "(y # yvec) \<sharp>* C" by fact
  hence yFreshC: "y \<sharp> C" and yvecFreshp: "yvec \<sharp>* C" by simp+
  have "(x' # xvec) \<sharp>* (y # yvec)" by fact
  hence x'ineqy: "x' \<noteq> y" and xvecFreshyvec: "xvec \<sharp>* yvec"
    and x'Freshyvec: "x' \<sharp> yvec" and yFreshxvec: "y \<sharp> xvec"
    by(auto simp add: fresh_list_cons)
  have "distinct (y#yvec)" by fact
  hence yFreshyvec: "y \<sharp> yvec" and yvecDist: "distinct yvec"
    by simp+
  have L: "length xvec = length yvec" by fact
  have "x \<sharp> [(x', y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v C"
  proof(case_tac "x = x'")
    assume xeqx': "x = x'"
    moreover from yFreshxvec yFreshyvec yFreshC L have "y \<sharp> [xvec yvec] \<bullet>\<^sub>v C"
      by simp
    hence "([(x, y)] \<bullet> y) \<sharp> [(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v C"
      by(rule pt_fresh_bij1[OF pt_name_inst, OF at_name_inst])
    with x'ineqy xeqx' show ?thesis by(simp add: calc_atm)
  next
    assume xineqx': "x \<noteq> x'"
    have "x mem (x' # xvec)" by fact
    with xineqx' have xmemxvec: "x mem xvec" by simp
    moreover have "\<lbrakk>yvec \<sharp>* C; xvec \<sharp>* yvec; x mem xvec; distinct yvec\<rbrakk> \<Longrightarrow> x \<sharp> [xvec yvec] \<bullet>\<^sub>v C" by fact
    ultimately have "x \<sharp> [xvec yvec] \<bullet>\<^sub>v C" using yvecFreshp xvecFreshyvec yvecDist
      by simp
    hence "([(x', y)] \<bullet> x) \<sharp> [(x', y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v C"
      by(rule pt_fresh_bij1[OF pt_name_inst, OF at_name_inst])
    moreover from xmemxvec yFreshxvec have "x \<noteq> y"
      by(induct xvec) (auto simp add: fresh_list_cons)
    ultimately show ?thesis using xineqx' x'ineqy by(simp add: calc_atm)
  qed
  thus ?case by simp
qed

lemma memFreshSimp[simp]:
  fixes y    :: name
  and   yvec :: "name list"

  shows "(\<not>(y mem yvec)) = y \<sharp> yvec"
by(induct yvec)
  (auto simp add: fresh_list_nil fresh_list_cons)

lemma freshChainPerm':
  fixes xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "length xvec = length yvec"
  and     "yvec \<sharp>* p"
  and     "xvec \<sharp>* yvec"
  and     "distinct yvec"

  shows "xvec \<sharp>* ([xvec yvec] \<bullet>\<^sub>v p)"
using assms
proof(induct rule: composePermInduct)
  case cBase
  show ?case by simp
next
  case(cStep x xvec y yvec)
  have "(y # yvec) \<sharp>* p" by fact
  hence yFreshp: "y \<sharp> p" and yvecFreshp: "yvec \<sharp>* p"
    by simp+
  moreover have "(x # xvec) \<sharp>* (y # yvec)" by fact
  hence xineqy: "x \<noteq> y" and xvecFreshyvec: "xvec \<sharp>* yvec"
    and xFreshyvec: "x \<sharp> yvec" and yFreshxvec: "y \<sharp> xvec"
    by(auto simp add: fresh_list_cons)
  have "distinct (y # yvec)" by fact
  hence yFreshyvec: "y \<sharp> yvec" and yvecDist: "distinct yvec"
    by simp+
  have L: "length xvec = length yvec" by fact
  have "\<lbrakk>yvec \<sharp>* p; xvec \<sharp>* yvec; distinct yvec\<rbrakk> \<Longrightarrow> xvec \<sharp>* ([xvec yvec] \<bullet>\<^sub>v p)" by fact
  with yvecFreshp xvecFreshyvec yvecDist have IH: "xvec \<sharp>* ([xvec yvec] \<bullet>\<^sub>v p)" by simp
  show ?case
  proof(auto)
    from L yFreshp yvecFreshp xineqy xvecFreshyvec yvecDist yFreshyvec yFreshxvec xFreshyvec
    have "x \<sharp> [(x # xvec) (y # yvec)] \<bullet>\<^sub>v p"
      by(rule_tac freshChainPerm) (auto simp add: fresh_list_cons)
    thus "x \<sharp> [(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p" by simp
  next
    show "xvec \<sharp>* ([(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p)"
    proof(case_tac "x mem xvec")
      assume "x mem xvec"
      with L yvecFreshp xvecFreshyvec yvecDist xFreshyvec
      have"x \<sharp> [xvec yvec] \<bullet>\<^sub>v p"
        by(rule_tac freshChainPerm) (auto simp add: fresh_list_cons)
      moreover from yFreshxvec yFreshyvec yFreshp L
      have "y \<sharp> [xvec yvec] \<bullet>\<^sub>v p" by simp
      ultimately show ?thesis using IH
        by(subst consPerm) (simp add: perm_fresh_fresh)
    next
      assume "\<not>(x mem xvec)"
      hence xFreshxvec: "x \<sharp> xvec" by simp
      from IH have "([(x, y)] \<bullet> xvec) \<sharp>* ([(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p)"
        by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with xFreshxvec yFreshxvec show ?thesis by simp
    qed
  qed
qed

lemma permSym:
  fixes x    :: name
  and   y    :: name
  and   xvec :: "name list"
  and   yvec :: "name list"
  and   p    :: "'a::pt_name"

  assumes "x \<sharp> xvec"
  and     "x \<sharp> yvec"
  and     "y \<sharp> xvec"
  and     "y \<sharp> yvec"
  and     "length xvec = length yvec"

  shows "([(x, y)] \<bullet> [xvec yvec] \<bullet>\<^sub>v p) = [xvec yvec] \<bullet>\<^sub>v [(x, y)] \<bullet> p"
using assms
apply(induct rule: composePerm.induct, auto)
by(subst pt_perm_compose[OF pt_name_inst, OF at_name_inst]) simp

lemma distinctPermClosed[simp]:
  fixes p :: "name prm"
  and   q :: "name prm"

  assumes "distinctPerm p"

  shows "distinctPerm(q \<bullet> p)"
using assms
by(induct p) (auto simp add: pt_fresh_bij[OF pt_name_inst, OF at_name_inst] dest: pt_bij4[OF pt_name_inst, OF at_name_inst])

lemma freshStarSimps:
  fixes x  :: name
  and   Xs :: "name set"
  and   Ys :: "name set"
  and   C  :: "'a::fs_name"
  and   p  :: "name prm"

  assumes "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* x"
  and     "Ys \<sharp>* x"

  shows "x \<sharp> (p \<bullet> C) = x \<sharp> C"
using assms
by(subst  pt_fresh_bij[OF pt_name_inst, OF at_name_inst, symmetric, of _ C p]) simp

lemma freshStarChainSimps:
  fixes xvec :: "name list"
  and   Xs   :: "name set"
  and   Ys   :: "name set"
  and   C    :: "'a::fs_name"
  and   p    :: "name prm"

  assumes "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* xvec"
  and     "Ys \<sharp>* xvec"

  shows   "xvec \<sharp>* (p \<bullet> C) = xvec \<sharp>* C"
using assms
by(induct xvec) (auto simp add: freshStarSimps)

lemma permStarFresh:
  fixes xvec :: "name list"
  and   p    :: "name prm"
  and   T    :: "'a::pt_name"

  assumes "xvec \<sharp>* p"

  shows "xvec \<sharp>* (p \<bullet> T) = xvec \<sharp>* T"
using assms
by(induct p) (auto simp add: chainFreshFresh)

lemma swapStarFresh:
  fixes x :: name
  and   p :: "name prm"
  and   T :: "'a::pt_name"

  assumes "x \<sharp> p"

  shows "x \<sharp> (p \<bullet> T) = x \<sharp> T"
proof -
  from assms have "[x] \<sharp>* (p \<bullet> T) = [x] \<sharp>* T"
    by(rule_tac permStarFresh) auto
  thus ?thesis by simp
qed

lemmas freshChainSimps = freshStarSimps freshStarChainSimps permStarFresh swapStarFresh chainFreshFresh freshPerm subsetFresh

lemma freshAlphaPerm:
  fixes xvec :: "name list"
  and   Xs   :: "name set"
  and   Ys   :: "name set"
  and   p    :: "name prm"

  assumes S: "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* xvec"
  and     "Ys \<sharp>* xvec"

  shows "xvec \<sharp>* p"
using assms
apply(induct p)
by auto (simp add: fresh_star_def fresh_def name_list_supp supp_list_nil)+

lemma freshAlphaSwap:
  fixes x  :: name
  and   Xs :: "name set"
  and   Ys :: "name set"
  and   p  :: "name prm"

  assumes S: "set p \<subseteq> Xs \<times> Ys"
  and     "Xs \<sharp>* x"
  and     "Ys \<sharp>* x"

  shows "x \<sharp> p"
proof -
  from assms have "[x] \<sharp>* p"
    apply(rule_tac freshAlphaPerm)
    apply assumption
    by auto
  thus ?thesis by simp
qed

lemma setToListFresh[simp]:
  fixes xvec :: "name list"
  and   C    :: "'a::fs_name"
  and   yvec :: "name list"
  and   Xs   :: "name set"
  and   x    :: name

  shows "xvec \<sharp>* (set yvec) = xvec \<sharp>* yvec"
  and   "Xs \<sharp>* (set yvec) = Xs \<sharp>* yvec"
  and   "x \<sharp> (set yvec) = x \<sharp> yvec"
  and   "set xvec \<sharp>* Xs = xvec \<sharp>* Xs"
by(auto simp add: fresh_star_def name_list_supp fresh_def fs_name1 at_fin_set_supp[OF at_name_inst])

end


theory HEAP01Reify
imports HEAP1
begin

(*========================================================================*)
section {* Refinement L0-L1 definitions *}
(*========================================================================*)

(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
subsubsection {* State reification definitions *}
(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

definition
  retr0 :: "F1 \<Rightarrow> F0"
where
  "retr0 f1 = locs f1"

definition
  contiguous :: "nat set \<Rightarrow> bool"
where
  "contiguous F \<equiv> \<exists> m l . nat1 l \<and> F = locs_of m l"

definition
  non_abutting :: "nat set \<Rightarrow> nat set \<Rightarrow> bool"
where
  "non_abutting F F' \<equiv> (\<forall> x \<in> F . \<forall> y \<in> F' . x > y+1 \<or> y > x + 1)"

locale level01_new = level1_new + level0_new
locale level01_dispose = level1_dispose + level0_dispose

(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)
subsubsection {* VDM auxiliary functions *}
(* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ *)

(*========================================================================*)
section {* VDM proof obligations for L0-L1 refinement *}
(*========================================================================*)

text {* Because of the (yet to be resolved) locale dependency/usage, we will
        avoid adding locale-based POs
      *}

(* TODO: PUT in locale? *)
definition
  PO_l01_adequacy :: "bool"
where
  "PO_l01_adequacy \<equiv> (\<forall> f0 . F0_inv f0 \<longrightarrow> (\<exists>! f1. f0 = retr0 f1 \<and> F1_inv f1))"

(*
lemma "PO_l01_adequacy"
unfolding PO_l01_adequacy_def
apply auto
unfolding retr0_def
defer
find_theorems "locs _ = locs _"
oops
*)

(* TODO: PUT in locale? Do it separate first to avoid confusion of assumptions across 4 locales! *)
definition
  PO_l01_new_widen_pre :: "bool"
where
  "PO_l01_new_widen_pre \<equiv> (\<forall> f1 s1 . F1_inv f1 \<and> nat1 s1 \<and> new0_pre (retr0 f1) s1 \<longrightarrow> new1_pre f1 s1)"

definition
  PO_l01_new_narrow_post :: "bool"
where
  "PO_l01_new_narrow_post \<equiv> (\<forall> f1 f1' s1 r . F1_inv f1 \<and> F1_inv f1' \<and> nat1 s1 \<and>
                                 new0_pre (retr0 f1) s1 \<and> new1_post f1 s1 f1' r \<longrightarrow> new0_post (retr0 f1) s1 (retr0 f1') r)"

definition
  PO_l01_dispose_widen_pre :: "bool"
where
  "PO_l01_dispose_widen_pre \<equiv> (\<forall> f1 d1 s1 . F1_inv f1 \<and> nat1 s1 \<and>
                                    dispose0_pre (retr0 f1) d1 s1 \<longrightarrow> dispose1_pre f1 d1 s1)"

definition
  PO_l01_dispose_narrow_post :: "bool"
where
  "PO_l01_dispose_narrow_post \<equiv> (\<forall> f1 f1' d1 s1 . F1_inv f1 \<and> F1_inv f1' \<and> nat1 s1 \<and>
                                    dispose0_pre (retr0 f1) d1 s1 \<and> dispose1_post f1 d1 s1 f1' \<longrightarrow>
                                        dispose0_post (retr0 f1) d1 s1 (retr0 f1'))"

unused_thms

(*
lemma (in level1_dispose) "False"
nitpick [show_all]
oops
lemma (in level1_new) "False"
nitpick [show_all]
oops
*)
(* NOTE: Nitpick trick to see if any axiom involved in the locales is inconsistent.
         i.e. if axioms are inconsistent, then we shouldn't be able to find a mode
         for False. If we do, then the axioms are conistent (i.e. it's unprovable
         as it should be).
 *)
end


(*  Title:      HOL/Library/DAList_Multiset.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Multisets partially implemented by association lists\<close>

theory DAList_Multiset
imports Multiset DAList
begin

text \<open>Delete prexisting code equations\<close>

lemma [code, code del]: "{#} = {#}" ..

lemma [code, code del]: "single = single" ..

lemma [code, code del]: "plus = (plus :: 'a multiset \<Rightarrow> _)" ..

lemma [code, code del]: "minus = (minus :: 'a multiset \<Rightarrow> _)" ..

lemma [code, code del]: "inf = (inf :: 'a multiset \<Rightarrow> _)" ..

lemma [code, code del]: "sup = (sup :: 'a multiset \<Rightarrow> _)" ..

lemma [code, code del]: "image_mset = image_mset" ..

lemma [code, code del]: "Multiset.filter = Multiset.filter" ..

lemma [code, code del]: "count = count" ..

lemma [code, code del]: "mcard = mcard" ..

lemma [code, code del]: "msetsum = msetsum" ..

lemma [code, code del]: "msetprod = msetprod" ..

lemma [code, code del]: "set_of = set_of" ..

lemma [code, code del]: "sorted_list_of_multiset = sorted_list_of_multiset" ..

lemma [code, code del]: "ord_multiset_inst.less_eq_multiset = ord_multiset_inst.less_eq_multiset" ..

lemma [code, code del]: "ord_multiset_inst.less_multiset = ord_multiset_inst.less_multiset" ..

lemma [code, code del]: "equal_multiset_inst.equal_multiset = equal_multiset_inst.equal_multiset" ..

text \<open>Raw operations on lists\<close>

definition join_raw ::
    "('key \<Rightarrow> 'val \<times> 'val \<Rightarrow> 'val) \<Rightarrow>
      ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
  where "join_raw f xs ys = foldr (\<lambda>(k, v). map_default k v (\<lambda>v'. f k (v', v))) ys xs"

lemma join_raw_Nil [simp]: "join_raw f xs [] = xs"
  by (simp add: join_raw_def)

lemma join_raw_Cons [simp]:
  "join_raw f xs ((k, v) # ys) = map_default k v (\<lambda>v'. f k (v', v)) (join_raw f xs ys)"
  by (simp add: join_raw_def)

lemma map_of_join_raw:
  assumes "distinct (map fst ys)"
  shows "map_of (join_raw f xs ys) x =
    (case map_of xs x of
      None \<Rightarrow> map_of ys x
    | Some v \<Rightarrow> (case map_of ys x of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f x (v, v'))))"
  using assms
  apply (induct ys)
  apply (auto simp add: map_of_map_default split: option.split)
  apply (metis map_of_eq_None_iff option.simps(2) weak_map_of_SomeI)
  apply (metis Some_eq_map_of_iff map_of_eq_None_iff option.simps(2))
  done

lemma distinct_join_raw:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (join_raw f xs ys))"
  using assms
proof (induct ys)
  case Nil
  then show ?case by simp
next
  case (Cons y ys)
  then show ?case by (cases y) (simp add: distinct_map_default)
qed

definition "subtract_entries_raw xs ys = foldr (\<lambda>(k, v). AList.map_entry k (\<lambda>v'. v' - v)) ys xs"

lemma map_of_subtract_entries_raw:
  assumes "distinct (map fst ys)"
  shows "map_of (subtract_entries_raw xs ys) x =
    (case map_of xs x of
      None \<Rightarrow> None
    | Some v \<Rightarrow> (case map_of ys x of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (v - v')))"
  using assms
  unfolding subtract_entries_raw_def
  apply (induct ys)
  apply auto
  apply (simp split: option.split)
  apply (simp add: map_of_map_entry)
  apply (auto split: option.split)
  apply (metis map_of_eq_None_iff option.simps(3) option.simps(4))
  apply (metis map_of_eq_None_iff option.simps(4) option.simps(5))
  done

lemma distinct_subtract_entries_raw:
  assumes "distinct (map fst xs)"
  shows "distinct (map fst (subtract_entries_raw xs ys))"
  using assms
  unfolding subtract_entries_raw_def
  by (induct ys) (auto simp add: distinct_map_entry)

text \<open>Operations on alists with distinct keys\<close>

lift_definition join :: "('a \<Rightarrow> 'b \<times> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist"
  is join_raw
  by (simp add: distinct_join_raw)

lift_definition subtract_entries :: "('a, ('b :: minus)) alist \<Rightarrow> ('a, 'b) alist \<Rightarrow> ('a, 'b) alist"
  is subtract_entries_raw
  by (simp add: distinct_subtract_entries_raw)

text \<open>Implementing multisets by means of association lists\<close>

definition count_of :: "('a \<times> nat) list \<Rightarrow> 'a \<Rightarrow> nat"
  where "count_of xs x = (case map_of xs x of None \<Rightarrow> 0 | Some n \<Rightarrow> n)"

lemma count_of_multiset: "count_of xs \<in> multiset"
proof -
  let ?A = "{x::'a. 0 < (case map_of xs x of None \<Rightarrow> 0::nat | Some n \<Rightarrow> n)}"
  have "?A \<subseteq> dom (map_of xs)"
  proof
    fix x
    assume "x \<in> ?A"
    then have "0 < (case map_of xs x of None \<Rightarrow> 0::nat | Some n \<Rightarrow> n)"
      by simp
    then have "map_of xs x \<noteq> None"
      by (cases "map_of xs x") auto
    then show "x \<in> dom (map_of xs)"
      by auto
  qed
  with finite_dom_map_of [of xs] have "finite ?A"
    by (auto intro: finite_subset)
  then show ?thesis
    by (simp add: count_of_def fun_eq_iff multiset_def)
qed

lemma count_simps [simp]:
  "count_of [] = (\<lambda>_. 0)"
  "count_of ((x, n) # xs) = (\<lambda>y. if x = y then n else count_of xs y)"
  by (simp_all add: count_of_def fun_eq_iff)

lemma count_of_empty: "x \<notin> fst ` set xs \<Longrightarrow> count_of xs x = 0"
  by (induct xs) (simp_all add: count_of_def)

lemma count_of_filter: "count_of (List.filter (P \<circ> fst) xs) x = (if P x then count_of xs x else 0)"
  by (induct xs) auto

lemma count_of_map_default [simp]:
  "count_of (map_default x b (\<lambda>x. x + b) xs) y =
    (if x = y then count_of xs x + b else count_of xs y)"
  unfolding count_of_def by (simp add: map_of_map_default split: option.split)

lemma count_of_join_raw:
  "distinct (map fst ys) \<Longrightarrow>
    count_of xs x + count_of ys x = count_of (join_raw (\<lambda>x (x, y). x + y) xs ys) x"
  unfolding count_of_def by (simp add: map_of_join_raw split: option.split)

lemma count_of_subtract_entries_raw:
  "distinct (map fst ys) \<Longrightarrow>
    count_of xs x - count_of ys x = count_of (subtract_entries_raw xs ys) x"
  unfolding count_of_def by (simp add: map_of_subtract_entries_raw split: option.split)

text \<open>Code equations for multiset operations\<close>

definition Bag :: "('a, nat) alist \<Rightarrow> 'a multiset"
  where "Bag xs = Abs_multiset (count_of (DAList.impl_of xs))"

code_datatype Bag

lemma count_Bag [simp, code]: "count (Bag xs) = count_of (DAList.impl_of xs)"
  by (simp add: Bag_def count_of_multiset)

lemma Mempty_Bag [code]: "{#} = Bag (DAList.empty)"
  by (simp add: multiset_eq_iff alist.Alist_inverse DAList.empty_def)

lemma single_Bag [code]: "{#x#} = Bag (DAList.update x 1 DAList.empty)"
  by (simp add: multiset_eq_iff alist.Alist_inverse update.rep_eq empty.rep_eq)

lemma union_Bag [code]: "Bag xs + Bag ys = Bag (join (\<lambda>x (n1, n2). n1 + n2) xs ys)"
  by (rule multiset_eqI)
    (simp add: count_of_join_raw alist.Alist_inverse distinct_join_raw join_def)

lemma minus_Bag [code]: "Bag xs - Bag ys = Bag (subtract_entries xs ys)"
  by (rule multiset_eqI)
    (simp add: count_of_subtract_entries_raw alist.Alist_inverse
      distinct_subtract_entries_raw subtract_entries_def)

lemma filter_Bag [code]: "Multiset.filter P (Bag xs) = Bag (DAList.filter (P \<circ> fst) xs)"
  by (rule multiset_eqI) (simp add: count_of_filter DAList.filter.rep_eq)

lemma mset_eq [code]: "HOL.equal (m1::'a::equal multiset) m2 \<longleftrightarrow> m1 \<le> m2 \<and> m2 \<le> m1"
  by (metis equal_multiset_def eq_iff)

text \<open>By default the code for @{text "<"} is @{prop"xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> xs = ys"}.
With equality implemented by @{text"\<le>"}, this leads to three calls of  @{text"\<le>"}.
Here is a more efficient version:\<close>
lemma mset_less[code]: "xs < (ys :: 'a multiset) \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
  by (rule less_le_not_le)

lemma mset_less_eq_Bag0:
  "Bag xs \<le> A \<longleftrightarrow> (\<forall>(x, n) \<in> set (DAList.impl_of xs). count_of (DAList.impl_of xs) x \<le> count A x)"
    (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then show ?rhs by (auto simp add: mset_le_def)
next
  assume ?rhs
  show ?lhs
  proof (rule mset_less_eqI)
    fix x
    from \<open>?rhs\<close> have "count_of (DAList.impl_of xs) x \<le> count A x"
      by (cases "x \<in> fst ` set (DAList.impl_of xs)") (auto simp add: count_of_empty)
    then show "count (Bag xs) x \<le> count A x" by (simp add: mset_le_def)
  qed
qed

lemma mset_less_eq_Bag [code]:
  "Bag xs \<le> (A :: 'a multiset) \<longleftrightarrow> (\<forall>(x, n) \<in> set (DAList.impl_of xs). n \<le> count A x)"
proof -
  {
    fix x n
    assume "(x,n) \<in> set (DAList.impl_of xs)"
    then have "count_of (DAList.impl_of xs) x = n"
    proof transfer
      fix x n
      fix xs :: "('a \<times> nat) list"
      show "(distinct \<circ> map fst) xs \<Longrightarrow> (x, n) \<in> set xs \<Longrightarrow> count_of xs x = n"
      proof (induct xs)
        case Nil
        then show ?case by simp
      next
        case (Cons ym ys)
        obtain y m where ym: "ym = (y,m)" by force
        note Cons = Cons[unfolded ym]
        show ?case
        proof (cases "x = y")
          case False
          with Cons show ?thesis
            unfolding ym by auto
        next
          case True
          with Cons(2-3) have "m = n" by force
          with True show ?thesis
            unfolding ym by auto
        qed
      qed
    qed
  }
  then show ?thesis
    unfolding mset_less_eq_Bag0 by auto
qed

declare multiset_inter_def [code]
declare sup_multiset_def [code]
declare multiset_of.simps [code]

fun fold_impl :: "('a \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a \<times> nat) list \<Rightarrow> 'b"
where
  "fold_impl fn e ((a,n) # ms) = (fold_impl fn ((fn a n) e) ms)"
| "fold_impl fn e [] = e"

definition fold :: "('a \<Rightarrow> nat \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> ('a, nat) alist \<Rightarrow> 'b"
  where "fold f e al = fold_impl f e (DAList.impl_of al)"

hide_const (open) fold

context comp_fun_commute
begin

lemma DAList_Multiset_fold:
  assumes fn: "\<And>a n x. fn a n x = (f a ^^ n) x"
  shows "Multiset.fold f e (Bag al) = DAList_Multiset.fold fn e al"
  unfolding DAList_Multiset.fold_def
proof (induct al)
  fix ys
  let ?inv = "{xs :: ('a \<times> nat) list. (distinct \<circ> map fst) xs}"
  note cs[simp del] = count_simps
  have count[simp]: "\<And>x. count (Abs_multiset (count_of x)) = count_of x"
    by (rule Abs_multiset_inverse[OF count_of_multiset])
  assume ys: "ys \<in> ?inv"
  then show "Multiset.fold f e (Bag (Alist ys)) = fold_impl fn e (DAList.impl_of (Alist ys))"
    unfolding Bag_def unfolding Alist_inverse[OF ys]
  proof (induct ys arbitrary: e rule: list.induct)
    case Nil
    show ?case
      by (rule trans[OF arg_cong[of _ "{#}" "Multiset.fold f e", OF multiset_eqI]])
         (auto, simp add: cs)
  next
    case (Cons pair ys e)
    obtain a n where pair: "pair = (a,n)"
      by force
    from fn[of a n] have [simp]: "fn a n = (f a ^^ n)"
      by auto
    have inv: "ys \<in> ?inv"
      using Cons(2) by auto
    note IH = Cons(1)[OF inv]
    def Ys \<equiv> "Abs_multiset (count_of ys)"
    have id: "Abs_multiset (count_of ((a, n) # ys)) = ((op + {# a #}) ^^ n) Ys"
      unfolding Ys_def
    proof (rule multiset_eqI, unfold count)
      fix c
      show "count_of ((a, n) # ys) c =
        count ((op + {#a#} ^^ n) (Abs_multiset (count_of ys))) c" (is "?l = ?r")
      proof (cases "c = a")
        case False
        then show ?thesis
          unfolding cs by (induct n) auto
      next
        case True
        then have "?l = n" by (simp add: cs)
        also have "n = ?r" unfolding True
        proof (induct n)
          case 0
          from Cons(2)[unfolded pair] have "a \<notin> fst ` set ys" by auto
          then show ?case by (induct ys) (simp, auto simp: cs)
        next
          case Suc
          then show ?case by simp
        qed
        finally show ?thesis .
      qed
    qed
    show ?case
      unfolding pair
      apply (simp add: IH[symmetric])
      unfolding id Ys_def[symmetric]
      apply (induct n)
      apply (auto simp: fold_mset_fun_left_comm[symmetric])
      done
  qed
qed

end

lift_definition single_alist_entry :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) alist" is "\<lambda>a b. [(a, b)]"
  by auto

lemma image_mset_Bag [code]:
  "image_mset f (Bag ms) =
    DAList_Multiset.fold (\<lambda>a n m. Bag (single_alist_entry (f a) n) + m) {#} ms"
  unfolding image_mset_def
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, (auto simp: ac_simps)[1])
  fix a n m
  show "Bag (single_alist_entry (f a) n) + m = ((op + \<circ> single \<circ> f) a ^^ n) m" (is "?l = ?r")
  proof (rule multiset_eqI)
    fix x
    have "count ?r x = (if x = f a then n + count m x else count m x)"
      by (induct n) auto
    also have "\<dots> = count ?l x"
      by (simp add: single_alist_entry.rep_eq)
    finally show "count ?l x = count ?r x" ..
  qed
qed

hide_const single_alist_entry

(* we cannot use (\<lambda>a n. op + (a * n)) for folding, since * is not defined
   in comm_monoid_add *)
lemma msetsum_Bag[code]: "msetsum (Bag ms) = DAList_Multiset.fold (\<lambda>a n. ((op + a) ^^ n)) 0 ms"
  unfolding msetsum.eq_fold
  apply (rule comp_fun_commute.DAList_Multiset_fold)
  apply unfold_locales
  apply (auto simp: ac_simps)
  done

(* we cannot use (\<lambda>a n. op * (a ^ n)) for folding, since ^ is not defined
   in comm_monoid_mult *)
lemma msetprod_Bag[code]: "msetprod (Bag ms) = DAList_Multiset.fold (\<lambda>a n. ((op * a) ^^ n)) 1 ms"
  unfolding msetprod.eq_fold
  apply (rule comp_fun_commute.DAList_Multiset_fold)
  apply unfold_locales
  apply (auto simp: ac_simps)
  done

lemma mcard_fold: "mcard A = Multiset.fold (\<lambda>_. Suc) 0 A" (is "_ = Multiset.fold ?f _ _")
proof -
  interpret comp_fun_commute ?f by default auto
  show ?thesis by (induct A) auto
qed

lemma mcard_Bag[code]: "mcard (Bag ms) = DAList_Multiset.fold (\<lambda>a n. op + n) 0 ms"
  unfolding mcard_fold
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, simp)
  fix a n x
  show "n + x = (Suc ^^ n) x"
    by (induct n) auto
qed

lemma set_of_fold: "set_of A = Multiset.fold insert {} A" (is "_ = Multiset.fold ?f _ _")
proof -
  interpret comp_fun_commute ?f by default auto
  show ?thesis by (induct A) auto
qed

lemma set_of_Bag[code]:
  "set_of (Bag ms) = DAList_Multiset.fold (\<lambda>a n. (if n = 0 then (\<lambda>m. m) else insert a)) {} ms"
  unfolding set_of_fold
proof (rule comp_fun_commute.DAList_Multiset_fold, unfold_locales, (auto simp: ac_simps)[1])
  fix a n x
  show "(if n = 0 then \<lambda>m. m else insert a) x = (insert a ^^ n) x" (is "?l n = ?r n")
  proof (cases n)
    case 0
    then show ?thesis by simp
  next
    case (Suc m)
    then have "?l n = insert a x" by simp
    moreover have "?r n = insert a x" unfolding Suc by (induct m) auto
    ultimately show ?thesis by auto
  qed
qed

instantiation multiset :: (exhaustive) exhaustive
begin

definition exhaustive_multiset ::
  "('a multiset \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
  where "exhaustive_multiset f i = Quickcheck_Exhaustive.exhaustive (\<lambda>xs. f (Bag xs)) i"

instance ..

end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |               December 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_step_ext
imports CSP_F_law_basic CSP_T.CSP_T_law_step_ext
begin

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

         1. step laws
         2.
         3.
         4.

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

(*********************************************************
              (P1 [> P2) |[X]| (Q1 [> Q2)
 *********************************************************)

(* The following law in p.288 does not hold.                               *)
(*     (P1 [> P2) |[X]| (Q1 [> Q2)                                         *)
(*  =F (P1 |[X]| Q1) [> ((P2 |[X]| (Q1 [> Q2)) |~| ((P1 [> P2) |[X]| Q2))  *)
(*                                                                         *)
(* a counter example:                                                      *)
(*  P1 = a -> STOP, P2 = STOP, Q1 = STOP, Q2 = b -> STOP, X = {}           *)
(*  where (a ~= b)                                                         *)
(*                                                                         *)
(*  check the following lemmas                                             *)

lemma "a ~= b ==>
       (<Ev a>, {(Ev b)}) ~:f
        failures ((a -> STOP [> STOP) |[{}]| (STOP [> (b -> STOP))) M"
apply (simp add: in_failures in_traces)
apply (intro allI impI)
apply (simp add: par_tr_Ev)
apply (erule disjE)
apply (auto)
done

lemma "(<Ev a>, {(Ev b)}) :f
       failures (((a -> STOP) |[{}]| STOP) [>
                 ((STOP |[{}]| (STOP [> (b -> STOP))) |~|
                  (((a -> STOP [> STOP) |[X]| (b -> STOP))))) M"
apply (simp add: in_failures in_traces)
apply (rule disjI1)
apply (rule_tac x="{(Ev b)}" in exI)
apply (rule_tac x="{(Ev b)}" in exI)
apply (simp)
apply (rule_tac x="<Ev a>" in exI)
apply (simp add: par_tr_nil_right)
done

(*********************************************************
              (P [> Q) |[X]| (? :Y -> Rf)
 *********************************************************)

(* The following law in p.289 does not hold.                               *)
(*                                                                         *)
(*     (P [> Q) |[X]| (? :Y -> Rf) =F[M,M]                                      *)
(*     (? x:(Y - X) -> ((P [> Q) |[X]| Rf x))                              *)
(*     [+] ((P |[X]| (? :Y -> Rf)) [> (Q |[X]| (? :Y -> Rf)))              *)
(*                                                                         *)
(* a counter example:                                                      *)
(*  P = STOP, Q = b -> STOP, Y = {a}, Rf = (%x. STOP), X = {}              *)
(*  where (a ~= b)                                                         *)
(*                                                                         *)
(*  check the following lemmas                                             *)

lemma "a ~= b ==>
      (<Ev a>, {(Ev b)}) ~:f
       failures ((STOP [> (b -> STOP)) |[{}]| (? x:{a} -> STOP)) M"
apply (simp add: in_failures in_traces)
apply (intro allI impI)
apply (simp add: par_tr_Ev)
apply (erule disjE)
apply (auto)
done

lemma "a ~= b ==>
       (<Ev a>, {(Ev b)}) :f
        failures ((? x:({a} - {}) -> ((STOP [>  (b -> STOP)) |[{}]| STOP))
                  [+] ((STOP |[{}]| (? x:{a} -> STOP))
                       [> ((b -> STOP) |[{}]| (? x:{a} -> STOP)))) M"
apply (fold Timeout_def)
apply (simp add: in_failures in_failures_Timeout in_traces)
apply (rule disjI2)
apply (rule disjI2)
apply (rule_tac x="{(Ev b)}" in exI)
apply (rule_tac x="{(Ev b)}" in exI)
apply (simp)
apply (rule_tac x="<Ev a>" in exI)
apply (simp add: par_tr_nil_left)
done

(*********************************************************
              Parallel expansion & distribbution
 *********************************************************)

lemma cspF_Parallel_Timeout_split:
  "((? :Y -> Pf) [> P) |[X]| ((? :Z -> Qf) [> Q) =F[M,M]
     (? x:((X Int Y Int Z) Un (Y - X) Un (Z - X))
         -> IF (x : X) THEN (Pf x |[X]| Qf x)
               ELSE IF (x : Y & x : Z) THEN ((Pf x |[X]| ((? x:Z -> Qf x) [> Q))
                                        |~| (((? x:Y -> Pf x) [> P) |[X]| Qf x))
               ELSE IF (x : Y) THEN (Pf x |[X]| ((? x:Z -> Qf x) [> Q))
               ELSE (((? x:Y -> Pf x) [> P) |[X]| Qf x))
     [> (((P |[X]| ((? :Z -> Qf) [> Q)) |~|
         (((? :Y -> Pf) [> P) |[X]| Q)))"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Parallel_Timeout_split)
apply (fold Timeout_def)
apply (rule order_antisym)

 (* => *)
 apply (rule)
 apply (simp add: in_failures_Timeout in_failures)
 apply (elim disjE conjE exE)
 apply (simp_all)

  apply (force)

  apply (rule disjI1)
  apply (rule_tac x="Y" in exI)
  apply (rule_tac x="Za" in exI)
  apply (simp)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<Ev a> ^^^ sb" in exI)
  apply (simp)

  apply (rule disjI1)
  apply (rule_tac x="Y" in exI)
  apply (rule_tac x="Za" in exI)
  apply (simp)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<>" in exI)
  apply (simp)

  apply (rule disjI2)
  apply (rule disjI1)
  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Z" in exI)
  apply (simp)
  apply (rule_tac x="<Ev a> ^^^ sb" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

  apply (rule disjI2)
  apply (rule disjI1)
  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Z" in exI)
  apply (simp)
  apply (rule_tac x="<>" in exI)
  apply (rule_tac x="t" in exI)
  apply (simp)

  (* main part *)

  apply (case_tac "s = <>", simp, simp)
  apply (rule disjI2)
  apply (rule disjI2)
  apply (simp add: par_tr_head_Ev_Ev)
  apply (elim exE disjE)
  apply (rule_tac x="c" in exI)
  apply (rule_tac x="v" in exI)
  apply (elim conjE disjE)

   (* sync *)
   apply (simp)
   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (force)

   (* left *)
   apply (simp)
   apply (case_tac "c:Z")

    apply (simp)
    apply (rule disjI1)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

    apply (simp)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

   (* right *)
   apply (simp)
   apply (case_tac "c:Y")

    apply (simp)
    apply (rule disjI2)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

    apply (simp)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

  (* others *)

  apply (simp add: in_traces)
  apply (simp add: in_traces)
  apply (simp add: in_traces)

(* <= *)
 apply (rule)
 apply (simp add: in_failures_Timeout in_failures)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  (* main part *)

  (* sync *)
  apply (simp add: in_failures_Parallel)
  apply (elim disjE conjE exE)
  apply (simp)
  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (simp)
  apply (rule_tac x="<Ev a> ^^^ sb" in exI)
  apply (rule_tac x="<Ev a> ^^^ t" in exI)
  apply (simp add: par_tr_head)

  (* no_sync *)
  apply (simp add: in_failures_IF)
  apply (case_tac "a:Z")

  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

  (* a ~: Z *)
  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

  apply (simp add: in_traces)

  (* no_sync *)
  apply (simp add: in_failures_IF)
  apply (case_tac "a:Y")

  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

  (* a ~: Y *)
  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

 (* others *)

 apply (simp add: in_traces)
done

(*********************************************************
            Parallel expansion & distribbution 2
 *********************************************************)

(*** left ****)

lemma cspF_Parallel_Timeout_input_l:
  "((? :Y -> Pf) [> P) |[X]| (? :Z -> Qf) =F[M,M]
     (? x:((X Int Y Int Z) Un (Y - X) Un (Z - X))
         -> IF (x : X) THEN (Pf x |[X]| Qf x)
               ELSE IF (x : Y & x : Z) THEN ((Pf x |[X]| (? x:Z -> Qf x))
                                        |~| (((? x:Y -> Pf x) [> P) |[X]| Qf x))
               ELSE IF (x : Y) THEN (Pf x |[X]| (? x:Z -> Qf x))
               ELSE (((? x:Y -> Pf x) [> P) |[X]| Qf x))
     [> (((P |[X]| (? :Z -> Qf))))"
apply (simp add: cspF_cspT_semantics)
apply (simp add: cspT_Parallel_Timeout_input)
apply (fold Timeout_def)
apply (rule order_antisym)

 (* => *)
 apply (rule)
 apply (simp add: in_failures_Timeout in_failures)
 apply (elim disjE conjE exE)
 apply (simp_all)

  apply (force)

  apply (rule disjI1)
  apply (rule_tac x="Y" in exI)
  apply (rule_tac x="Za" in exI)
  apply (simp)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<Ev a> ^^^ sb" in exI)
  apply (simp)

  apply (simp add: par_tr_nil_right)
  apply (rule disjI2)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="sb" in exI)
  apply (elim conjE)
  apply (simp add: image_iff)
  apply (case_tac "a : Z")
   apply (simp)
   apply (rule disjI1)
   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<>" in exI)
   apply (simp add: par_tr_nil_right)

   apply (simp)
   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<>" in exI)
   apply (simp add: par_tr_nil_right)

  apply (simp add: in_traces)

  (* main part *)

  apply (case_tac "s = <>", simp, simp)
  apply (rule disjI2)
  apply (simp add: par_tr_head_Ev_Ev)
  apply (elim exE disjE)
  apply (rule_tac x="c" in exI)
  apply (rule_tac x="v" in exI)
  apply (elim conjE disjE)

   (* sync *)
   apply (simp)
   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (force)

   (* left *)
   apply (simp)
   apply (case_tac "c:Z")

    apply (simp)
    apply (rule disjI1)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

    apply (simp)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

   (* right *)
   apply (simp)
   apply (case_tac "c:Y")

    apply (simp)
    apply (rule disjI2)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

    apply (simp)
    apply (rule_tac x="Ya" in exI)
    apply (rule_tac x="Za" in exI)
    apply (force)

  (* others *)

  apply (simp add: in_traces)

(* <= *)
 apply (rule)
 apply (simp add: in_failures_Timeout in_failures)
 apply (elim conjE exE disjE)
 apply (simp_all)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (simp)
  apply (rule_tac x="sa" in exI)
  apply (rule_tac x="<>" in exI)
  apply (simp)

  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (force)

  (* main part *)

  (* sync *)
  apply (simp add: in_failures_Parallel)
  apply (elim disjE conjE exE)
  apply (simp)
  apply (rule_tac x="Ya" in exI)
  apply (rule_tac x="Za" in exI)
  apply (simp)
  apply (rule_tac x="<Ev a> ^^^ sb" in exI)
  apply (rule_tac x="<Ev a> ^^^ t" in exI)
  apply (simp add: par_tr_head)

  (* no_sync *)
  apply (simp add: in_failures_IF)
  apply (case_tac "a:Z")

  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev aa> ^^^ sc" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (simp add: in_traces)

  (* a ~: Z *)
  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="<>" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

  apply (simp add: in_traces)

  (* no_sync *)
  apply (simp add: in_failures_IF)
  apply (case_tac "a:Y")

  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev a> ^^^ sb" in exI)
   apply (rule_tac x="<Ev aa> ^^^ sc" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev aa> ^^^ sc" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (simp add: in_traces)

  (* a ~: Y *)
  apply (simp add: in_failures_Timeout in_failures)
  apply (elim disjE conjE exE)
  apply (simp_all)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="sb" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (rule_tac x="Ya" in exI)
   apply (rule_tac x="Za" in exI)
   apply (simp)
   apply (rule_tac x="<Ev aa> ^^^ sc" in exI)
   apply (rule_tac x="<Ev a> ^^^ t" in exI)
   apply (simp add: par_tr_head)

   apply (simp add: in_traces)

 (* others *)

 apply (simp add: in_traces)
done

(*** right ****)

lemma cspF_Parallel_Timeout_input_r:
  "(? :Y -> Pf) |[X]| ((? :Z -> Qf) [> Q) =F[M,M]
     (? x:((X Int Y Int Z) Un (Y - X) Un (Z - X))
         -> IF (x : X) THEN (Pf x |[X]| Qf x)
               ELSE IF (x : Y & x : Z) THEN ((Pf x |[X]| ((? x:Z -> Qf x) [> Q))
                                        |~| ((? x:Y -> Pf x) |[X]| Qf x))
               ELSE IF (x : Y) THEN (Pf x |[X]| ((? x:Z -> Qf x) [> Q))
               ELSE ((? x:Y -> Pf x) |[X]| Qf x))
     [> ((? :Y -> Pf) |[X]| Q)"
apply (rule cspF_rw_left)
apply (rule cspF_commut)
apply (rule cspF_rw_left)
apply (rule cspF_Parallel_Timeout_input_l)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (rule cspF_decompo)
apply (force)
apply (rule cspF_decompo)
apply (simp)
apply (rule cspF_commut)

apply (case_tac "a : Z & a : Y")
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_IF_True)
apply (rule cspF_rw_right)
apply (rule cspF_IF_True)
apply (rule cspF_rw_left)
apply (rule cspF_commut)
apply (rule cspF_decompo)
apply (rule cspF_commut)
apply (rule cspF_commut)

apply (simp (no_asm_simp))
apply (rule cspF_rw_left)
apply (rule cspF_IF_False)
apply (rule cspF_rw_right)
apply (subgoal_tac "~ (a : Y & a : Z)")
apply (simp (no_asm_simp))
apply (rule cspF_IF_False)
apply (force)

apply (case_tac "a : Z")
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_IF_True)
apply (rule cspF_rw_right)
apply (rule cspF_IF_False)
apply (rule cspF_commut)
apply (simp)
apply (rule cspF_rw_left)
apply (rule cspF_IF_False)
apply (rule cspF_rw_right)
apply (rule cspF_IF_True)
apply (rule cspF_commut)

apply (rule cspF_reflex)
apply (rule cspF_commut)
done

lemmas cspF_Parallel_Timeout_input
     = cspF_Parallel_Timeout_input_l
       cspF_Parallel_Timeout_input_r

(*** cspF_step_ext ***)

lemmas cspF_step_ext = cspF_Parallel_Timeout_split
                       cspF_Parallel_Timeout_input

end


theory Incredible_Predicate_Tasks
imports
  Incredible_Completeness
  Incredible_Predicate
  "HOL-Eisbach.Eisbach"
begin

declare One_nat_def [simp del]

context ND_Rules_Inst begin
lemma eff_NatRuleI:
  "nat_rule rule c ants
    \<Longrightarrow> entail = (\<Gamma> \<turnstile> subst s (freshen a c))
    \<Longrightarrow> hyps = ((\<lambda>ant. ((\<lambda>p. subst s (freshen a p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen a (a_conc ant)))) |`| ants)
    \<Longrightarrow> (\<And> ant f. ant |\<in>| ants \<Longrightarrow> f |\<in>| \<Gamma> \<Longrightarrow> freshenLC a ` (a_fresh ant) \<inter> lconsts f = {})
    \<Longrightarrow> (\<And> ant. ant |\<in>| ants \<Longrightarrow> freshenLC a ` (a_fresh ant) \<inter> subst_lconsts s = {})
    \<Longrightarrow> eff (NatRule rule) entail hyps"
  by (drule eff.intros(2)) simp_all
end

context Abstract_Task begin
lemma  natEff_InstI:
  "rule = (r,c)
  \<Longrightarrow> c \<in> set (consequent r)
  \<Longrightarrow> antec = f_antecedent r
  \<Longrightarrow> natEff_Inst rule c antec"
  by (metis natEff_Inst.intros)
end

context begin

text \<open>A typical task with local constants:: \<open>\<forall>x. Q x \<longrightarrow> Q x\<close>\<close>

text \<open>First the task is defined as an @{term Abstract_Task}.\<close>

interpretation task: Abstract_Task
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  antecedent
  consequent
  prop_rules
  "[]"
  "[ForallX (imp (Q x) (Q x))]"
by unfold_locales auto

text \<open>Then we show, that this task has a proof within our formalization of natural deduction
  by giving a concrete proof tree.\<close>

abbreviation lx :: "nat" where "lx \<equiv> to_nat (1::nat,0::nat)"

abbreviation base_tree :: "((form fset \<times> form) \<times> (prop_rule \<times> form) NatRule) tree" where
  "base_tree \<equiv> Node ({|Q (LC lx)|} \<turnstile> Q (LC lx), Axiom) {||}"

abbreviation imp_tree :: "((form fset \<times> form) \<times> (prop_rule \<times> form) NatRule) tree" where
  "imp_tree \<equiv> Node ({||} \<turnstile> imp (Q (LC lx)) (Q (LC lx)), NatRule (impI, imp X Y)) {|base_tree|}"

abbreviation solution_tree :: "((form fset \<times> form) \<times> (prop_rule \<times> form) NatRule) tree" where
  "solution_tree \<equiv> Node ({||} \<turnstile> ForallX (imp (Q x) (Q x)), NatRule (allI, ForallX (P x))) {|imp_tree|}"

abbreviation s1 where "s1 \<equiv> [(12, ([9], imp (Q x) (Q x)))] "
abbreviation s2 where "s2 \<equiv> [(10, ([], Q (LC lx))), (11, ([], Q (LC lx)))] "

lemma fv_subst_s1[simp]: "fv_subst s1 = {}"
  by (simp add: fv_subst_def)

lemma subst1_simps[simp]:
  "subst s1 (P (LC n)) = imp (Q (LC n)) (Q (LC n))"
  "subst s1 (ForallX (P x)) = ForallX (imp (Q x) (Q x))"
  by simp_all

lemma subst2_simps[simp]:
    "subst s2 X = Q (LC lx)"
    "subst s2 Y = Q (LC lx)"
    "subst s2 (imp X Y) = imp (subst s2 X) (subst s2 Y)"
  by simp_all

lemma substI1: "ForallX (imp (Q x) (Q x)) = subst s1 (predicate.freshen 1 (ForallX (P x)))"
  by (auto simp add: predicate.freshen_def Let_def)

lemma substI2: "imp (Q (LC lx)) (Q (LC lx)) = subst s2 (predicate.freshen 2 (imp X Y))"
  by (auto simp add: predicate.freshen_def Let_def)

declare subst.simps[simp del]

lemma "task.solved"
  unfolding task.solved_def
apply clarsimp
apply (rule_tac x="{||}" in exI)
apply clarsimp
apply (rule_tac x="solution_tree" in exI)
apply clarsimp
apply (rule conjI)

 apply (rule task.wf)
   apply (solves \<open>(auto simp add: stream.set_map task.n_rules_def)[1]\<close>)
  apply clarsimp
  apply (rule task.eff_NatRuleI)
      apply (solves \<open>rule task.natEff_Inst.intros;simp\<close>)
     apply clarsimp
     apply (rule conjI)
      apply (solves \<open>simp\<close>)
     apply (solves \<open>rule substI1\<close>)
    apply (simp add: predicate.f_antecedent_def predicate.freshen_def)
    apply (subst antecedent.sel(2))
    apply (solves \<open>simp\<close>)
   apply (solves \<open>simp\<close>)
  apply (solves \<open>simp\<close>)
 apply simp

 apply (rule task.wf)
   apply (solves \<open>(auto simp add: stream.set_map task.n_rules_def)[1]\<close>)
  apply clarsimp
  apply (rule task.eff_NatRuleI)
      apply (solves \<open>rule task.natEff_Inst.intros; simp\<close>)
     apply clarsimp
     apply (rule conjI)
      apply (solves \<open>simp\<close>)
     apply (solves \<open>rule substI2\<close>)
    apply (solves \<open>simp add: predicate.f_antecedent_def predicate.freshen_def\<close>)
   apply (solves \<open>simp\<close>)
  apply (solves \<open>simp add: predicate.f_antecedent_def\<close>)
 apply simp

 apply (solves \<open>(auto intro: task.wf intro!: task.eff.intros(1))[1]\<close>)
apply (solves \<open>(rule tfinite.intros, simp)+\<close>)
done

abbreviation vertices where "vertices \<equiv> {|0::nat,1,2 |}"
fun nodeOf  where
    "nodeOf n = [Conclusion (ForallX (imp (Q x) (Q x))),
                 Rule allI,
                 Rule impI] ! n "

fun inst  where
    "inst n = [[],s1,s2] ! n"

interpretation task: Vertex_Graph task.nodes task.inPorts task.outPorts vertices nodeOf.

abbreviation e1 :: "(nat, form, nat) edge'"
  where "e1 \<equiv> ((1,Reg (ForallX (P x))), (0,plain_ant (ForallX (imp (Q x) (Q x)))))"
abbreviation e2  :: "(nat, form, nat) edge'"
  where "e2 \<equiv> ((2,Reg (imp X Y)), (1,allI_input))"
abbreviation e3  :: "(nat, form, nat) edge'"
  where "e3 \<equiv> ((2,Hyp X (impI_input)), (2,impI_input))"
abbreviation task_edges :: "(nat, form, nat) edge' set" where "task_edges \<equiv> {e1, e2, e3}"

interpretation task: Scoped_Graph task.nodes task.inPorts task.outPorts vertices nodeOf task_edges task.hyps
  by standard (auto simp add: predicate.f_consequent_def predicate.f_antecedent_def)

interpretation task: Instantiation
  task.inPorts
  task.outPorts
  nodeOf
  task.hyps
  task.nodes
  task_edges
  vertices
  task.labelsIn
  task.labelsOut
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  "id"
  "inst"
by unfold_locales simp

text \<open>Finally we can also show that there is a proof graph for this task.\<close>

interpretation Well_Scoped_Graph
  task.nodes
  task.inPorts
  task.outPorts
  vertices
  nodeOf
  task_edges
  task.hyps
by standard (auto split: if_splits)

lemma no_path_01[simp]: "task.path 0 v pth \<longleftrightarrow> (pth = [] \<and> v = 0)"
  by (cases pth) (auto simp add: task.path_cons_simp)
lemma no_path_12[simp]: "\<not> task.path 1 2 pth"
  by (cases pth) (auto simp add: task.path_cons_simp)

interpretation Acyclic_Graph
  task.nodes
  task.inPorts
  task.outPorts
  vertices
  nodeOf
  task_edges
  task.hyps
proof
  fix v pth
  assume "task.path v v pth" and "task.hyps_free pth"
  thus "pth = []"
    by (cases pth) (auto simp add: task.path_cons_simp predicate.f_antecedent_def)
qed

interpretation Saturated_Graph
  task.nodes
  task.inPorts
  task.outPorts
  vertices
  nodeOf
  task_edges
by standard
   (auto simp add: predicate.f_consequent_def predicate.f_antecedent_def)

interpretation Pruned_Port_Graph
  task.nodes
  task.inPorts
  task.outPorts
  vertices
  nodeOf
  task_edges
proof
  fix v
  assume "v |\<in>| vertices"
  hence "\<exists> pth. task.path v 0 pth"
    apply auto
    apply (rule exI[where x = "[e1]"], auto simp add: task.path_cons_simp)
    apply (rule exI[where x = "[e2,e1]"], auto simp add: task.path_cons_simp)
    done
  moreover
  have "task.terminal_vertex 0" by auto
  ultimately
  show "\<exists>pth v'. task.path v v' pth \<and> task.terminal_vertex v'" by blast
qed

interpretation Well_Shaped_Graph
  task.nodes
  task.inPorts
  task.outPorts
  vertices
  nodeOf task_edges
  task.hyps
..

interpretation Solution
  task.inPorts
  task.outPorts
  nodeOf
  task.hyps
  task.nodes
  vertices
  task.labelsIn
  task.labelsOut
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  id
  inst
  task_edges
by standard
   (auto simp add: task.labelAtOut_def task.labelAtIn_def predicate.freshen_def, subst antecedent.sel, simp)

interpretation Proof_Graph
  task.nodes
  task.inPorts
  task.outPorts
  vertices
  nodeOf
  task_edges
  task.hyps
  task.labelsIn
  task.labelsOut
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  id
  inst
..

lemma path_20:
  assumes "task.path 2 0 pth"
  shows "(1, allI_input) \<in> snd ` set pth"
proof-
  { fix v
    assume "task.path v 0 pth"
    hence "v = 0 \<or> v = 1 \<or> (1, allI_input) \<in> snd ` set pth"
    by (induction v "0::nat" pth rule: task.path.induct) auto
  }
  from this[OF assms]
  show ?thesis by auto
qed

lemma scope_21: "2 \<in> task.scope (1, allI_input)"
  by (auto intro!: task.scope.intros elim: path_20 simp add: task.outPortsRule_def predicate.f_antecedent_def predicate.f_consequent_def)

interpretation Scoped_Proof_Graph
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  task.inPorts
  task.outPorts
  nodeOf
  task.hyps
  task.nodes
  vertices
  task.labelsIn
  task.labelsOut
  id
  inst
  task_edges
  task.local_vars
by standard (auto simp add: predicate.f_antecedent_def scope_21)

interpretation Tasked_Proof_Graph
  "curry to_nat :: nat \<Rightarrow> var \<Rightarrow> var"
  map_lc
  lc
  "closed"
  subst
  lc_subst
  map_lc_subst
  "Var 0 []"
  antecedent
  consequent
  prop_rules
  "[]"
  "[ForallX (imp (Q x) (Q x))]"
  vertices
  nodeOf
  task_edges
  id
  inst
by unfold_locales auto

end

end


(******************************************************************************
 * Clean
 *
 * Copyright (c) 2018-2019 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * 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.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "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 COPYRIGHT
 * OWNER OR CONTRIBUTORS 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.
 ******************************************************************************)

(*
 * Quicksort : all at a glance.
 *
 * Authors : Burkhart Wolff, Frédéric Tuong
 *)

chapter \<open> Clean Semantics : A Coding-Concept Example\<close>

text\<open>The following show-case introduces subsequently a non-trivial example involving
local and global variable declarations, declarations of operations with pre-post conditions as
well as direct-recursive operations (i.e. C-like functions with side-effects on global and
local variables. \<close>

theory Quicksort
  imports Clean.Clean
          Clean.Hoare_Clean
          Clean.Clean_Symbex
begin

section\<open>The Quicksort Example - At a Glance\<close>

text\<open> We present the following quicksort algorithm in some conceptual, high-level notation:

\begin{isar}
algorithm (A,i,j) =
    tmp := A[i];
    A[i]:=A[j];
    A[j]:=tmp

algorithm partition(A, lo, hi) is
    pivot := A[hi]
    i := lo
    for j := lo to hi - 1 do
        if A[j] < pivot then
            swap A[i] with A[j]
            i := i + 1
    swap A[i] with A[hi]
    return i

algorithm quicksort(A, lo, hi) is
    if lo < hi then
        p := partition(A, lo, hi)
        quicksort(A, lo, p - 1)
        quicksort(A, p + 1, hi)

\end{isar}
\<close>

section\<open>Clean Encoding of the Global State of Quicksort\<close>

global_vars state
    A :: "int list"

function_spec swap (i::nat,j::nat) \<comment> \<open>TODO: the hovering on parameters produces a number of report equal to the number of \<^ML>\<open>Proof_Context.add_fixes\<close> called in \<^ML>\<open>Function_Specification_Parser.checkNsem_function_spec\<close>\<close>
pre          "\<open>i < length A \<and> j < length A\<close>"
post         "\<open>\<lambda>res. length A = length(old A) \<and> res = ()\<close>"
local_vars   tmp :: int
defines      " \<open> tmp := A ! i\<close>  ;-
               \<open> A := list_update A i (A ! j)\<close> ;-
               \<open> A := list_update A j tmp\<close> "

function_spec partition (lo::nat, hi::nat) returns nat
pre          "\<open>lo < length A \<and> hi < length A\<close>"
post         "\<open>\<lambda>res::nat. length A = length(old A) \<and> res = 3\<close>"
local_vars   pivot  :: int
             i      :: nat
             j      :: nat
defines      " \<open>pivot := A ! hi \<close>  ;- \<open>i := lo \<close> ;- \<open>j := lo \<close> ;-
               while\<^sub>C \<open>j \<le> hi - 1 \<close>
                do if\<^sub>C \<open>A ! j < pivot\<close>
                     then call\<^sub>C swap \<open>(i , j) \<close>  ;-
                          \<open>i := i + 1 \<close>
                     else skip\<^sub>S\<^sub>E
                   fi ;-
                    \<open>j := j + 1 \<close>
                od;-
                call\<^sub>C swap \<open>(i, j)\<close>  ;-
                return\<^bsub>local_partition_state.result_value_update\<^esub> \<open>i\<close>"

thm partition_core_def

rec_function_spec quicksort (lo::nat, hi::nat) returns unit
pre          "\<open>lo \<le> hi \<and> hi < length A\<close>"
post         "\<open>\<lambda>res::unit. \<forall>i\<in>{lo .. hi}. \<forall>j\<in>{lo .. hi}. i \<le> j \<longrightarrow> A!i \<le> A!j\<close>"
variant      "hi - lo"
local_vars   p :: "nat"
defines      " if\<^sub>C \<open>lo < hi\<close>
               then (p\<^sub>t\<^sub>m\<^sub>p \<leftarrow> call\<^sub>C partition \<open>(lo, hi)\<close> ; assign_local p_update (\<lambda>\<sigma>. p\<^sub>t\<^sub>m\<^sub>p)) ;-
                     call\<^sub>C quicksort \<open>(lo, p - 1)\<close> ;-
                     call\<^sub>C quicksort \<open>(lo, p + 1)\<close>
               else skip\<^sub>S\<^sub>E
               fi"

thm quicksort_core_def
thm quicksort_def
thm quicksort_pre_def
thm quicksort_post_def

section\<open>Possible Application Sketch\<close>

lemma quicksort_correct :
  "\<lbrace>\<lambda>\<sigma>.   \<triangleright> \<sigma> \<and> quicksort_pre (lo, hi)(\<sigma>) \<and> \<sigma> = \<sigma>\<^sub>p\<^sub>r\<^sub>e \<rbrace>
     quicksort (lo, hi)
   \<lbrace>\<lambda>r \<sigma>. \<triangleright> \<sigma> \<and> quicksort_post(lo, hi)(\<sigma>\<^sub>p\<^sub>r\<^sub>e)(\<sigma>)(r) \<rbrace>"
   oops

end