--- a/Nominal/Fv.thy Wed Mar 10 16:50:42 2010 +0100
+++ b/Nominal/Fv.thy Wed Mar 10 16:51:15 2010 +0100
@@ -238,6 +238,12 @@
end
*}
+(* Checks that a list of bindings contains only compatible ones *)
+ML {*
+fun bns_same l =
+ length (distinct (op =) (map (fn ((b, _, _), _) => b) l)) = 1
+*}
+
ML {* fn x => split_list(flat x) *}
ML {* fn x => apsnd flat (split_list (map split_list x)) *}
(* TODO: Notice datatypes without bindings and replace alpha with equality *)
@@ -321,21 +327,22 @@
let
val rel_in_simp_binds = filter (fn ((NONE, i, _), _) => i = arg_no | _ => false) bind_pis;
val rel_in_comp_binds = filter (fn ((SOME _, i, _), _) => i = arg_no | _ => false) bind_pis;
- val rel_has_binds = filter (fn ((SOME _, _, j), _) => j = arg_no | _ => false) bind_pis;
+ val rel_has_binds = filter (fn ((_, _, j), _) => j = arg_no | _ => false) bind_pis;
in
case (rel_in_simp_binds, rel_in_comp_binds, rel_has_binds) of
([], [], []) =>
if is_rec_type dt then (nth alpha_frees (body_index dt) $ arg $ arg2)
else (HOLogic.mk_eq (arg, arg2))
- (* TODO: if more then check and accept *)
| (_, [], []) => @{term True}
- | ([], [(((SOME (bn, _)), _, _), pi)], []) =>
+ | ([], ((((SOME (bn, _)), _, _), pi) :: _), []) =>
let
val alpha_bn = nth alpha_bn_frees (find_index (fn (b, _, _) => b = bn) bns) $ pi $ arg $ arg2
val ty = fastype_of (bn $ arg)
val permute = Const(@{const_name permute}, @{typ perm} --> ty --> ty)
in
- HOLogic.mk_conj (alpha_bn, HOLogic.mk_eq (permute $ pi $ (bn $ arg), (bn $ arg2)))
+ if bns_same rel_in_comp_binds then
+ HOLogic.mk_conj (alpha_bn, HOLogic.mk_eq (permute $ pi $ (bn $ arg), (bn $ arg2)))
+ else error "incompatible bindings for one argument"
end
| ([], [], relevant) =>
let
--- a/Nominal/Parser.thy Wed Mar 10 16:50:42 2010 +0100
+++ b/Nominal/Parser.thy Wed Mar 10 16:51:15 2010 +0100
@@ -278,9 +278,10 @@
val thy_name = Context.theory_name thy
val ((((raw_dt_names, (raw_bn_funs_loc, raw_bn_eqs_loc)), raw_binds), raw_bns), lthy2) =
raw_nominal_decls dts bn_funs bn_eqs binds lthy
- val bn_funs_decls = [];
+ val morphism_2_1 = ProofContext.export_morphism lthy2 lthy
+ val raw_bns_exp = map (apsnd (map (apfst (Morphism.term morphism_2_1)))) raw_bns;
+ val bn_funs_decls = flat (map (fn (ith, l) => map (fn (bn, data) => (bn, ith, data)) l) raw_bns_exp);
- val morphism_2_1 = ProofContext.export_morphism lthy2 lthy
val raw_bn_funs = map (Morphism.term morphism_2_1) raw_bn_funs_loc
val raw_bn_eqs = ProofContext.export lthy2 lthy raw_bn_eqs_loc
val dtinfo = Datatype.the_info (ProofContext.theory_of lthy2) (hd raw_dt_names);
@@ -299,11 +300,6 @@
Local_Theory.theory_result (define_raw_perms dtinfo (length dts)) lthy2;
val raw_binds_flat = map (map flat) raw_binds;
val (((fv_ts_loc, fv_def_loc), alpha), lthy4) = define_fv_alpha dtinfo raw_binds_flat bn_funs_decls lthy3;
-in
-if !restricted_nominal = 0 then
- ((raw_dt_names, raw_bn_funs, raw_bn_eqs, raw_binds), lthy4)
-else
-let
val alpha_ts_loc = #preds alpha
val morphism_4_3 = ProofContext.export_morphism lthy4 lthy3;
val fv_ts = map (Morphism.term morphism_4_3) fv_ts_loc;
@@ -321,6 +317,11 @@
val alpha_cases = ProofContext.export lthy4 lthy3 alpha_cases_loc
val alpha_inj_loc = build_alpha_inj alpha_intros (inject @ distinct) alpha_cases_loc lthy4
val alpha_inj = ProofContext.export lthy4 lthy3 alpha_inj_loc
+in
+if !restricted_nominal = 0 then
+ ((raw_dt_names, raw_bn_funs, raw_bn_eqs, raw_binds), lthy5)
+else
+let
val (bv_eqvts, lthy5) = fold_map (build_bv_eqvt perms (raw_bn_eqs @ raw_perm_def) inducts) bns lthy4;
val (fv_eqvts, lthy6) = build_eqvts Binding.empty fv_ts_loc perms
((flat (map snd bv_eqvts)) @ fv_def_loc @ raw_perm_def) induct lthy5;
--- a/Nominal/Term1.thy Wed Mar 10 16:50:42 2010 +0100
+++ b/Nominal/Term1.thy Wed Mar 10 16:51:15 2010 +0100
@@ -32,16 +32,16 @@
local_setup {*
snd o define_fv_alpha (Datatype.the_info @{theory} "Term1.rtrm1")
- [[[], [], [(NONE, 0, 1)], [(SOME @{term bv1}, 0, 2)]],
- [[], [], []]] *}
+ [[[], [], [(NONE, 0, 1)], [(SOME (@{term bv1}, true), 0, 2)]],
+ [[], [], []]] [(@{term bv1}, 1, [[], [0], [0, 1]])] *}
notation
alpha_rtrm1 ("_ \<approx>1 _" [100, 100] 100) and
alpha_bp ("_ \<approx>1b _" [100, 100] 100)
-thm alpha_rtrm1_alpha_bp.intros
+thm alpha_rtrm1_alpha_bp_alpha_bv1.intros
thm fv_rtrm1_fv_bp.simps[no_vars]
-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)) *}
+local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha1_inj}, []), (build_alpha_inj @{thms alpha_rtrm1_alpha_bp_alpha_bv1.intros} @{thms rtrm1.distinct rtrm1.inject bp.distinct bp.inject} @{thms alpha_rtrm1.cases alpha_bp.cases alpha_bv1.cases} ctxt)) ctxt)) *}
thm alpha1_inj
local_setup {*
@@ -52,9 +52,26 @@
snd o build_eqvts @{binding fv_rtrm1_fv_bp_eqvt} [@{term fv_rtrm1}, @{term fv_bp}] [@{term "permute :: perm \<Rightarrow> rtrm1 \<Rightarrow> rtrm1"},@{term "permute :: perm \<Rightarrow> bp \<Rightarrow> bp"}] (@{thms fv_rtrm1_fv_bp.simps permute_rtrm1_permute_bp.simps}) @{thm rtrm1_bp.induct}
*}
+lemma alpha1_eqvt: "(rtrm1 \<approx>1 rtrm1a \<longrightarrow> (p \<bullet> rtrm1) \<approx>1 (p \<bullet> rtrm1a)) \<and> (bp \<approx>1b bpa \<longrightarrow> (p \<bullet> bp) \<approx>1b (p \<bullet> bpa))
+ \<and> (alpha_bv1 a b c \<longrightarrow> alpha_bv1 (p \<bullet> a) (p \<bullet> b) (p \<bullet> c))"
+apply (rule alpha_rtrm1_alpha_bp_alpha_bv1.induct)
+apply (simp_all add: fv_rtrm1_fv_bp.simps permute_rtrm1_permute_bp.simps alpha1_inj)
+apply (erule exE)
+apply (rule_tac x="p \<bullet> pi" in exI)
+apply (erule alpha_gen_compose_eqvt)
+apply (simp_all add: eqvts)
+apply (erule exE)
+apply (rule_tac x="p \<bullet> pi" in exI)
+apply (rule conjI)
+apply (erule conjE)+
+apply (erule alpha_gen_compose_eqvt)
+apply (simp_all add: eqvts permute_eqvt[symmetric])
+apply (simp add: eqvts[symmetric])
+done
+(*
local_setup {*
(fn ctxt => snd (Local_Theory.note ((@{binding alpha1_eqvt}, []),
-build_alpha_eqvts [@{term alpha_rtrm1}, @{term alpha_bp}] [@{term "permute :: perm \<Rightarrow> rtrm1 \<Rightarrow> rtrm1"},@{term "permute :: perm \<Rightarrow> bp \<Rightarrow> bp"}] @{thms permute_rtrm1_permute_bp.simps alpha1_inj} @{thm alpha_rtrm1_alpha_bp.induct} ctxt) ctxt)) *}
+build_alpha_eqvts [@{term alpha_rtrm1}, @{term alpha_bp}] [@{term "permute :: perm \<Rightarrow> rtrm1 \<Rightarrow> rtrm1"},@{term "permute :: perm \<Rightarrow> bp \<Rightarrow> bp"}] @{thms permute_rtrm1_permute_bp.simps alpha1_inj} @{thm alpha_rtrm1_alpha_bp_alpha_bv1.induct} ctxt) ctxt)) *}*)
lemma alpha1_eqvt_proper[eqvt]:
"pi \<bullet> (t \<approx>1 s) = ((pi \<bullet> t) \<approx>1 (pi \<bullet> s))"
@@ -74,7 +91,7 @@
thm eqvts_raw(1)
local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha1_equivp}, []),
- (build_equivps [@{term alpha_rtrm1}, @{term alpha_bp}] @{thm rtrm1_bp.induct} @{thm alpha_rtrm1_alpha_bp.induct} @{thms rtrm1.inject bp.inject} @{thms alpha1_inj} @{thms rtrm1.distinct bp.distinct} @{thms alpha_rtrm1.cases alpha_bp.cases} @{thms alpha1_eqvt} ctxt)) ctxt)) *}
+ (build_equivps [@{term alpha_rtrm1}, @{term alpha_bp}] @{thm rtrm1_bp.induct} @{thm alpha_rtrm1_alpha_bp_alpha_bv1.induct} @{thms rtrm1.inject bp.inject} @{thms alpha1_inj} @{thms rtrm1.distinct bp.distinct} @{thms alpha_rtrm1.cases alpha_bp.cases} @{thms alpha1_eqvt} ctxt)) ctxt)) *}
thm alpha1_equivp
local_setup {* define_quotient_type [(([], @{binding trm1}, NoSyn), (@{typ rtrm1}, @{term alpha_rtrm1}))]
--- a/Nominal/Term5.thy Wed Mar 10 16:50:42 2010 +0100
+++ b/Nominal/Term5.thy Wed Mar 10 16:51:15 2010 +0100
@@ -50,16 +50,19 @@
lemma alpha5_eqvt:
"xa \<approx>5 y \<Longrightarrow> (x \<bullet> xa) \<approx>5 (x \<bullet> y)"
"xb \<approx>l ya \<Longrightarrow> (x \<bullet> xb) \<approx>l (x \<bullet> ya)"
- "alpha_rbv5 a b c \<Longrightarrow> True"
+ "alpha_rbv5 a b c \<Longrightarrow> alpha_rbv5 (x \<bullet> a) (x \<bullet> b) (x \<bullet> c)"
apply (induct rule: alpha_rtrm5_alpha_rlts_alpha_rbv5.inducts)
-apply (simp_all add: alpha5_inj)
+apply (simp_all add: alpha5_inj permute_eqvt[symmetric])
apply (erule exE)
-apply (rule_tac x="pi" in exI)
-apply clarify
-apply (simp add: alpha_gen fv_rtrm5_rlts_eqvt[symmetric] rbv5_eqvt[symmetric])
+apply (rule_tac x="x \<bullet> pi" in exI)
+apply (erule conjE)+
+apply (rule conjI)
+apply (erule alpha_gen_compose_eqvt)
+apply (simp_all add: eqvts)
+apply (simp add: permute_eqvt[symmetric])
apply (subst eqvts[symmetric])
-apply (subst eqvts[symmetric])
-sorry
+apply (simp add: eqvts)
+done
lemma alpha5_equivp:
"equivp alpha_rtrm5"
--- a/Nominal/Test.thy Wed Mar 10 16:50:42 2010 +0100
+++ b/Nominal/Test.thy Wed Mar 10 16:51:15 2010 +0100
@@ -2,29 +2,14 @@
imports "Parser" "../Attic/Prove"
begin
-text {* weirdo example from Peter Sewell's bestiary *}
-
-nominal_datatype weird =
- WBind x::"name" y::"name" p1::"weird" p2::"weird" p3::"weird"
- bind x in p1, bind x in p2, bind y in p2, bind y in p3
-| WV "name"
-| WP "weird" "weird"
-
-thm permute_weird_raw.simps[no_vars]
-thm alpha_weird_raw.intros[no_vars]
-thm fv_weird_raw.simps[no_vars]
-
-
-text {* example 1 *}
-
-(* ML {* set show_hyps *} *)
+text {* example 1, equivalent to example 2 from Terms *}
nominal_datatype lam =
VAR "name"
| APP "lam" "lam"
| LET bp::"bp" t::"lam" bind "bi bp" in t
-and bp =
- BP "name" "lam"
+and bp =
+ BP "name" "lam"
binder
bi::"bp \<Rightarrow> atom set"
where
@@ -42,21 +27,15 @@
term Test.BP_raw
thm bi_raw.simps
thm permute_lam_raw_permute_bp_raw.simps
-thm alpha_lam_raw_alpha_bp_raw.intros[no_vars]
+thm alpha_lam_raw_alpha_bp_raw_alpha_bi_raw.intros[no_vars]
thm fv_lam_raw_fv_bp_raw.simps[no_vars]
-(*thm lam_bp_induct
-thm lam_bp_perm
-thm lam_bp_fv
-thm lam_bp_bn
-thm lam_bp_inject
-thm lam_bp_distinct*)
text {* example 2 *}
nominal_datatype trm' =
Var "name"
| App "trm'" "trm'"
-| Lam x::"name" t::"trm'" bind x in t
+| Lam x::"name" t::"trm'" bind x in t
| Let p::"pat'" "trm'" t::"trm'" bind "f p" in t
and pat' =
PN
@@ -64,7 +43,7 @@
| PD "name" "name"
binder
f::"pat' \<Rightarrow> atom set"
-where
+where
"f PN = {}"
| "f (PD x y) = {atom x, atom y}"
| "f (PS x) = {atom x}"
@@ -77,7 +56,7 @@
*)
-thm alpha_trm'_raw_alpha_pat'_raw.intros[no_vars]
+thm alpha_trm'_raw_alpha_pat'_raw_alpha_f_raw.intros[no_vars]
thm fv_trm'_raw_fv_pat'_raw.simps[no_vars]
thm f_raw.simps
(*thm trm'_pat'_induct
@@ -89,7 +68,7 @@
nominal_datatype trm0 =
Var0 "name"
| App0 "trm0" "trm0"
-| Lam0 x::"name" t::"trm0" bind x in t
+| Lam0 x::"name" t::"trm0" bind x in t
| Let0 p::"pat0" "trm0" t::"trm0" bind "f0 p" in t
and pat0 =
PN0
@@ -97,7 +76,7 @@
| PD0 "pat0" "pat0"
binder
f0::"pat0 \<Rightarrow> atom set"
-where
+where
"f0 PN0 = {}"
| "f0 (PS0 x) = {atom x}"
| "f0 (PD0 p1 p2) = (f0 p1) \<union> (f0 p2)"
@@ -110,20 +89,10 @@
text {* example type schemes *}
-(* does not work yet
nominal_datatype t =
Var "name"
| Fun "t" "t"
-
-nominal_datatype tyS =
- All xs::"name list" ty::"t_raw" bind xs in ty
-*)
-
-
-nominal_datatype t =
- Var "name"
-| Fun "t" "t"
-and tyS =
+and tyS =
All xs::"name set" ty::"t" bind xs in ty
(* example 1 from Terms.thy *)
@@ -131,8 +100,8 @@
nominal_datatype trm1 =
Vr1 "name"
| Ap1 "trm1" "trm1"
-| Lm1 x::"name" t::"trm1" bind x in t
-| Lt1 p::"bp1" "trm1" t::"trm1" bind "bv1 p" in t
+| Lm1 x::"name" t::"trm1" bind x in t
+| Lt1 p::"bp1" "trm1" t::"trm1" bind "bv1 p" in t
and bp1 =
BUnit1
| BV1 "name"
@@ -147,30 +116,6 @@
thm bv1_raw.simps
-(* example 2 from Terms.thy *)
-
-nominal_datatype trm2 =
- Vr2 "name"
-| Ap2 "trm2" "trm2"
-| Lm2 x::"name" t::"trm2" bind x in t
-| Lt2 r::"assign" t::"trm2" bind "bv2 r" in t
-and assign =
- As "name" "trm2"
-binder
- bv2
-where
- "bv2 (As x t) = {atom x}"
-
-(* compat should be
-compat (As x t) pi (As x' t') == pi o x = x' & alpha t t'
-*)
-
-
-thm fv_trm2_raw_fv_assign_raw.simps[no_vars]
-thm alpha_trm2_raw_alpha_assign_raw.intros[no_vars]
-
-
-
text {* example 3 from Terms.thy *}
nominal_datatype trm3 =
@@ -193,18 +138,6 @@
compat (ACons x t ts) pi (ACons x' t' ts') \<equiv> pi o x = x' \<and> alpha t t' \<and> compat ts pi ts'
*)
-(* example 4 from Terms.thy *)
-
-(* fv_eqvt does not work, we need to repaire defined permute functions
- defined fv and defined alpha... *)
-nominal_datatype trm4 =
- Vr4 "name"
-| Ap4 "trm4" "trm4 list"
-| Lm4 x::"name" t::"trm4" bind x in t
-
-thm alpha_trm4_raw_alpha_trm4_raw_list.intros[no_vars]
-thm fv_trm4_raw_fv_trm4_raw_list.simps[no_vars]
-
(* example 5 from Terms.thy *)
nominal_datatype trm5 =
@@ -220,61 +153,6 @@
"bv5 Lnil = {}"
| "bv5 (Lcons n t ltl) = {atom n} \<union> (bv5 ltl)"
-(* example 6 from Terms.thy *)
-
-(* BV is not respectful, needs to fail*)
-nominal_datatype trm6 =
- Vr6 "name"
-| Lm6 x::"name" t::"trm6" bind x in t
-| Lt6 left::"trm6" right::"trm6" bind "bv6 left" in right
-binder
- bv6
-where
- "bv6 (Vr6 n) = {}"
-| "bv6 (Lm6 n t) = {atom n} \<union> bv6 t"
-| "bv6 (Lt6 l r) = bv6 l \<union> bv6 r"
-(* example 7 from Terms.thy *)
-
-(* BV is not respectful, needs to fail*)
-nominal_datatype trm7 =
- Vr7 "name"
-| Lm7 l::"name" r::"trm7" bind l in r
-| Lt7 l::"trm7" r::"trm7" bind "bv7 l" in r
-binder
- bv7
-where
- "bv7 (Vr7 n) = {atom n}"
-| "bv7 (Lm7 n t) = bv7 t - {atom n}"
-| "bv7 (Lt7 l r) = bv7 l \<union> bv7 r"
-
-(* example 8 from Terms.thy *)
-
-nominal_datatype foo8 =
- Foo0 "name"
-| Foo1 b::"bar8" f::"foo8" bind "bv8 b" in f --"check fo error if this is called foo"
-and bar8 =
- Bar0 "name"
-| Bar1 "name" s::"name" b::"bar8" bind s in b
-binder
- bv8
-where
- "bv8 (Bar0 x) = {}"
-| "bv8 (Bar1 v x b) = {atom v}"
-
-(* example 9 from Terms.thy *)
-
-(* BV is not respectful, needs to fail*)
-nominal_datatype lam9 =
- Var9 "name"
-| Lam9 n::"name" l::"lam9" bind n in l
-and bla9 =
- Bla9 f::"lam9" s::"lam9" bind "bv9 f" in s
-binder
- bv9
-where
- "bv9 (Var9 x) = {}"
-| "bv9 (Lam9 x b) = {atom x}"
-
(* example from my PHD *)
atom_decl coname
@@ -303,7 +181,7 @@
and body =
Empty
| Seq c::defn d::"body" bind "cbinders c" in d
-and defn =
+and defn =
Type "name" "tyty"
| Dty "name"
| DStru "name" "mexp"
@@ -311,11 +189,11 @@
and sexp =
Sig sbody
| SFunc "name" "sexp" "sexp"
-and sbody =
+and sbody =
SEmpty
| SSeq C::spec D::sbody bind "Cbinders C" in D
and spec =
- Type1 "name"
+ Type1 "name"
| Type2 "name" "tyty"
| SStru "name" "sexp"
| SVal "name" "tyty"
@@ -339,103 +217,30 @@
"cbinders (Type t T) = {atom t}"
| "cbinders (Dty t) = {atom t}"
| "cbinders (DStru x s) = {atom x}"
-| "cbinders (Val v M) = {atom v}"*)
+| "cbinders (Val v M) = {atom v}"
| "Cbinders (Type1 t) = {atom t}"
| "Cbinders (Type2 t T) = {atom t}"
| "Cbinders (SStru x S) = {atom x}"
-| "Cbinders (SVal v T) = {atom v}"
-
-
-(* core haskell *)
-print_theorems
-
-atom_decl var
-atom_decl tvar
-
-
-(* there are types, coercion types and regular types *)
-nominal_datatype tkind =
- KStar
-| KFun "tkind" "tkind"
-and ckind =
- CKEq "ty" "ty"
-and ty =
- TVar "tvar"
-| TC "string"
-| TApp "ty" "ty"
-| TFun "string" "ty list"
-| TAll tv::"tvar" "tkind" T::"ty" bind tv in T
-| TEq "ty" "ty" "ty"
-and co =
- CC "string"
-| CApp "co" "co"
-| CFun "string" "co list"
-| CAll tv::"tvar" "ckind" C::"co" bind tv in C
-| CEq "co" "co" "co"
-| CSym "co"
-| CCir "co" "co"
-| CLeft "co"
-| CRight "co"
-| CSim "co"
-| CRightc "co"
-| CLeftc "co"
-| CCoe "co" "co"
+| "Cbinders (SVal v T) = {atom v}"
-typedecl ty --"hack since ty is not yet defined"
-typedecl kind
-
-instance ty and kind:: pt
-sorry
-
-abbreviation
- "atoms A \<equiv> atom ` A"
-
-nominal_datatype trm =
- Var "var"
-| C "string"
-| LAM tv::"tvar" "kind" t::"trm" bind tv in t
-| APP "trm" "ty"
-| Lam v::"var" "ty" t::"trm" bind v in t
-| App "trm" "trm"
-| Let x::"var" "ty" "trm" t::"trm" bind x in t
-| Case "trm" "assoc list"
-| Cast "trm" "ty" --"ty is supposed to be a coercion type only"
-and assoc =
- A p::"pat" t::"trm" bind "bv p" in t
-and pat =
- K "string" "(tvar \<times> kind) list" "(var \<times> ty) list"
-binder
- bv :: "pat \<Rightarrow> atom set"
-where
- "bv (K s ts vs) = (atoms (set (map fst ts))) \<union> (atoms (set (map fst vs)))"
-
-(*
-compat (K s ts vs) pi (K s' ts' vs') ==
- s = s' &
-
-*)
-
-
-(*thm bv_raw.simps*)
-
(* example 3 from Peter Sewell's bestiary *)
nominal_datatype exp =
VarP "name"
| AppP "exp" "exp"
| LamP x::"name" e::"exp" bind x in e
-| LetP x::"name" p::"pat3" e1::"exp" e2::"exp" bind x in e2, bind "bp p" in e1
+| LetP x::"name" p::"pat3" e1::"exp" e2::"exp" bind x in e2, bind "bp' p" in e1
and pat3 =
PVar "name"
| PUnit
| PPair "pat3" "pat3"
binder
- bp :: "pat3 \<Rightarrow> atom set"
+ bp' :: "pat3 \<Rightarrow> atom set"
where
- "bp (PVar x) = {atom x}"
-| "bp (PUnit) = {}"
-| "bp (PPair p1 p2) = bp p1 \<union> bp p2"
-thm alpha_exp_raw_alpha_pat3_raw.intros
+ "bp' (PVar x) = {atom x}"
+| "bp' (PUnit) = {}"
+| "bp' (PPair p1 p2) = bp' p1 \<union> bp' p2"
+thm alpha_exp_raw_alpha_pat3_raw_alpha_bp'_raw.intros
(* example 6 from Peter Sewell's bestiary *)
nominal_datatype exp6 =
@@ -452,7 +257,9 @@
"bp6 (PVar' x) = {atom x}"
| "bp6 (PUnit') = {}"
| "bp6 (PPair' p1 p2) = bp6 p1 \<union> bp6 p2"
-thm alpha_exp6_raw_alpha_pat6_raw.intros
+thm alpha_exp6_raw_alpha_pat6_raw_alpha_bp6_raw.intros
+
+(* THE REST ARE NOT SUPPOSED TO WORK YET *)
(* example 7 from Peter Sewell's bestiary *)
nominal_datatype exp7 =
@@ -512,6 +319,163 @@
| "b_fnclause (K x pat exp8) = {atom x}"
thm alpha_exp8_raw_alpha_fnclause_raw_alpha_fnclauses_raw_alpha_lrb8_raw_alpha_lrbs8_raw_alpha_pat8_raw.intros
+(* example 4 from Terms.thy *)
+(* fv_eqvt does not work, we need to repaire defined permute functions
+ defined fv and defined alpha... *)
+nominal_datatype trm4 =
+ Vr4 "name"
+| Ap4 "trm4" "trm4 list"
+| Lm4 x::"name" t::"trm4" bind x in t
+
+thm alpha_trm4_raw_alpha_trm4_raw_list.intros[no_vars]
+thm fv_trm4_raw_fv_trm4_raw_list.simps[no_vars]
+
+(* core haskell *)
+atom_decl var
+atom_decl tvar
+
+(* there are types, coercion types and regular types *)
+nominal_datatype tkind =
+ KStar
+| KFun "tkind" "tkind"
+and ckind =
+ CKEq "ty" "ty"
+and ty =
+ TVar "tvar"
+| TC "string"
+| TApp "ty" "ty"
+| TFun "string" "ty list"
+| TAll tv::"tvar" "tkind" T::"ty" bind tv in T
+| TEq "ty" "ty" "ty"
+and co =
+ CC "string"
+| CApp "co" "co"
+| CFun "string" "co list"
+| CAll tv::"tvar" "ckind" C::"co" bind tv in C
+| CEq "co" "co" "co"
+| CSym "co"
+| CCir "co" "co"
+| CLeft "co"
+| CRight "co"
+| CSim "co"
+| CRightc "co"
+| CLeftc "co"
+| CCoe "co" "co"
+
+
+typedecl ty --"hack since ty is not yet defined"
+typedecl kind
+
+instance ty and kind:: pt
+sorry
+
+abbreviation
+ "atoms A \<equiv> atom ` A"
+
+nominal_datatype trm =
+ Var "var"
+| C "string"
+| LAM tv::"tvar" "kind" t::"trm" bind tv in t
+| APP "trm" "ty"
+| Lam v::"var" "ty" t::"trm" bind v in t
+| App "trm" "trm"
+| Let x::"var" "ty" "trm" t::"trm" bind x in t
+| Case "trm" "assoc list"
+| Cast "trm" "ty" --"ty is supposed to be a coercion type only"
+and assoc =
+ A p::"pat" t::"trm" bind "bv p" in t
+and pat =
+ K "string" "(tvar \<times> kind) list" "(var \<times> ty) list"
+binder
+ bv :: "pat \<Rightarrow> atom set"
+where
+ "bv (K s ts vs) = (atoms (set (map fst ts))) \<union> (atoms (set (map fst vs)))"
+
+(*
+compat (K s ts vs) pi (K s' ts' vs') ==
+ s = s' &
+
+*)
+
+
+
+text {* weirdo example from Peter Sewell's bestiary *}
+
+nominal_datatype weird =
+ WBind x::"name" y::"name" p1::"weird" p2::"weird" p3::"weird"
+ bind x in p1, bind x in p2, bind y in p2, bind y in p3
+| WV "name"
+| WP "weird" "weird"
+
+thm permute_weird_raw.simps[no_vars]
+thm alpha_weird_raw.intros[no_vars]
+thm fv_weird_raw.simps[no_vars]
+
+(* example 6 from Terms.thy *)
+
+(* BV is not respectful, needs to fail*)
+nominal_datatype trm6 =
+ Vr6 "name"
+| Lm6 x::"name" t::"trm6" bind x in t
+| Lt6 left::"trm6" right::"trm6" bind "bv6 left" in right
+binder
+ bv6
+where
+ "bv6 (Vr6 n) = {}"
+| "bv6 (Lm6 n t) = {atom n} \<union> bv6 t"
+| "bv6 (Lt6 l r) = bv6 l \<union> bv6 r"
+(* example 7 from Terms.thy *)
+
+(* BV is not respectful, needs to fail*)
+nominal_datatype trm7 =
+ Vr7 "name"
+| Lm7 l::"name" r::"trm7" bind l in r
+| Lt7 l::"trm7" r::"trm7" bind "bv7 l" in r
+binder
+ bv7
+where
+ "bv7 (Vr7 n) = {atom n}"
+| "bv7 (Lm7 n t) = bv7 t - {atom n}"
+| "bv7 (Lt7 l r) = bv7 l \<union> bv7 r"
+
+(* example 8 from Terms.thy *)
+
+(* Binding in a term under a bn, needs to fail *)
+nominal_datatype foo8 =
+ Foo0 "name"
+| Foo1 b::"bar8" f::"foo8" bind "bv8 b" in f --"check fo error if this is called foo"
+and bar8 =
+ Bar0 "name"
+| Bar1 "name" s::"name" b::"bar8" bind s in b
+binder
+ bv8
+where
+ "bv8 (Bar0 x) = {}"
+| "bv8 (Bar1 v x b) = {atom v}"
+
+(* example 9 from Terms.thy *)
+
+(* BV is not respectful, needs to fail*)
+nominal_datatype lam9 =
+ Var9 "name"
+| Lam9 n::"name" l::"lam9" bind n in l
+and bla9 =
+ Bla9 f::"lam9" s::"lam9" bind "bv9 f" in s
+binder
+ bv9
+where
+ "bv9 (Var9 x) = {}"
+| "bv9 (Lam9 x b) = {atom x}"
+
+
+(* Type schemes with separate datatypes *)
+nominal_datatype t =
+ Var "name"
+| Fun "t" "t"
+
+nominal_datatype tyS =
+ All xs::"name list" ty::"t_raw" bind xs in ty
+