theory Terms

imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp" "Abs"

begin

atom_decl name

text {* primrec seems to be genarally faster than fun *}

section {*** lets with binding patterns ***}

datatype rtrm1 =

  rVr1 "name"

| rAp1 "rtrm1" "rtrm1"

| rLm1 "name" "rtrm1"        --"name is bound in trm1"

| rLt1 "bp" "rtrm1" "rtrm1"   --"all variables in bp are bound in the 2nd trm1"

and bp =

  BUnit

| BVr "name"

| BPr "bp" "bp"

(* to be given by the user *)

primrec 

  bv1

where

  "bv1 (BUnit) = {}"

| "bv1 (BVr x) = {atom x}"

| "bv1 (BPr bp1 bp2) = (bv1 bp1) \<union> (bv1 bp1)"

(* needs to be calculated by the package *)

primrec 

  rfv_trm1 and rfv_bp

where

  "rfv_trm1 (rVr1 x) = {atom x}"

| "rfv_trm1 (rAp1 t1 t2) = (rfv_trm1 t1) \<union> (rfv_trm1 t2)"

| "rfv_trm1 (rLm1 x t) = (rfv_trm1 t) - {atom x}"

| "rfv_trm1 (rLt1 bp t1 t2) = (rfv_trm1 t1) \<union> (rfv_trm1 t2 - bv1 bp)"

| "rfv_bp (BUnit) = {}"

| "rfv_bp (BVr x) = {atom x}"

| "rfv_bp (BPr b1 b2) = (rfv_bp b1) \<union> (rfv_bp b2)"

(* needs to be stated by the package *)

instantiation 

  rtrm1 and bp :: pt

begin

primrec

  permute_rtrm1 and permute_bp

where

  "permute_rtrm1 pi (rVr1 a) = rVr1 (pi \<bullet> a)"

| "permute_rtrm1 pi (rAp1 t1 t2) = rAp1 (permute_rtrm1 pi t1) (permute_rtrm1 pi t2)"

| "permute_rtrm1 pi (rLm1 a t) = rLm1 (pi \<bullet> a) (permute_rtrm1 pi t)"

| "permute_rtrm1 pi (rLt1 bp t1 t2) = rLt1 (permute_bp pi bp) (permute_rtrm1 pi t1) (permute_rtrm1 pi t2)"

| "permute_bp pi (BUnit) = BUnit"

| "permute_bp pi (BVr a) = BVr (pi \<bullet> a)"

| "permute_bp pi (BPr bp1 bp2) = BPr (permute_bp pi bp1) (permute_bp pi bp2)"

lemma pt_rtrm1_bp_zero:

  fixes t::rtrm1

  and   b::bp

  shows "0 \<bullet> t = t"

  and   "0 \<bullet> b = b"

apply(induct t and b rule: rtrm1_bp.inducts)

apply(simp_all)

done

lemma pt_rtrm1_bp_plus:

  fixes t::rtrm1

  and   b::bp

  shows "((p + q) \<bullet> t) = p \<bullet> (q \<bullet> t)"

  and   "((p + q) \<bullet> b) = p \<bullet> (q \<bullet> b)"

apply(induct t and b rule: rtrm1_bp.inducts)

apply(simp_all)

done

instance

apply default

apply(simp_all add: pt_rtrm1_bp_zero pt_rtrm1_bp_plus)

done

end

inductive

  alpha1 :: "rtrm1 \<Rightarrow> rtrm1 \<Rightarrow> bool" ("_ \<approx>1 _" [100, 100] 100)

where

  a1: "a = b \<Longrightarrow> (rVr1 a) \<approx>1 (rVr1 b)"

| a2: "\<lbrakk>t1 \<approx>1 t2; s1 \<approx>1 s2\<rbrakk> \<Longrightarrow> rAp1 t1 s1 \<approx>1 rAp1 t2 s2"

| a3: "(\<exists>pi. (({atom aa}, t) \<approx>gen alpha1 rfv_trm1 pi ({atom ab}, s))) \<Longrightarrow> rLm1 aa t \<approx>1 rLm1 ab s"

