diff -r ad38ca4213f4 -r d0ba4829a76c Nominal/Fv.thy --- a/Nominal/Fv.thy Wed Mar 10 10:11:20 2010 +0100 +++ b/Nominal/Fv.thy Wed Mar 10 10:47:21 2010 +0100 @@ -234,7 +234,7 @@ val (_, (_, _, constrs)) = nth descr ith_dtyp; val eqs = map2i alpha_bn_constr constrs args_in_bns in - ((bn, alpha_bn_name), (alpha_bn_free, eqs)) + ((bn, alpha_bn_free), (alpha_bn_name, eqs)) end *} @@ -261,9 +261,10 @@ val alpha_frees = map Free (alpha_names ~~ alpha_types); (* We assume that a bn is either recursive or not *) val bns_rec = map (fn (bn, _, _) => not (bn mem nr_bns)) bns; - - val alpha_bnfrees = map (fst o snd) (map (alpha_bn thy dt_info alpha_frees) (bns ~~ bns_rec)) - + val (bn_alpha_bns, alpha_bn_names_eqs) = split_list (map (alpha_bn thy dt_info alpha_frees) (bns ~~ bns_rec)) + val (alpha_bn_names, alpha_bn_eqs) = split_list alpha_bn_names_eqs; + val alpha_bn_frees = map snd bn_alpha_bns; + val alpha_bn_types = map fastype_of alpha_bn_frees; fun fv_alpha_constr ith_dtyp (cname, dts) bindcs = let val Ts = map (typ_of_dtyp descr sorts) dts; @@ -329,7 +330,7 @@ (* TODO: if more then check and accept *) | (_, [], []) => @{term True} | ([], [(((SOME (bn, _)), _, _), pi)], []) => - nth alpha_bnfrees (find_index (fn (b, _, _) => b = bn) bns) $ pi $ arg $ arg2 + nth alpha_bn_frees (find_index (fn (b, _, _) => b = bn) bns) $ pi $ arg $ arg2 | ([], [], relevant) => let val (rbinds, rpis) = split_list relevant @@ -380,8 +381,9 @@ val (alphas, lthy''') = (Inductive.add_inductive_i {quiet_mode = true, verbose = false, alt_name = Binding.empty, coind = false, no_elim = false, no_ind = false, skip_mono = true, fork_mono = false} - (map2 (fn x => fn y => ((Binding.name x, y), NoSyn)) alpha_names alpha_types) [] - (add_binds alpha_eqs) [] lthy'') + (map2 (fn x => fn y => ((Binding.name x, y), NoSyn)) (alpha_names @ alpha_bn_names) + (alpha_types @ alpha_bn_types)) [] + (add_binds (alpha_eqs @ flat alpha_bn_eqs)) [] lthy'') val all_fvs = (fst fvs @ fst fvs2, snd fvs @ snd fvs2) in ((all_fvs, alphas), lthy''') @@ -390,29 +392,24 @@ (* atom_decl name - datatype lam = VAR "name" | APP "lam" "lam" | LET "bp" "lam" and bp = BP "name" "lam" - primrec bi::"bp \ atom set" where "bi (BP x t) = {atom x}" - setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Fv.lam") 2 *} - - local_setup {* snd o define_fv_alpha (Datatype.the_info @{theory} "Fv.lam") - [[[], [], [(SOME (@{term bi}, false), 0, 1)]], [[]]] [(@{term bi}, 1, [[0]])] *} + [[[], [], [(SOME (@{term bi}, true), 0, 1)]], [[]]] [(@{term bi}, 1, [[0]])] *} print_theorems *) -(* +(*atom_decl name datatype rtrm1 = rVr1 "name" | rAp1 "rtrm1" "rtrm1" @@ -422,24 +419,38 @@ 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) \ (bv1 bp1)" - -setup {* snd o define_raw_perms ["rtrm1", "bp"] ["Fv.rtrm1", "Fv.bp"] *} - -local_setup {* define_fv_alpha "Fv.rtrm1" - [[[[]], [[], []], [[(NONE, 0)], [(NONE, 0)]], [[(SOME @{term bv1}, 0)], [], [(SOME @{term bv1}, 0)]]], - [[], [[]], [[], []]]] *} +setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Fv.rtrm1") 2 *} +local_setup {* + snd o define_fv_alpha (Datatype.the_info @{theory} "Fv.rtrm1") + [[[], [], [(NONE, 0, 1)], [(SOME (@{term bv1}, false), 0, 2)]], + [[], [], []]] [(@{term bv1}, 1, [[], [0], [0, 1]])] *} print_theorems *) +(* +atom_decl name +datatype rtrm5 = + rVr5 "name" +| rLt5 "rlts" "rtrm5" --"bind (bv5 lts) in (rtrm5)" +and rlts = + rLnil +| rLcons "name" "rtrm5" "rlts" +primrec + rbv5 +where + "rbv5 rLnil = {}" +| "rbv5 (rLcons n t ltl) = {atom n} \ (rbv5 ltl)" +setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Fv.rtrm5") 2 *} +local_setup {* snd o define_fv_alpha (Datatype.the_info @{theory} "Fv.rtrm5") + [[[], [(SOME (@{term rbv5}, false), 0, 1)]], [[], []]] [(@{term rbv5}, 1, [[], [0, 2]])] *} +print_theorems +*) ML {* fun alpha_inj_tac dist_inj intrs elims =