diff -r 41137dc935ff -r 8193bbaa07fe Nominal-General/nominal_atoms.ML --- a/Nominal-General/nominal_atoms.ML Sun Nov 14 12:09:14 2010 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,83 +0,0 @@ -(* Title: nominal_atoms/ML - Authors: Brian Huffman, Christian Urban - - Command for defining concrete atom types. - - At the moment, only single-sorted atom types - are supported. -*) - -signature ATOM_DECL = -sig - val add_atom_decl: (binding * (binding option)) -> theory -> theory -end; - -structure Atom_Decl :> ATOM_DECL = -struct - -fun atom_decl_set (str : string) : term = - let - val a = Free ("a", @{typ atom}); - val s = Const (@{const_name "Sort"}, @{typ "string => atom_sort list => atom_sort"}) - $ HOLogic.mk_string str $ HOLogic.nil_const @{typ "atom_sort"}; - in - HOLogic.mk_Collect ("a", @{typ atom}, HOLogic.mk_eq (mk_sort_of a, s)) - end - -fun add_atom_decl (name : binding, arg : binding option) (thy : theory) = - let - val _ = Theory.requires thy "Nominal2_Base" "nominal logic"; - val str = Sign.full_name thy name; - - (* typedef *) - val set = atom_decl_set str; - val tac = rtac @{thm exists_eq_simple_sort} 1; - val ((full_tname, info as ({Rep_name, Abs_name, ...}, {type_definition, ...})), thy) = - Typedef.add_typedef_global false NONE (name, [], NoSyn) set NONE tac thy; - - (* definition of atom and permute *) - val newT = #abs_type (fst info); - val RepC = Const (Rep_name, newT --> @{typ atom}); - val AbsC = Const (Abs_name, @{typ atom} --> newT); - val a = Free ("a", newT); - val p = Free ("p", @{typ perm}); - val atom_eqn = - HOLogic.mk_Trueprop (HOLogic.mk_eq (mk_atom a, RepC $ a)); - val permute_eqn = - HOLogic.mk_Trueprop (HOLogic.mk_eq - (mk_perm p a, AbsC $ (mk_perm p (RepC $ a)))); - val atom_def_name = - Binding.prefix_name "atom_" (Binding.suffix_name "_def" name); - val permute_def_name = - Binding.prefix_name "permute_" (Binding.suffix_name "_def" name); - - (* at class instance *) - val lthy = - Class.instantiation ([full_tname], [], @{sort at}) thy; - val ((_, (_, permute_ldef)), lthy) = - Specification.definition (NONE, ((permute_def_name, []), permute_eqn)) lthy; - val ((_, (_, atom_ldef)), lthy) = - Specification.definition (NONE, ((atom_def_name, []), atom_eqn)) lthy; - val ctxt_thy = ProofContext.init_global (ProofContext.theory_of lthy); - val permute_def = singleton (ProofContext.export lthy ctxt_thy) permute_ldef; - val atom_def = singleton (ProofContext.export lthy ctxt_thy) atom_ldef; - val class_thm = @{thm at_class} OF [type_definition, atom_def, permute_def]; - val thy = lthy - |> Class.prove_instantiation_instance (K (Tactic.rtac class_thm 1)) - |> Local_Theory.exit_global; - in - thy - end; - -(** outer syntax **) - -local structure P = Parse and K = Keyword in - -val _ = - Outer_Syntax.command "atom_decl" "declaration of a concrete atom type" K.thy_decl - ((P.binding -- Scan.option (Args.parens (P.binding))) >> - (Toplevel.print oo (Toplevel.theory o add_atom_decl))); - -end; - -end;