| a4: "t1 \<approx>1 t2 \<Longrightarrow> (\<exists>pi. (((bv1 b1), s1) \<approx>gen alpha1 rfv_trm1 pi ((bv1 b2), s2))) \<Longrightarrow> rLt1 b1 t1 s1 \<approx>1 rLt1 b2 t2 s2"

lemma alpha1_inj:

"(rVr1 a \<approx>1 rVr1 b) = (a = b)"

"(rAp1 t1 s1 \<approx>1 rAp1 t2 s2) = (t1 \<approx>1 t2 \<and> s1 \<approx>1 s2)"

"(rLm1 aa t \<approx>1 rLm1 ab s) = (\<exists>pi. (({atom aa}, t) \<approx>gen alpha1 rfv_trm1 pi ({atom ab}, s)))"

"(rLt1 b1 t1 s1 \<approx>1 rLt1 b2 t2 s2) = (t1 \<approx>1 t2 \<and> (\<exists>pi. (((bv1 b1), s1) \<approx>gen alpha1 rfv_trm1 pi ((bv1 b2), s2))))"

apply -

apply rule apply (erule alpha1.cases) apply (simp_all add: alpha1.intros)

apply rule apply (erule alpha1.cases) apply (simp_all add: alpha1.intros)

apply rule apply (erule alpha1.cases) apply (simp_all add: alpha1.intros)

apply rule apply (erule alpha1.cases) apply (simp_all add: alpha1.intros)

done

(* Shouyld we derive it? But bv is given by the user? *)

lemma bv1_eqvt[eqvt]:

  shows "(pi \<bullet> bv1 x) = bv1 (pi \<bullet> x)"

  apply (induct x)

apply (simp_all add: empty_eqvt insert_eqvt atom_eqvt)

done

lemma rfv_trm1_eqvt[eqvt]:

  shows "(pi\<bullet>rfv_trm1 t) = rfv_trm1 (pi\<bullet>t)"

  apply (induct t)

  apply (simp_all add: insert_eqvt atom_eqvt empty_eqvt union_eqvt Diff_eqvt bv1_eqvt)

  done

lemma alpha1_eqvt:

  shows "t \<approx>1 s \<Longrightarrow> (pi \<bullet> t) \<approx>1 (pi \<bullet> s)"

  apply (induct t s rule: alpha1.inducts)

  apply (simp_all add:eqvts alpha1_inj)

  apply (erule exE)

  apply (rule_tac x="pi \<bullet> pia" in exI)

  apply (simp add: alpha_gen)

  apply(erule conjE)+

  apply(rule conjI)

  apply(rule_tac ?p1="- pi" in permute_eq_iff[THEN iffD1])

  apply(simp add: atom_eqvt Diff_eqvt insert_eqvt empty_eqvt rfv_trm1_eqvt)

  apply(rule conjI)

  apply(rule_tac ?p1="- pi" in fresh_star_permute_iff[THEN iffD1])

  apply(simp add: atom_eqvt Diff_eqvt rfv_trm1_eqvt insert_eqvt empty_eqvt)

  apply(simp add: permute_eqvt[symmetric])

  apply (erule exE)

  apply (rule_tac x="pi \<bullet> pia" in exI)

  apply (simp add: alpha_gen)

  apply(erule conjE)+

  apply(rule conjI)

  apply(rule_tac ?p1="- pi" in permute_eq_iff[THEN iffD1])

  apply(simp add: rfv_trm1_eqvt Diff_eqvt bv1_eqvt)

  apply(rule conjI)

  apply(rule_tac ?p1="- pi" in fresh_star_permute_iff[THEN iffD1])

  apply(simp add: atom_eqvt rfv_trm1_eqvt Diff_eqvt bv1_eqvt)

  apply(simp add: permute_eqvt[symmetric])

  done

lemma alpha1_equivp: "equivp alpha1" 

  sorry

quotient_type trm1 = rtrm1 / alpha1

  by (rule alpha1_equivp)

