diff -r 85501074fd4f -r 7566b899ca6a Quot/Nominal/Fv.thy --- a/Quot/Nominal/Fv.thy Thu Feb 18 08:43:13 2010 +0100 +++ b/Quot/Nominal/Fv.thy Thu Feb 18 09:46:38 2010 +0100 @@ -23,6 +23,11 @@ [], [[], [], [(NONE, 0)]], [[], [], [(SOME (Const f), 0), (Some (Const g), 1)]]] + +A SOME binding has to have a function returning an atom set, +and a NONE binding has to be on an argument that is an atom +or an atom set. + *) ML {* @@ -40,13 +45,24 @@ if b = noatoms then a else if b = a then noatoms else HOLogic.mk_binop @{const_name minus} (a, b); + fun mk_atoms t = + let + val ty = fastype_of t; + val atom_ty = HOLogic.dest_setT ty --> @{typ atom}; + val img_ty = atom_ty --> ty --> @{typ "atom set"}; + in + (Const (@{const_name image}, img_ty) $ Const (@{const_name atom}, atom_ty) $ t) + end; + (* Copy from Term *) + fun is_funtype (Type ("fun", [_, _])) = true + | is_funtype _ = false; *} ML {* (* Currently needs just one full_tname to access Datatype *) fun define_raw_fv full_tname bindsall lthy = let - val thy = ProofContext.theory_of lthy + val thy = ProofContext.theory_of lthy; val {descr, ...} = Datatype.the_info thy full_tname; val sorts = []; (* TODO *) fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i); @@ -64,6 +80,7 @@ fun fv_bind (NONE, i) = if is_rec_type (nth dts i) then (nth fv_frees (body_index (nth dts i))) $ (nth args i) else (* TODO we assume that all can be 'atomized' *) + if (is_funtype o fastype_of) (nth args i) then mk_atoms (nth args i) else mk_single_atom (nth args i) | fv_bind (SOME f, i) = f $ (nth args i); fun fv_arg ((dt, x), bindxs) = @@ -71,7 +88,8 @@ val arg = if is_rec_type dt then nth fv_frees (body_index dt) $ x else (* TODO: we just assume everything can be 'atomized' *) - HOLogic.mk_set @{typ atom} [mk_atom (type_of x) $ x] + if (is_funtype o fastype_of) x then mk_atoms x else + HOLogic.mk_set @{typ atom} [mk_atom (fastype_of x) $ x] val sub = mk_union (map fv_bind bindxs) in mk_diff arg sub @@ -91,9 +109,18 @@ end *} -(* test +(* tests: + atom_decl name +datatype ty = + Var "name set" + +ML {* Syntax.check_term @{context} (mk_atoms @{term "a :: name set"}) *} + +local_setup {* define_raw_fv "Fv.ty" [[[[]]]] *} +print_theorems + datatype rtrm1 = rVr1 "name" | rAp1 "rtrm1" "rtrm1"