theory Terms

imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp" "Abs" "Perm" "Fv" "../../Attic/Prove"

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"

print_theorems

(* to be given by the user *)

primrec 

  bv1

where

  "bv1 (BUnit) = {}"

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

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

setup {* snd o define_raw_perms ["rtrm1", "bp"] ["Terms.rtrm1", "Terms.bp"] *}

thm permute_rtrm1_permute_bp.simps

local_setup {* 

  snd o define_fv_alpha "Terms.rtrm1"

  [[[[]], [[], []], [[(NONE, 0)], [(NONE, 0)]], [[(SOME @{term bv1}, 0)], [], [(SOME @{term bv1}, 0)]]],

  [[], [[]], [[], []]]] *}

notation

  alpha_rtrm1 ("_ \<approx>1 _" [100, 100] 100) and

  alpha_bp ("_ \<approx>1b _" [100, 100] 100)

thm alpha_rtrm1_alpha_bp.intros

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha1_inj}, []), (build_alpha_inj @{thms alpha_rtrm1_alpha_bp.intros} @{thms rtrm1.distinct rtrm1.inject bp.distinct bp.inject} @{thms alpha_rtrm1.cases alpha_bp.cases} ctxt)) ctxt)) *}

thm alpha1_inj

lemma alpha_bp_refl: "alpha_bp a a"

apply induct

apply (simp_all  add: alpha1_inj)

done

lemma alpha_bp_eq_eq: "alpha_bp a b = (a = b)"

apply rule

apply (induct a b rule: alpha_rtrm1_alpha_bp.inducts(2))

apply (simp_all add: alpha_bp_refl)

done

lemma alpha_bp_eq: "alpha_bp = (op =)"

apply (rule ext)+

apply (rule alpha_bp_eq_eq)

done

lemma bv1_eqvt[eqvt]:

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

  apply (induct x)

  apply (simp_all add: atom_eqvt eqvts)

  done

lemma fv_rtrm1_eqvt[eqvt]:

    "(pi\<bullet>fv_rtrm1 t) = fv_rtrm1 (pi\<bullet>t)"

    "(pi\<bullet>fv_bp b) = fv_bp (pi\<bullet>b)"

  apply (induct t and b)

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

  done

lemma alpha1_eqvt:

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

  "alpha_bp a b \<Longrightarrow> alpha_bp (pi \<bullet> a) (pi \<bullet> b)"

  apply (induct t s and a b rule: alpha_rtrm1_alpha_bp.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 fv_rtrm1_eqvt)

  apply(rule conjI)

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

  apply(simp add: atom_eqvt Diff_eqvt fv_rtrm1_eqvt insert_eqvt empty_eqvt)

  apply(simp add: permute_eqvt[symmetric])

  apply (erule exE)

  apply (erule exE)

  apply (rule conjI)

  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: fv_rtrm1_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 fv_rtrm1_eqvt Diff_eqvt bv1_eqvt)

  apply(simp add: permute_eqvt[symmetric])

  apply (rule_tac x="pi \<bullet> piaa" 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: fv_rtrm1_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 fv_rtrm1_eqvt Diff_eqvt bv1_eqvt)

  apply(simp add: permute_eqvt[symmetric])

  done

lemma alpha1_equivp: "equivp alpha_rtrm1" 

  sorry

quotient_type trm1 = rtrm1 / alpha_rtrm1

  by (rule alpha1_equivp)

local_setup {*

(fn ctxt => ctxt

 |> snd o (Quotient_Def.quotient_lift_const ("Vr1", @{term rVr1}))

 |> snd o (Quotient_Def.quotient_lift_const ("Ap1", @{term rAp1}))

 |> snd o (Quotient_Def.quotient_lift_const ("Lm1", @{term rLm1}))

 |> snd o (Quotient_Def.quotient_lift_const ("Lt1", @{term rLt1}))

 |> snd o (Quotient_Def.quotient_lift_const ("fv_trm1", @{term fv_rtrm1})))

*}

print_theorems

lemma alpha_rfv1:

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

  apply(induct rule: alpha_rtrm1_alpha_bp.inducts(1))

  done

lemma [quot_respect]:

 "(op = ===> alpha_rtrm1) rVr1 rVr1"

 "(alpha_rtrm1 ===> alpha_rtrm1 ===> alpha_rtrm1) rAp1 rAp1"

 "(op = ===> alpha_rtrm1 ===> alpha_rtrm1) rLm1 rLm1"

 "(op = ===> alpha_rtrm1 ===> alpha_rtrm1 ===> alpha_rtrm1) rLt1 rLt1"

apply (rule_tac [!] x="0" in exI)

apply (simp_all add: alpha_gen fresh_star_def fresh_zero_perm alpha_rfv1 alpha_bp_eq)