quotient_definition

  "Vr1 :: name \<Rightarrow> trm1"

as

  "rVr1"

quotient_definition

  "Ap1 :: trm1 \<Rightarrow> trm1 \<Rightarrow> trm1"

as

  "rAp1"

quotient_definition

  "Lm1 :: name \<Rightarrow> trm1 \<Rightarrow> trm1"

as

  "rLm1"

quotient_definition

  "Lt1 :: bp \<Rightarrow> trm1 \<Rightarrow> trm1 \<Rightarrow> trm1"

as

  "rLt1"

quotient_definition

  "fv_trm1 :: trm1 \<Rightarrow> atom set"

as

  "rfv_trm1"

lemma alpha_rfv1:

  shows "t \<approx>1 s \<Longrightarrow> rfv_trm1 t = rfv_trm1 s"

  apply(induct rule: alpha1.induct)

  apply(simp_all add: alpha_gen.simps)

  done

lemma [quot_respect]:

 "(op = ===> alpha1) rVr1 rVr1"

 "(alpha1 ===> alpha1 ===> alpha1) rAp1 rAp1"

 "(op = ===> alpha1 ===> alpha1) rLm1 rLm1"

 "(op = ===> alpha1 ===> alpha1 ===> alpha1) rLt1 rLt1"

apply (auto intro: alpha1.intros)

apply(rule a3) apply (rule_tac x="0" in exI)

apply (simp add: fresh_star_def fresh_zero_perm alpha_rfv1 alpha_gen)

apply(rule a4) apply assumption apply (rule_tac x="0" in exI)

apply (simp add: fresh_star_def fresh_zero_perm alpha_rfv1 alpha_gen)

done

lemma [quot_respect]:

  "(op = ===> alpha1 ===> alpha1) permute permute"

apply auto

apply (rule alpha1_eqvt)

apply simp

done

lemma [quot_respect]:

  "(alpha1 ===> op =) rfv_trm1 rfv_trm1"

apply (simp add: alpha_rfv1)

done

lemmas trm1_bp_induct = rtrm1_bp.induct[quot_lifted]

lemmas trm1_bp_inducts = rtrm1_bp.inducts[quot_lifted]

instantiation trm1 and bp :: pt

begin

quotient_definition

  "permute_trm1 :: perm \<Rightarrow> trm1 \<Rightarrow> trm1"

as

  "permute :: perm \<Rightarrow> rtrm1 \<Rightarrow> rtrm1"

lemmas permute_trm1[simp] = permute_rtrm1_permute_bp.simps[quot_lifted]

instance

apply default

apply(induct_tac [!] x rule: trm1_bp_inducts(1))

apply(simp_all)

done

end

lemmas fv_trm1 = rfv_trm1_rfv_bp.simps[quot_lifted]

lemmas fv_trm1_eqvt = rfv_trm1_eqvt[quot_lifted]

lemmas alpha1_INJ = alpha1_inj[unfolded alpha_gen, quot_lifted, folded alpha_gen]

lemma lm1_supp_pre:

  shows "(supp (atom x, t)) supports (Lm1 x t) "

apply(simp add: supports_def)

apply(fold fresh_def)

apply(simp add: fresh_Pair swap_fresh_fresh)

apply(clarify)

apply(subst swap_at_base_simps(3))

apply(simp_all add: fresh_atom)

done

lemma lt1_supp_pre:

  shows "(supp (x, t, s)) supports (Lt1 t x s) "

apply(simp add: supports_def)

apply(fold fresh_def)

apply(simp add: fresh_Pair swap_fresh_fresh)

done

lemma bp_supp: "finite (supp (bp :: bp))"

  apply (induct bp)

  apply(simp_all add: supp_def)

  apply (fold supp_def)

  apply (simp add: supp_at_base)

  apply(simp add: Collect_imp_eq)

  apply(simp add: Collect_neg_eq[symmetric])

  apply (fold supp_def)

  apply (simp)

  done

instance trm1 :: fs

apply default

apply(induct_tac x rule: trm1_bp_inducts(1))

apply(simp_all)

apply(simp add: supp_def alpha1_INJ eqvts)

apply(simp add: supp_def[symmetric] supp_at_base)

apply(simp only: supp_def alpha1_INJ eqvts permute_trm1)

apply(simp add: Collect_imp_eq Collect_neg_eq)

apply(rule supports_finite)

apply(rule lm1_supp_pre)

apply(simp add: supp_Pair supp_atom)

apply(rule supports_finite)

apply(rule lt1_supp_pre)

apply(simp add: supp_Pair supp_atom bp_supp)

done

lemma supp_fv:

  shows "supp t = fv_trm1 t"

apply(induct t rule: trm1_bp_inducts(1))

apply(simp_all)

apply(simp add: supp_def permute_trm1 alpha1_INJ fv_trm1)

apply(simp only: supp_at_base[simplified supp_def])

apply(simp add: supp_def permute_trm1 alpha1_INJ fv_trm1)

apply(simp add: Collect_imp_eq Collect_neg_eq)

apply(subgoal_tac "supp (Lm1 name rtrm1) = supp (Abs {atom name} rtrm1)")

apply(simp add: supp_Abs fv_trm1)

apply(simp (no_asm) add: supp_def permute_set_eq atom_eqvt)

apply(simp add: alpha1_INJ)

apply(simp add: Abs_eq_iff)

apply(simp add: alpha_gen.simps)

apply(simp add: supp_eqvt[symmetric] fv_trm1_eqvt[symmetric])

apply(subgoal_tac "supp (Lt1 bp rtrm11 rtrm12) = supp(rtrm11) \<union> supp (Abs (bv1 bp) rtrm12)")

apply(simp add: supp_Abs fv_trm1)

apply(simp (no_asm) add: supp_def)

apply(simp add: alpha1_INJ)

apply(simp add: Abs_eq_iff)

apply(simp add: alpha_gen)

apply(simp add: supp_eqvt[symmetric] fv_trm1_eqvt[symmetric] bv1_eqvt)

apply(simp add: Collect_imp_eq Collect_neg_eq)

done

lemma trm1_supp:

  "supp (Vr1 x) = {atom x}"

  "supp (Ap1 t1 t2) = supp t1 \<union> supp t2"

  "supp (Lm1 x t) = (supp t) - {atom x}"

  "supp (Lt1 b t s) = supp t \<union> (supp s - bv1 b)"

  by (simp_all only: supp_fv fv_trm1)

lemma trm1_induct_strong:

  assumes "\<And>name b. P b (Vr1 name)"

  and     "\<And>rtrm11 rtrm12 b. \<lbrakk>\<And>c. P c rtrm11; \<And>c. P c rtrm12\<rbrakk> \<Longrightarrow> P b (Ap1 rtrm11 rtrm12)"

  and     "\<And>name rtrm1 b. \<lbrakk>\<And>c. P c rtrm1; (atom name) \<sharp> b\<rbrakk> \<Longrightarrow> P b (Lm1 name rtrm1)"

  and     "\<And>bp rtrm11 rtrm12 b. \<lbrakk>\<And>c. P c rtrm11; \<And>c. P c rtrm12; bp1 bp \<sharp>* b\<rbrakk> \<Longrightarrow> P b (Lt1 bp rtrm11 rtrm12)"

  shows   "P a rtrma"

sorry

section {*** lets with single assignments ***}

datatype rtrm2 =

  rVr2 "name"

| rAp2 "rtrm2" "rtrm2"

| rLm2 "name" "rtrm2" --"bind (name) in (rtrm2)"

| rLt2 "rassign" "rtrm2" --"bind (bv2 rassign) in (rtrm2)"

and rassign =

  rAs "name" "rtrm2"

(* to be given by the user *)

primrec 

  rbv2

where

  "rbv2 (rAs x t) = {atom x}"

(* needs to be calculated by the package *)

primrec

  fv_rtrm2 and fv_rassign

where

  "fv_rtrm2 (rVr2 x) = {atom x}"