done

lemma [quot_respect]:

  "(op = ===> alpha_rtrm1 ===> alpha_rtrm1) permute permute"

  by (simp add: alpha1_eqvt)

lemma [quot_respect]:

  "(alpha_rtrm1 ===> op =) fv_rtrm1 fv_rtrm1"

  by (simp add: alpha_rfv1)

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"

is

  "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 = fv_rtrm1_fv_bp.simps[quot_lifted]

lemmas fv_trm1_eqvt = fv_rtrm1_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 fv_eq_bv: "fv_bp bp = bv1 bp"

apply(induct bp rule: trm1_bp_inducts(2))

apply(simp_all)

done

lemma helper: "{b. \<forall>pi. pi \<bullet> (a \<rightleftharpoons> b) \<bullet> bp \<noteq> bp} = {}"

apply auto

apply (rule_tac x="(x \<rightleftharpoons> a)" in exI)

apply auto

done

lemma supp_fv:

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 fv_eq_bv)

apply(simp (no_asm) add: supp_def)

apply(simp add: alpha1_INJ alpha_bp_eq)

apply(simp add: Abs_eq_iff)

apply(simp add: alpha_gen)

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

apply(simp add: Collect_imp_eq Collect_neg_eq fresh_star_def helper)

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 add: supp_fv fv_trm1 fv_eq_bv)

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; bv1 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}"

setup {* snd o define_raw_perms ["rtrm2", "rassign"] ["Terms.rtrm2", "Terms.rassign"] *}

local_setup {* snd o define_fv_alpha "Terms.rtrm2"

   [[[], []]]] *}

notation

  alpha_rtrm2 ("_ \<approx>2 _" [100, 100] 100) and

  alpha_rassign ("_ \<approx>2b _" [100, 100] 100)

thm alpha_rtrm2_alpha_rassign.intros

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha2_inj}, []), (build_alpha_inj @{thms alpha_rtrm2_alpha_rassign.intros} @{thms rtrm2.distinct rtrm2.inject rassign.distinct rassign.inject} @{thms alpha_rtrm2.cases alpha_rassign.cases} ctxt)) ctxt)) *}

thm alpha2_inj

lemma alpha2_equivp:

  "equivp alpha_rtrm2"

  "equivp alpha_rassign"

  sorry

quotient_type

  trm2 = rtrm2 / alpha_rtrm2

and

  assign = rassign / alpha_rassign

  by (auto intro: alpha2_equivp)

local_setup {*

(fn ctxt => ctxt

 |> snd o (Quotient_Def.quotient_lift_const ("Vr2", @{term rVr2}))

 |> snd o (Quotient_Def.quotient_lift_const ("Ap2", @{term rAp2}))

 |> snd o (Quotient_Def.quotient_lift_const ("Lm2", @{term rLm2}))

 |> snd o (Quotient_Def.quotient_lift_const ("Lt2", @{term rLt2}))

 |> snd o (Quotient_Def.quotient_lift_const ("As", @{term rAs}))

 |> snd o (Quotient_Def.quotient_lift_const ("fv_trm2", @{term fv_rtrm2}))

 |> snd o (Quotient_Def.quotient_lift_const ("bv2", @{term rbv2})))

*}

print_theorems

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)"

setup {* snd o define_raw_perms ["rtrm3", "assigns"] ["Terms.trm3", "Terms.assigns"] *}

local_setup {* snd o define_fv_alpha "Terms.trm3"

   [[], [[], [], []]]] *}

print_theorems

notation

  alpha_trm3 ("_ \<approx>3 _" [100, 100] 100) and

  alpha_assigns ("_ \<approx>3a _" [100, 100] 100)

thm alpha_trm3_alpha_assigns.intros

lemma alpha3_equivp:

  "equivp alpha_trm3"

  "equivp alpha_assigns"

  sorry

quotient_type

  qtrm3 = trm3 / alpha_trm3

and

  qassigns = assigns / alpha_assigns

  by (auto intro: alpha3_equivp)

section {*** lam with indirect list recursion ***}

datatype trm4 =

  Vr4 "name"

| Ap4 "trm4" "trm4 list"

| Lm4 "name" "trm4"  --"bind (name) in (trm)"

print_theorems

thm trm4.recs

(* there cannot be a clause for lists, as *)

(* permutations are  already defined in Nominal (also functions, options, and so on) *)

setup {* snd o define_raw_perms ["trm4"] ["Terms.trm4"] *}

(* "repairing" of the permute function *)

lemma repaired:

  fixes ts::"trm4 list"

  shows "permute_trm4_list p ts = p \<bullet> ts"

  apply(induct ts)

  apply(simp_all)

  done