| "fv_rtrm2 (rAp2 t1 t2) = (fv_rtrm2 t1) \<union> (fv_rtrm2 t2)"

| "fv_rtrm2 (rLm2 x t) = (fv_rtrm2 t) - {atom x}"

| "fv_rtrm2 (rLt2 as t) = (fv_rtrm2 t - rbv2 as) \<union> (fv_rassign as)"

| "fv_rassign (rAs x t) = fv_rtrm2 t"

(* needs to be stated by the package *)

instantiation

  rtrm2 and rassign :: pt

begin

primrec

  permute_rtrm2 and permute_rassign

where

  "permute_rtrm2 pi (rVr2 a) = rVr2 (pi \<bullet> a)"

| "permute_rtrm2 pi (rAp2 t1 t2) = rAp2 (permute_rtrm2 pi t1) (permute_rtrm2 pi t2)"

| "permute_rtrm2 pi (rLm2 a t) = rLm2 (pi \<bullet> a) (permute_rtrm2 pi t)"

| "permute_rtrm2 pi (rLt2 as t) = rLt2 (permute_rassign pi as) (permute_rtrm2 pi t)"

| "permute_rassign pi (rAs a t) = rAs (pi \<bullet> a) (permute_rtrm2 pi t)"

lemma pt_rtrm2_rassign_zero:

  fixes t::rtrm2

  and   b::rassign

  shows "0 \<bullet> t = t"

  and   "0 \<bullet> b = b"

apply(induct t and b rule: rtrm2_rassign.inducts)

apply(simp_all)

done

lemma pt_rtrm2_rassign_plus:

  fixes t::rtrm2

  and   b::rassign

  shows "((p + q) \<bullet> t) = p \<bullet> (q \<bullet> t)"

  and   "((p + q) \<bullet> b) = p \<bullet> (q \<bullet> b)"

apply(induct t and b rule: rtrm2_rassign.inducts)

apply(simp_all)

done

instance

apply default

apply(simp_all add: pt_rtrm2_rassign_zero pt_rtrm2_rassign_plus)

done

end

inductive

  alpha2 :: "rtrm2 \<Rightarrow> rtrm2 \<Rightarrow> bool" ("_ \<approx>2 _" [100, 100] 100)

and

  alpha2a :: "rassign \<Rightarrow> rassign \<Rightarrow> bool" ("_ \<approx>2a _" [100, 100] 100)

where

  a1: "a = b \<Longrightarrow> (rVr2 a) \<approx>2 (rVr2 b)"

| a2: "\<lbrakk>t1 \<approx>2 t2; s1 \<approx>2 s2\<rbrakk> \<Longrightarrow> rAp2 t1 s1 \<approx>2 rAp2 t2 s2"

| a3: "(\<exists>pi. (({atom a}, t) \<approx>gen alpha2 fv_rtrm2 pi ({atom b}, s))) \<Longrightarrow> rLm2 a t \<approx>2 rLm2 b s"

| a4: "\<lbrakk>\<exists>pi. ((rbv2 bt, t) \<approx>gen alpha2 fv_rtrm2 pi ((rbv2 bs), s));

        \<exists>pi. ((rbv2 bt, bt) \<approx>gen alpha2a fv_rassign pi (rbv2 bs, bs))\<rbrakk>

        \<Longrightarrow> rLt2 bt t \<approx>2 rLt2 bs s"

| a5: "\<lbrakk>a = b; t \<approx>2 s\<rbrakk> \<Longrightarrow> rAs a t \<approx>2a rAs b s" (* This way rbv2 can be lifted *)

lemma alpha2_equivp:

  "equivp alpha2"

  "equivp alpha2a"

  sorry

quotient_type

  trm2 = rtrm2 / alpha2

and

  assign = rassign / alpha2a

  by (auto intro: alpha2_equivp)

section {*** lets with many assignments ***}

datatype trm3 =

  Vr3 "name"

| Ap3 "trm3" "trm3"

| Lm3 "name" "trm3" --"bind (name) in (trm3)"

| Lt3 "assigns" "trm3" --"bind (bv3 assigns) in (trm3)"

and assigns =

  ANil

| ACons "name" "trm3" "assigns"

(* to be given by the user *)

primrec 

  bv3

where

  "bv3 ANil = {}"

| "bv3 (ACons x t as) = {atom x} \<union> (bv3 as)"

primrec

  fv_trm3 and fv_assigns

where

  "fv_trm3 (Vr3 x) = {atom x}"

| "fv_trm3 (Ap3 t1 t2) = (fv_trm3 t1) \<union> (fv_trm3 t2)"

| "fv_trm3 (Lm3 x t) = (fv_trm3 t) - {atom x}"

| "fv_trm3 (Lt3 as t) = (fv_trm3 t - bv3 as) \<union> (fv_assigns as)"

| "fv_assigns (ANil) = {}"

| "fv_assigns (ACons x t as) = (fv_trm3 t) \<union> (fv_assigns as)"

(* needs to be stated by the package *)

instantiation

 trm3 and assigns :: pt

begin

primrec

  permute_trm3 and permute_assigns

where

  "permute_trm3 pi (Vr3 a) = Vr3 (pi \<bullet> a)"

| "permute_trm3 pi (Ap3 t1 t2) = Ap3 (permute_trm3 pi t1) (permute_trm3 pi t2)"

| "permute_trm3 pi (Lm3 a t) = Lm3 (pi \<bullet> a) (permute_trm3 pi t)"

| "permute_trm3 pi (Lt3 as t) = Lt3 (permute_assigns pi as) (permute_trm3 pi t)"

| "permute_assigns pi (ANil) = ANil"

| "permute_assigns pi (ACons a t as) = ACons (pi \<bullet> a) (permute_trm3 pi t) (permute_assigns pi as)"

lemma pt_trm3_assigns_zero:

  fixes t::trm3

  and   b::assigns

  shows "0 \<bullet> t = t"

  and   "0 \<bullet> b = b"

apply(induct t and b rule: trm3_assigns.inducts)

apply(simp_all)

done

lemma pt_trm3_assigns_plus:

  fixes t::trm3

  and   b::assigns

  shows "((p + q) \<bullet> t) = p \<bullet> (q \<bullet> t)"

  and   "((p + q) \<bullet> b) = p \<bullet> (q \<bullet> b)"

apply(induct t and b rule: trm3_assigns.inducts)

apply(simp_all)

done

instance

apply default

apply(simp_all add: pt_trm3_assigns_zero pt_trm3_assigns_plus)

done

end

inductive

  alpha3 :: "trm3 \<Rightarrow> trm3 \<Rightarrow> bool" ("_ \<approx>3 _" [100, 100] 100)

and

  alpha3a :: "assigns \<Rightarrow> assigns \<Rightarrow> bool" ("_ \<approx>3a _" [100, 100] 100)

where

  a1: "a = b \<Longrightarrow> (Vr3 a) \<approx>3 (Vr3 b)"

| a2: "\<lbrakk>t1 \<approx>3 t2; s1 \<approx>3 s2\<rbrakk> \<Longrightarrow> Ap3 t1 s1 \<approx>3 Ap3 t2 s2"

| a3: "(\<exists>pi. (({atom a}, t) \<approx>gen alpha3 fv_rtrm3 pi ({atom b}, s))) \<Longrightarrow> Lm3 a t \<approx>3 Lm3 b s"

| a4: "\<lbrakk>\<exists>pi. ((bv3 bt, t) \<approx>gen alpha3 fv_trm3 pi ((bv3 bs), s));

        \<exists>pi. ((bv3 bt, bt) \<approx>gen alpha3a fv_assign pi (bv3 bs, bs))\<rbrakk>

        \<Longrightarrow> Lt3 bt t \<approx>3 Lt3 bs s"

| a5: "ANil \<approx>3a ANil"

| a6: "\<lbrakk>a = b; t \<approx>3 s; tt \<approx>3a st\<rbrakk> \<Longrightarrow> ACons a t tt \<approx>3a ACons b s st"

lemma alpha3_equivp:

  "equivp alpha3"