# HG changeset patch # User Christian Urban # Date 1336855149 -3600 # Node ID b6873d123f9b647012b8b09ffd008f7818933682 # Parent a6f3e1b084946be15c292ee678d740d54762443d cleaned the repository for Nominal2-Isabelle2012 diff -r a6f3e1b08494 -r b6873d123f9b Attic/FIXME-TODO --- a/Attic/FIXME-TODO Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ -Highest Priority -================ - -- give examples for the new quantifier translations in regularization - (quotient_term.ML) - - -Higher Priority -=============== - -- If the constant definition gives the wrong definition - term, one gets a cryptic message about absrep_fun - -- Handle theorems that include Ball/Bex. - Workaround: Unfolding Ball_def/Bex_def is enough to lift, - in some cases regularization is harder though. - -- The user should be able to give quotient_respects and - preserves theorems in a more natural form. - -Lower Priority -============== - -- the quot_lifted attribute should rename variables so they do not - suggest that they talk about raw terms. - -- think about what happens if things go wrong (like - theorem cannot be lifted) / proper diagnostic - messages for the user - -- inductions from the datatype package have a strange - order of quantifiers in assumptions. - -- find clean ways how to write down the "mathematical" - procedure for a possible submission (Peter submitted - his work only to TPHOLs 2005...we would have to go - maybe for the Journal of Formalised Mathematics) - -- add tests for adding theorems to the various thm lists - -- Maybe quotient and equiv theorems like the ones for - [QuotList, QuotOption, QuotPair...] could be automatically - proven? - -- Examples: Finite multiset. diff -r a6f3e1b08494 -r b6873d123f9b Attic/Fv.thy --- a/Attic/Fv.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,678 +0,0 @@ -theory Fv -imports "../Nominal-General/Nominal2_Atoms" - "Abs" "Perm" "Rsp" "Nominal2_FSet" -begin - -(* The bindings data structure: - - Bindings are a list of lists of lists of triples. - - The first list represents the datatypes defined. - The second list represents the constructors. - The internal list is a list of all the bndings that - concern the constructor. - - Every triple consists of a function, the binding and - the body. - - Eg: -nominal_datatype - - C1 - | C2 x y z bind x in z - | C3 x y z bind f x in z bind g y in z - -yields: -[ - [], - [(NONE, 0, 2)], - [(SOME (Const f), 0, 2), (Some (Const g), 1, 2)]] - -A SOME binding has to have a function which takes an appropriate -argument and returns an atom set. A NONE binding has to be on an -argument that is an atom or an atom set. -*) - -(* -An overview of the generation of free variables: - -1) fv_bn functions are generated only for the non-recursive binds. - - An fv_bn for a constructor is a union of values for the arguments: - - For an argument x that is in the bn function - - if it is a recursive argument bn' we return: fv_bn' x - - otherwise empty - - For an argument x that is not in the bn function - - for atom we return: {atom x} - - for atom set we return: atom ` x - - for a recursive call to type ty' we return: fv_ty' x - with fv of the appropriate type - - otherwise empty - -2) fv_ty functions generated for all types being defined: - - fv_ty for a constructor is a union of values for the arguments. - - For an argument that is bound in a shallow binding we return empty. - - For an argument x that bound in a non-recursive deep binding - we return: fv_bn x. - - Otherwise we return the free variables of the argument minus the - bound variables of the argument. - - The free variables for an argument x are: - - for an atom: {atom x} - - for atom set: atom ` x - - for recursive call to type ty' return: fv_ty' x - - for nominal datatype ty' return: fv_ty' x - - The bound variables are a union of results of all bindings that - involve the given argument. For a paricular binding: - - - for a binding function bn: bn x - - for a recursive argument of type ty': fv_fy' x - - for nominal datatype ty' return: fv_ty' x -*) - -(* -An overview of the generation of alpha-equivalence: - -1) alpha_bn relations are generated for binding functions. - - An alpha_bn for a constructor is true if a conjunction of - propositions for each argument holds. - - For an argument a proposition is build as follows from - th: - - - for a recursive argument in the bn function, we return: alpha_bn argl argr - - for a recursive argument for type ty not in bn, we return: alpha_ty argl argr - - for other arguments in the bn function we return: True - - for other arguments not in the bn function we return: argl = argr - -2) alpha_ty relations are generated for all the types being defined: - - For each constructor we gather all the arguments that are bound, - and for each of those we add a permutation. We associate those - permutations with the bindings. Note that two bindings can have - the same permutation if the arguments being bound are the same. - - An alpha_ty for a constructor is true if there exist permutations - as above such that a conjunction of propositions for all arguments holds. - - For an argument we allow bindings where only one of the following - holds: - - - Argument is bound in some shallow bindings: We return true - - Argument of type ty is bound recursively in some other - arguments [i1, .. in] with one binding function bn. - We return: - - (bn argl, (argl, argl_i1, ..., argl_in)) \gen - \(argl,argl1,..,argln) (argr,argr1,..,argrn). - (alpha_ty argl argr) \ (alpha_i1 argl1 argr1) \ .. \ (alpha_in argln argrn) - \(arg,arg1,..,argn). (fv_ty arg) \ (fv_i1 arg1) \ .. \ (fv_in argn) - pi - (bn argr, (argr, argr_i1, ..., argr_in)) - - - Argument is bound in some deep non-recursive bindings. - We return: alpha_bn argl argr - - Argument of type ty has some shallow bindings [b1..bn] and/or - non-recursive bindings [f1 a1, .., fm am], where the bindings - have the permutations p1..pl. We return: - - (b1l \..\ bnl \ f1 a1l \..\ fn anl, argl) \gen - alpha_ty fv_ty (p1 +..+ pl) - (b1r \..\ bnr \ f1 a1r \..\ fn anr, argr) - - - Argument has some recursive bindings. The bindings were - already treated in 2nd case so we return: True - - Argument has no bindings and is not bound. - If it is recursive for type ty, we return: alpha_ty argl argr - Otherwise we return: argl = argr - -*) - - -ML {* -datatype alpha_mode = AlphaGen | AlphaRes | AlphaLst; -*} - -ML {* -fun atyp_const AlphaGen = @{const_name alpha_gen} - | atyp_const AlphaRes = @{const_name alpha_res} - | atyp_const AlphaLst = @{const_name alpha_lst} -*} - -(* TODO: make sure that parser checks that bindings are compatible *) -ML {* -fun alpha_const_for_binds [] = atyp_const AlphaGen - | alpha_const_for_binds ((NONE, _, _, at) :: t) = atyp_const at - | alpha_const_for_binds ((SOME (_, _), _, _, at) :: _) = atyp_const at -*} - -ML {* -fun is_atom thy typ = - Sign.of_sort thy (typ, @{sort at}) - -fun is_atom_set thy (Type ("fun", [t, @{typ bool}])) = is_atom thy t - | is_atom_set _ _ = false; - -fun is_atom_fset thy (Type ("FSet.fset", [t])) = is_atom thy t - | is_atom_fset _ _ = false; -*} - - -(* Like map2, only if the second list is empty passes empty lists insted of error *) -ML {* -fun map2i _ [] [] = [] - | map2i f (x :: xs) (y :: ys) = f x y :: map2i f xs ys - | map2i f (x :: xs) [] = f x [] :: map2i f xs [] - | map2i _ _ _ = raise UnequalLengths; -*} - -(* Finds bindings with the same function and binding, and gathers all - bodys for such pairs - *) -ML {* -fun gather_binds binds = -let - fun gather_binds_cons binds = - let - val common = map (fn (f, bi, _, aty) => (f, bi, aty)) binds - val nodups = distinct (op =) common - fun find_bodys (sf, sbi, sty) = - filter (fn (f, bi, _, aty) => f = sf andalso bi = sbi andalso aty = sty) binds - val bodys = map ((map (fn (_, _, bo, _) => bo)) o find_bodys) nodups - in - nodups ~~ bodys - end -in - map (map gather_binds_cons) binds -end -*} - -ML {* -fun un_gather_binds_cons binds = - flat (map (fn (((f, bi, aty), bos), pi) => map (fn bo => ((f, bi, bo, aty), pi)) bos) binds) -*} - -ML {* - open Datatype_Aux; (* typ_of_dtyp, DtRec, ... *); -*} -ML {* - (* TODO: It is the same as one in 'nominal_atoms' *) - fun mk_atom ty = Const (@{const_name atom}, ty --> @{typ atom}); - val noatoms = @{term "{} :: atom set"}; - fun mk_single_atom x = HOLogic.mk_set @{typ atom} [mk_atom (type_of x) $ x]; - fun mk_union sets = - fold (fn a => fn b => - if a = noatoms then b else - if b = noatoms then a else - if a = b then a else - HOLogic.mk_binop @{const_name sup} (a, b)) (rev sets) noatoms; - val mk_inter = foldr1 (HOLogic.mk_binop @{const_name inf}) - fun mk_diff a b = - if b = noatoms then a else - if b = a then noatoms else - HOLogic.mk_binop @{const_name minus} (a, b); - fun mk_atom_set 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; - fun mk_atom_fset t = - let - val ty = fastype_of t; - val atom_ty = dest_fsetT ty --> @{typ atom}; - val fmap_ty = atom_ty --> ty --> @{typ "atom fset"}; - val fset_to_set = @{term "fset_to_set :: atom fset \ atom set"} - in - fset_to_set $ ((Const (@{const_name fmap}, fmap_ty) $ Const (@{const_name atom}, atom_ty) $ t)) - end; - (* Similar to one in USyntax *) - fun mk_pair (fst, snd) = - let val ty1 = fastype_of fst - val ty2 = fastype_of snd - val c = HOLogic.pair_const ty1 ty2 - in c $ fst $ snd - end; -*} - -(* Given [fv1, fv2, fv3] creates %(x, y, z). fv1 x u fv2 y u fv3 z *) -ML {* -fun mk_compound_fv fvs = -let - val nos = (length fvs - 1) downto 0; - val fvs_applied = map (fn (fv, no) => fv $ Bound no) (fvs ~~ nos); - val fvs_union = mk_union fvs_applied; - val (tyh :: tys) = rev (map (domain_type o fastype_of) fvs); - fun fold_fun ty t = HOLogic.mk_split (Abs ("", ty, t)) -in - fold fold_fun tys (Abs ("", tyh, fvs_union)) -end; -*} - -(* Given [R1, R2, R3] creates %(x,x'). %(y,y'). %(z,z'). R x x' \ R y y' \ R z z' *) -ML {* -fun mk_compound_alpha Rs = -let - val nos = (length Rs - 1) downto 0; - val nos2 = (2 * length Rs - 1) downto length Rs; - val Rs_applied = map (fn (R, (no2, no)) => R $ Bound no2 $ Bound no) (Rs ~~ (nos2 ~~ nos)); - val Rs_conj = mk_conjl Rs_applied; - val (tyh :: tys) = rev (map (domain_type o fastype_of) Rs); - fun fold_fun ty t = HOLogic.mk_split (Abs ("", ty, t)) - val abs_rhs = fold fold_fun tys (Abs ("", tyh, Rs_conj)) -in - fold fold_fun tys (Abs ("", tyh, abs_rhs)) -end; -*} - - -ML {* -fun non_rec_binds l = -let - fun is_non_rec (SOME (f, false), _, _, _) = SOME f - | is_non_rec _ = NONE -in - distinct (op =) (map_filter is_non_rec (flat (flat l))) -end -*} - -(* We assume no bindings in the type on which bn is defined *) -ML {* -fun fv_bn thy (dt_info : Datatype_Aux.info) fv_frees bn_fvbn (fvbn, (bn, ith_dtyp, args_in_bns)) = -let - val {descr, sorts, ...} = dt_info; - fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i); - fun fv_bn_constr (cname, dts) args_in_bn = - let - val Ts = map (typ_of_dtyp descr sorts) dts; - val names = Datatype_Prop.make_tnames Ts; - val args = map Free (names ~~ Ts); - val c = Const (cname, Ts ---> (nth_dtyp ith_dtyp)); - fun fv_arg ((dt, x), arg_no) = - let - val ty = fastype_of x -(* val _ = tracing ("B 1" ^ PolyML.makestring args_in_bn);*) -(* val _ = tracing ("B 2" ^ PolyML.makestring bn_fvbn);*) - in - case AList.lookup (op=) args_in_bn arg_no of - SOME NONE => @{term "{} :: atom set"} - | SOME (SOME (f : term)) => (the (AList.lookup (op=) bn_fvbn f)) $ x - | NONE => - if is_atom thy ty then mk_single_atom x else - if is_atom_set thy ty then mk_atom_set x else - if is_atom_fset thy ty then mk_atom_fset x else - if is_rec_type dt then nth fv_frees (body_index dt) $ x else - @{term "{} :: atom set"} - end; - val arg_nos = 0 upto (length dts - 1) - in - HOLogic.mk_Trueprop (HOLogic.mk_eq - (fvbn $ list_comb (c, args), mk_union (map fv_arg (dts ~~ args ~~ arg_nos)))) - end; - val (_, (_, _, constrs)) = nth descr ith_dtyp; - val eqs = map2i fv_bn_constr constrs args_in_bns -in - ((bn, fvbn), eqs) -end -*} - -ML {* print_depth 100 *} -ML {* -fun fv_bns thy dt_info fv_frees rel_bns = -let - fun mk_fvbn_free (bn, ith, _) = - let - val fvbn_name = "fv_" ^ (Long_Name.base_name (fst (dest_Const bn))); - in - (fvbn_name, Free (fvbn_name, fastype_of (nth fv_frees ith))) - end; - val (fvbn_names, fvbn_frees) = split_list (map mk_fvbn_free rel_bns); - val bn_fvbn = (map (fn (bn, _, _) => bn) rel_bns) ~~ fvbn_frees - val (l1, l2) = split_list (map (fv_bn thy dt_info fv_frees bn_fvbn) (fvbn_frees ~~ rel_bns)); -in - (l1, (fvbn_names ~~ l2)) -end -*} - - -ML {* -fun alpha_bn (dt_info : Datatype_Aux.info) alpha_frees bn_alphabn ((bn, ith_dtyp, args_in_bns), (alpha_bn_free, _ (*is_rec*) )) = -let - val {descr, sorts, ...} = dt_info; - fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i); - fun alpha_bn_constr (cname, dts) args_in_bn = - let - val Ts = map (typ_of_dtyp descr sorts) dts; - val names = Name.variant_list ["pi"] (Datatype_Prop.make_tnames Ts); - val names2 = Name.variant_list ("pi" :: names) (Datatype_Prop.make_tnames Ts); - val args = map Free (names ~~ Ts); - val args2 = map Free (names2 ~~ Ts); - val c = Const (cname, Ts ---> (nth_dtyp ith_dtyp)); - val rhs = HOLogic.mk_Trueprop - (alpha_bn_free $ (list_comb (c, args)) $ (list_comb (c, args2))); - fun lhs_arg ((dt, arg_no), (arg, arg2)) = - case AList.lookup (op=) args_in_bn arg_no of - SOME NONE => @{term True} - | SOME (SOME f) => (the (AList.lookup (op=) bn_alphabn f)) $ arg $ arg2 - | NONE => - if is_rec_type dt then (nth alpha_frees (body_index dt)) $ arg $ arg2 - else HOLogic.mk_eq (arg, arg2) - val arg_nos = 0 upto (length dts - 1) - val lhss = mk_conjl (map lhs_arg (dts ~~ arg_nos ~~ (args ~~ args2))) - val eq = Logic.mk_implies (HOLogic.mk_Trueprop lhss, rhs) - in - eq - end - val (_, (_, _, constrs)) = nth descr ith_dtyp; - val eqs = map2i alpha_bn_constr constrs args_in_bns -in - ((bn, alpha_bn_free), eqs) -end -*} - -ML {* -fun alpha_bns dt_info alpha_frees rel_bns bns_rec = -let - val {descr, sorts, ...} = dt_info; - fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i); - fun mk_alphabn_free (bn, ith, _) = - let - val alphabn_name = "alpha_" ^ (Long_Name.base_name (fst (dest_Const bn))); - val alphabn_type = nth_dtyp ith --> nth_dtyp ith --> @{typ bool}; - val alphabn_free = Free(alphabn_name, alphabn_type); - in - (alphabn_name, alphabn_free) - end; - val (alphabn_names, alphabn_frees) = split_list (map mk_alphabn_free rel_bns); - val bn_alphabn = (map (fn (bn, _, _) => bn) rel_bns) ~~ alphabn_frees; - val pair = split_list (map (alpha_bn dt_info alpha_frees bn_alphabn) - (rel_bns ~~ (alphabn_frees ~~ bns_rec))) -in - (alphabn_names, pair) -end -*} - - -(* Checks that a list of bindings contains only compatible ones *) -ML {* -fun bns_same l = - length (distinct (op =) (map (fn ((b, _, _, atyp), _) => (b, atyp)) l)) = 1 -*} - -ML {* -fun setify x = - if fastype_of x = @{typ "atom list"} then - Const (@{const_name set}, @{typ "atom list \ atom set"}) $ x else x -*} - -ML {* -fun define_fv (dt_info : Datatype_Aux.info) bindsall bns lthy = -let - val thy = ProofContext.theory_of lthy; - val {descr, sorts, ...} = dt_info; - fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i); - val fv_names = Datatype_Prop.indexify_names (map (fn (i, _) => - "fv_" ^ name_of_typ (nth_dtyp i)) descr); - val fv_types = map (fn (i, _) => nth_dtyp i --> @{typ "atom set"}) descr; - val fv_frees = map Free (fv_names ~~ fv_types); -(* TODO: We need a transitive closure, but instead we do this hack considering - all binding functions as recursive or not *) - val nr_bns = - if (non_rec_binds bindsall) = [] then [] - else map (fn (bn, _, _) => bn) bns; - val rel_bns = filter (fn (bn, _, _) => bn mem nr_bns) bns; - val (bn_fv_bns, fv_bn_names_eqs) = fv_bns thy dt_info fv_frees rel_bns; - val fvbns = map snd bn_fv_bns; - val (fv_bn_names, fv_bn_eqs) = split_list fv_bn_names_eqs; - - fun fv_constr ith_dtyp (cname, dts) bindcs = - let - val Ts = map (typ_of_dtyp descr sorts) dts; - val bindslen = length bindcs - val pi_strs_same = replicate bindslen "pi" - val pi_strs = Name.variant_list [] pi_strs_same; - val pis = map (fn ps => Free (ps, @{typ perm})) pi_strs; - val bind_pis_gath = bindcs ~~ pis; - val bind_pis = un_gather_binds_cons bind_pis_gath; - val bindcs = map fst bind_pis; - val names = Name.variant_list pi_strs (Datatype_Prop.make_tnames Ts); - val args = map Free (names ~~ Ts); - val c = Const (cname, Ts ---> (nth_dtyp ith_dtyp)); - val fv_c = nth fv_frees ith_dtyp; - val arg_nos = 0 upto (length dts - 1) - fun fv_bind args (NONE, i, _, _) = - if is_rec_type (nth dts i) then (nth fv_frees (body_index (nth dts i))) $ (nth args i) else - if ((is_atom thy) o fastype_of) (nth args i) then mk_single_atom (nth args i) else - if ((is_atom_set thy) o fastype_of) (nth args i) then mk_atom_set (nth args i) else - if ((is_atom_fset thy) o fastype_of) (nth args i) then mk_atom_fset (nth args i) else - (* TODO goes the code for preiously defined nominal datatypes *) - @{term "{} :: atom set"} - | fv_bind args (SOME (f, _), i, _, _) = f $ (nth args i) - fun fv_binds_as_set args relevant = mk_union (map (setify o fv_bind args) relevant) - fun find_nonrec_binder j (SOME (f, false), i, _, _) = if i = j then SOME f else NONE - | find_nonrec_binder _ _ = NONE - fun fv_arg ((dt, x), arg_no) = - case get_first (find_nonrec_binder arg_no) bindcs of - SOME f => - (case get_first (fn (x, y) => if x = f then SOME y else NONE) bn_fv_bns of - SOME fv_bn => fv_bn $ x - | NONE => error "bn specified in a non-rec binding but not in bn list") - | NONE => - let - val arg = - if is_rec_type dt then nth fv_frees (body_index dt) $ x else - if ((is_atom thy) o fastype_of) x then mk_single_atom x else - if ((is_atom_set thy) o fastype_of) x then mk_atom_set x else - if ((is_atom_fset thy) o fastype_of) x then mk_atom_fset x else - (* TODO goes the code for preiously defined nominal datatypes *) - @{term "{} :: atom set"}; - (* If i = j then we generate it only once *) - val relevant = filter (fn (_, i, j, _) => ((i = arg_no) orelse (j = arg_no))) bindcs; - val sub = fv_binds_as_set args relevant - in - mk_diff arg sub - end; - val fv_eq = HOLogic.mk_Trueprop (HOLogic.mk_eq - (fv_c $ list_comb (c, args), mk_union (map fv_arg (dts ~~ args ~~ arg_nos)))) - in - fv_eq - end; - fun fv_eq (i, (_, _, constrs)) binds = map2i (fv_constr i) constrs binds; - val fveqs = map2i fv_eq descr (gather_binds bindsall) - val fv_eqs_perfv = fveqs - val rel_bns_nos = map (fn (_, i, _) => i) rel_bns; - fun filter_fun (_, b) = b mem rel_bns_nos; - val all_fvs = (fv_names ~~ fv_eqs_perfv) ~~ (0 upto (length fv_names - 1)) - val (fv_names_fst, fv_eqs_fst) = apsnd flat (split_list (map fst (filter_out filter_fun all_fvs))) - val (fv_names_snd, fv_eqs_snd) = apsnd flat (split_list (map fst (filter filter_fun all_fvs))) - val fv_eqs_all = fv_eqs_fst @ (flat fv_bn_eqs); - val fv_names_all = fv_names_fst @ fv_bn_names; - val add_binds = map (fn x => (Attrib.empty_binding, x)) -(* Function_Fun.add_fun Function_Common.default_config ... true *) - val (fvs, lthy') = (Primrec.add_primrec - (map (fn s => (Binding.name s, NONE, NoSyn)) fv_names_all) (add_binds fv_eqs_all) lthy) - val (fvs2, lthy'') = - if fv_eqs_snd = [] then (([], []), lthy') else - (Primrec.add_primrec - (map (fn s => (Binding.name s, NONE, NoSyn)) fv_names_snd) (add_binds fv_eqs_snd) lthy') - val ordered_fvs = fv_frees @ fvbns; - val all_fvs = (fst fvs @ fst fvs2, snd fvs @ snd fvs2) -in - ((all_fvs, ordered_fvs), lthy'') -end -*} - -ML {* -fun define_alpha (dt_info : Datatype_Aux.info) bindsall bns fv_frees lthy = -let - val thy = ProofContext.theory_of lthy; - val {descr, sorts, ...} = dt_info; - fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i); -(* TODO: We need a transitive closure, but instead we do this hack considering - all binding functions as recursive or not *) - val nr_bns = - if (non_rec_binds bindsall) = [] then [] - else map (fn (bn, _, _) => bn) bns; - val alpha_names = Datatype_Prop.indexify_names (map (fn (i, _) => - "alpha_" ^ name_of_typ (nth_dtyp i)) descr); - val alpha_types = map (fn (i, _) => nth_dtyp i --> nth_dtyp i --> @{typ bool}) descr; - 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_bn_names, (bn_alpha_bns, alpha_bn_eqs)) = - alpha_bns dt_info alpha_frees bns bns_rec - val alpha_bn_frees = map snd bn_alpha_bns; - val alpha_bn_types = map fastype_of alpha_bn_frees; - - fun alpha_constr ith_dtyp (cname, dts) bindcs = - let - val Ts = map (typ_of_dtyp descr sorts) dts; - val bindslen = length bindcs - val pi_strs_same = replicate bindslen "pi" - val pi_strs = Name.variant_list [] pi_strs_same; - val pis = map (fn ps => Free (ps, @{typ perm})) pi_strs; - val bind_pis_gath = bindcs ~~ pis; - val bind_pis = un_gather_binds_cons bind_pis_gath; - val names = Name.variant_list pi_strs (Datatype_Prop.make_tnames Ts); - val args = map Free (names ~~ Ts); - val names2 = Name.variant_list (pi_strs @ names) (Datatype_Prop.make_tnames Ts); - val args2 = map Free (names2 ~~ Ts); - val c = Const (cname, Ts ---> (nth_dtyp ith_dtyp)); - val alpha = nth alpha_frees ith_dtyp; - val arg_nos = 0 upto (length dts - 1) - fun fv_bind args (NONE, i, _, _) = - if is_rec_type (nth dts i) then (nth fv_frees (body_index (nth dts i))) $ (nth args i) else - if ((is_atom thy) o fastype_of) (nth args i) then mk_single_atom (nth args i) else - if ((is_atom_set thy) o fastype_of) (nth args i) then mk_atom_set (nth args i) else - if ((is_atom_fset thy) o fastype_of) (nth args i) then mk_atom_fset (nth args i) else - (* TODO goes the code for preiously defined nominal datatypes *) - @{term "{} :: atom set"} - | fv_bind args (SOME (f, _), i, _, _) = f $ (nth args i) - fun fv_binds args relevant = mk_union (map (fv_bind args) relevant) - val alpha_rhs = - HOLogic.mk_Trueprop (alpha $ (list_comb (c, args)) $ (list_comb (c, args2))); - fun alpha_arg ((dt, arg_no), (arg, arg2)) = - 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 ((NONE, _, j, _), _) => j = arg_no - | ((SOME (_, false), _, j, _), _) => j = arg_no - | _ => false) bind_pis; - val rel_has_rec_binds = filter - (fn ((SOME (_, true), _, j, _), _) => j = arg_no | _ => false) bind_pis; - in - case (rel_in_simp_binds, rel_in_comp_binds, rel_has_binds, rel_has_rec_binds) of - ([], [], [], []) => - if is_rec_type dt then (nth alpha_frees (body_index dt) $ arg $ arg2) - else (HOLogic.mk_eq (arg, arg2)) - | (_, [], [], []) => @{term True} - | ([], [], [], _) => @{term True} - | ([], ((((SOME (bn, is_rec)), _, _, atyp), _) :: _), [], []) => - if not (bns_same rel_in_comp_binds) then error "incompatible bindings for an argument" else - if is_rec then - let - val (rbinds, rpis) = split_list rel_in_comp_binds - val bound_in_nos = map (fn (_, _, i, _) => i) rbinds - val bound_in_ty_nos = map (fn i => body_index (nth dts i)) bound_in_nos; - val bound_args = arg :: map (nth args) bound_in_nos; - val bound_args2 = arg2 :: map (nth args2) bound_in_nos; - val lhs_binds = fv_binds args rbinds - val lhs_arg = foldr1 HOLogic.mk_prod bound_args - val lhs = mk_pair (lhs_binds, lhs_arg); - val rhs_binds = fv_binds args2 rbinds; - val rhs_arg = foldr1 HOLogic.mk_prod bound_args2; - val rhs = mk_pair (rhs_binds, rhs_arg); - val fvs = map (nth fv_frees) ((body_index dt) :: bound_in_ty_nos); - val fv = mk_compound_fv fvs; - val alphas = map (nth alpha_frees) ((body_index dt) :: bound_in_ty_nos); - val alpha = mk_compound_alpha alphas; - val pi = foldr1 (uncurry mk_plus) (distinct (op =) rpis); - val alpha_gen_pre = Const (atyp_const atyp, dummyT) $ lhs $ alpha $ fv $ pi $ rhs; - val alpha_gen = Syntax.check_term lthy alpha_gen_pre - in - alpha_gen - end - else - let - val alpha_bn_const = - nth alpha_bn_frees (find_index (fn (b, _, _) => b = bn) bns) - in - alpha_bn_const $ arg $ arg2 - end - | ([], [], relevant, []) => - let - val (rbinds, rpis) = split_list relevant - val lhs_binds = fv_binds args rbinds - val lhs = mk_pair (lhs_binds, arg); - val rhs_binds = fv_binds args2 rbinds; - val rhs = mk_pair (rhs_binds, arg2); - val alpha = nth alpha_frees (body_index dt); - val fv = nth fv_frees (body_index dt); - val pi = foldr1 (uncurry mk_plus) (distinct (op =) rpis); - val alpha_const = alpha_const_for_binds rbinds; - val alpha_gen_pre = Const (alpha_const, dummyT) $ lhs $ alpha $ fv $ pi $ rhs; - val alpha_gen = Syntax.check_term lthy alpha_gen_pre - in - alpha_gen - end - | _ => error "Fv.alpha: not supported binding structure" - end - val alphas = map alpha_arg (dts ~~ arg_nos ~~ (args ~~ args2)) - val alpha_lhss = mk_conjl alphas - val alpha_lhss_ex = - fold (fn pi_str => fn t => HOLogic.mk_exists (pi_str, @{typ perm}, t)) pi_strs alpha_lhss - val alpha_eq = Logic.mk_implies (HOLogic.mk_Trueprop alpha_lhss_ex, alpha_rhs) - in - alpha_eq - end; - fun alpha_eq (i, (_, _, constrs)) binds = map2i (alpha_constr i) constrs binds; - val alphaeqs = map2i alpha_eq descr (gather_binds bindsall) - val alpha_eqs = flat alphaeqs - val add_binds = map (fn x => (Attrib.empty_binding, x)) - 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_bn_names) - (alpha_types @ alpha_bn_types)) [] - (add_binds (alpha_eqs @ flat alpha_bn_eqs)) [] lthy) -in - (alphas, lthy') -end -*} - - -ML {* -fun define_fv_alpha_export dt binds bns ctxt = -let - val (((fv_ts_loc, fv_def_loc), ord_fv_ts_loc), ctxt') = - define_fv dt binds bns ctxt; - val (alpha, ctxt'') = - define_alpha dt binds bns fv_ts_loc ctxt'; - val alpha_ts_loc = #preds alpha - val alpha_induct_loc = #induct alpha - val alpha_intros_loc = #intrs alpha; - val alpha_cases_loc = #elims alpha - val morphism = ProofContext.export_morphism ctxt'' ctxt; - val fv_ts = map (Morphism.term morphism) fv_ts_loc; - val ord_fv_ts = map (Morphism.term morphism) ord_fv_ts_loc; - val fv_def = Morphism.fact morphism fv_def_loc; - val alpha_ts = map (Morphism.term morphism) alpha_ts_loc; - val alpha_induct = Morphism.thm morphism alpha_induct_loc; - val alpha_intros = Morphism.fact morphism alpha_intros_loc - val alpha_cases = Morphism.fact morphism alpha_cases_loc -in - ((((fv_ts, ord_fv_ts), fv_def), ((alpha_ts, alpha_intros), (alpha_cases, alpha_induct))), ctxt'') -end; -*} - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/IsaMakefile --- a/Attic/IsaMakefile Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,45 +0,0 @@ - -## targets - -default: Quot -images: - -all: Quot - - -## global settings - -SRC = $(ISABELLE_HOME)/src -OUT = $(ISABELLE_OUTPUT) -LOG = $(OUT)/log - -USEDIR = $(ISABELLE_TOOL) usedir -v true -t true ##-D generated - - -## Quot - -Quot: $(LOG)/HOL-Quot.gz - -$(LOG)/HOL-Quot.gz: Quot/ROOT.ML Quot/*.thy - @$(USEDIR) HOL-Plain Quot - -paper: $(LOG)/HOL-Quot-Paper.gz - -$(LOG)/HOL-Quot-Paper.gz: Paper/ROOT.ML Paper/document/root.tex Paper/*.thy - @$(USEDIR) -D generated HOL Paper - $(ISATOOL) document -o pdf Paper/generated - @cp Paper/document.pdf paper.pdf - -keywords: - mkdir -p tmp - cp $(ISABELLE_HOME)/heaps/polyml-5.3.0_x86-linux/log/Pure.gz tmp - cp $(ISABELLE_HOME)/heaps/polyml-5.3.0_x86-linux/log/HOL.gz tmp - cp $(ISABELLE_HOME)/heaps/polyml-5.3.0_x86-linux/log/Pure-ProofGeneral.gz tmp - cp $(ISABELLE_HOME)/heaps/polyml-5.3.0_x86-linux/log/HOL-Nominal.gz tmp - cp $(LOG)/HOL-Nominal-Quot.gz tmp - isabelle keywords -k quot tmp/* - -## clean - -clean: - @rm -f $(LOG)/HOL-Quot.gz diff -r a6f3e1b08494 -r b6873d123f9b Attic/Parser.thy --- a/Attic/Parser.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,670 +0,0 @@ -theory Parser -imports "../Nominal-General/Nominal2_Atoms" - "../Nominal-General/Nominal2_Eqvt" - "../Nominal-General/Nominal2_Supp" - "Perm" "Equivp" "Rsp" "Lift" "Fv" -begin - -section{* Interface for nominal_datatype *} - -text {* - -Nominal-Datatype-part: - - -1nd Arg: (string list * binding * mixfix * (binding * typ list * mixfix) list) list - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - type(s) to be defined constructors list - (ty args, name, syn) (name, typs, syn) - -Binder-Function-part: - -2rd Arg: (binding * typ option * mixfix) list - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - binding function(s) - to be defined - (name, type, syn) - -3th Arg: term list - ^^^^^^^^^ - the equations of the binding functions - (Trueprop equations) -*} - -ML {* - -*} - -text {*****************************************************} -ML {* -(* nominal datatype parser *) -local - structure P = OuterParse - - fun tuple ((x, y, z), u) = (x, y, z, u) - fun tswap (((x, y), z), u) = (x, y, u, z) -in - -val _ = OuterKeyword.keyword "bind" -val anno_typ = Scan.option (P.name --| P.$$$ "::") -- P.typ - -(* binding specification *) -(* maybe use and_list *) -val bind_parser = - P.enum "," ((P.$$$ "bind" |-- P.term) -- (P.$$$ "in" |-- P.name) >> swap) - -val constr_parser = - P.binding -- Scan.repeat anno_typ - -(* datatype parser *) -val dt_parser = - (P.type_args -- P.binding -- P.opt_mixfix >> P.triple1) -- - (P.$$$ "=" |-- P.enum1 "|" (constr_parser -- bind_parser -- P.opt_mixfix >> tswap)) >> tuple - -(* function equation parser *) -val fun_parser = - Scan.optional (P.$$$ "binder" |-- P.fixes -- SpecParse.where_alt_specs) ([],[]) - -(* main parser *) -val main_parser = - (P.and_list1 dt_parser) -- fun_parser >> P.triple2 - -end -*} - -(* adds "_raw" to the end of constants and types *) -ML {* -fun add_raw s = s ^ "_raw" -fun add_raws ss = map add_raw ss -fun raw_bind bn = Binding.suffix_name "_raw" bn - -fun replace_str ss s = - case (AList.lookup (op=) ss s) of - SOME s' => s' - | NONE => s - -fun replace_typ ty_ss (Type (a, Ts)) = Type (replace_str ty_ss a, map (replace_typ ty_ss) Ts) - | replace_typ ty_ss T = T - -fun raw_dts ty_ss dts = -let - - fun raw_dts_aux1 (bind, tys, mx) = - (raw_bind bind, map (replace_typ ty_ss) tys, mx) - - fun raw_dts_aux2 (ty_args, bind, mx, constrs) = - (ty_args, raw_bind bind, mx, map raw_dts_aux1 constrs) -in - map raw_dts_aux2 dts -end - -fun replace_aterm trm_ss (Const (a, T)) = Const (replace_str trm_ss a, T) - | replace_aterm trm_ss (Free (a, T)) = Free (replace_str trm_ss a, T) - | replace_aterm trm_ss trm = trm - -fun replace_term trm_ss ty_ss trm = - trm |> Term.map_aterms (replace_aterm trm_ss) |> map_types (replace_typ ty_ss) -*} - -ML {* -fun get_cnstrs dts = - map (fn (_, _, _, constrs) => constrs) dts - -fun get_typed_cnstrs dts = - flat (map (fn (_, bn, _, constrs) => - (map (fn (bn', _, _) => (Binding.name_of bn, Binding.name_of bn')) constrs)) dts) - -fun get_cnstr_strs dts = - map (fn (bn, _, _) => Binding.name_of bn) (flat (get_cnstrs dts)) - -fun get_bn_fun_strs bn_funs = - map (fn (bn_fun, _, _) => Binding.name_of bn_fun) bn_funs -*} - -ML {* -fun rawify_dts dt_names dts dts_env = -let - val raw_dts = raw_dts dts_env dts - val raw_dt_names = add_raws dt_names -in - (raw_dt_names, raw_dts) -end -*} - -ML {* -fun rawify_bn_funs dts_env cnstrs_env bn_fun_env bn_funs bn_eqs = -let - val bn_funs' = map (fn (bn, ty, mx) => - (raw_bind bn, replace_typ dts_env ty, mx)) bn_funs - - val bn_eqs' = map (fn (attr, trm) => - (attr, replace_term (cnstrs_env @ bn_fun_env) dts_env trm)) bn_eqs -in - (bn_funs', bn_eqs') -end -*} - -ML {* -fun apfst3 f (a, b, c) = (f a, b, c) -*} - -ML {* -fun rawify_binds dts_env cnstrs_env bn_fun_env binds = - map (map (map (map (fn (opt_trm, i, j, aty) => - (Option.map (apfst (replace_term (cnstrs_env @ bn_fun_env) dts_env)) opt_trm, i, j, aty))))) binds -*} - -ML {* -fun find [] _ = error ("cannot find element") - | find ((x, z)::xs) y = if (Long_Name.base_name x) = y then z else find xs y -*} - -ML {* -fun strip_bn_fun t = - case t of - Const (@{const_name sup}, _) $ l $ r => strip_bn_fun l @ strip_bn_fun r - | Const (@{const_name append}, _) $ l $ r => strip_bn_fun l @ strip_bn_fun r - | Const (@{const_name insert}, _) $ (Const (@{const_name atom}, _) $ Bound i) $ y => - (i, NONE) :: strip_bn_fun y - | Const (@{const_name Cons}, _) $ (Const (@{const_name atom}, _) $ Bound i) $ y => - (i, NONE) :: strip_bn_fun y - | Const (@{const_name bot}, _) => [] - | Const (@{const_name Nil}, _) => [] - | (f as Free _) $ Bound i => [(i, SOME f)] - | _ => error ("Unsupported binding function: " ^ (PolyML.makestring t)) -*} - -ML {* -fun prep_bn dt_names dts eqs = -let - fun aux eq = - let - val (lhs, rhs) = eq - |> strip_qnt_body "all" - |> HOLogic.dest_Trueprop - |> HOLogic.dest_eq - val (bn_fun, [cnstr]) = strip_comb lhs - val (_, ty) = dest_Free bn_fun - val (ty_name, _) = dest_Type (domain_type ty) - val dt_index = find_index (fn x => x = ty_name) dt_names - val (cnstr_head, cnstr_args) = strip_comb cnstr - val rhs_elements = strip_bn_fun rhs - val included = map (apfst (fn i => length (cnstr_args) - i - 1)) rhs_elements - in - (dt_index, (bn_fun, (cnstr_head, included))) - end - fun order dts i ts = - let - val dt = nth dts i - val cts = map (fn (x, _, _) => Binding.name_of x) ((fn (_, _, _, x) => x) dt) - val ts' = map (fn (x, y) => (fst (dest_Const x), y)) ts - in - map (find ts') cts - end - - val unordered = AList.group (op=) (map aux eqs) - val unordered' = map (fn (x, y) => (x, AList.group (op=) y)) unordered - val ordered = map (fn (x, y) => (x, map (fn (v, z) => (v, order dts x z)) y)) unordered' -in - ordered -end -*} - -ML {* -fun add_primrec_wrapper funs eqs lthy = - if null funs then (([], []), lthy) - else - let - val eqs' = map (fn (_, eq) => (Attrib.empty_binding, eq)) eqs - val funs' = map (fn (bn, ty, mx) => (bn, SOME ty, mx)) funs - in - Primrec.add_primrec funs' eqs' lthy - end -*} - -ML {* -fun add_datatype_wrapper dt_names dts = -let - val conf = Datatype.default_config -in - Local_Theory.theory_result (Datatype.add_datatype conf dt_names dts) -end -*} - -ML {* -fun raw_nominal_decls dts bn_funs bn_eqs binds lthy = -let - val thy = ProofContext.theory_of lthy - val thy_name = Context.theory_name thy - - val dt_names = map (fn (_, s, _, _) => Binding.name_of s) dts - val dt_full_names = map (Long_Name.qualify thy_name) dt_names - val dt_full_names' = add_raws dt_full_names - val dts_env = dt_full_names ~~ dt_full_names' - - val cnstrs = get_cnstr_strs dts - val cnstrs_ty = get_typed_cnstrs dts - val cnstrs_full_names = map (Long_Name.qualify thy_name) cnstrs - val cnstrs_full_names' = map (fn (x, y) => Long_Name.qualify thy_name - (Long_Name.qualify (add_raw x) (add_raw y))) cnstrs_ty - val cnstrs_env = cnstrs_full_names ~~ cnstrs_full_names' - - val bn_fun_strs = get_bn_fun_strs bn_funs - val bn_fun_strs' = add_raws bn_fun_strs - val bn_fun_env = bn_fun_strs ~~ bn_fun_strs' - val bn_fun_full_env = map (pairself (Long_Name.qualify thy_name)) - (bn_fun_strs ~~ bn_fun_strs') - - val (raw_dt_names, raw_dts) = rawify_dts dt_names dts dts_env - - val (raw_bn_funs, raw_bn_eqs) = rawify_bn_funs dts_env cnstrs_env bn_fun_env bn_funs bn_eqs - - val raw_binds = rawify_binds dts_env cnstrs_env bn_fun_full_env binds - - val raw_bns = prep_bn dt_full_names' raw_dts (map snd raw_bn_eqs) - -(*val _ = tracing (cat_lines (map PolyML.makestring raw_bns))*) -in - lthy - |> add_datatype_wrapper raw_dt_names raw_dts - ||>> add_primrec_wrapper raw_bn_funs raw_bn_eqs - ||>> pair raw_binds - ||>> pair raw_bns -end -*} - -lemma equivp_hack: "equivp x" -sorry -ML {* -fun equivp_hack ctxt rel = -let - val thy = ProofContext.theory_of ctxt - val ty = domain_type (fastype_of rel) - val cty = ctyp_of thy ty - val ct = cterm_of thy rel -in - Drule.instantiate' [SOME cty] [SOME ct] @{thm equivp_hack} -end -*} - -ML {* val cheat_alpha_eqvt = Unsynchronized.ref false *} -ML {* val cheat_equivp = Unsynchronized.ref false *} -ML {* val cheat_fv_rsp = Unsynchronized.ref false *} -ML {* val cheat_const_rsp = Unsynchronized.ref false *} - -(* nominal_datatype2 does the following things in order: - -Parser.thy/raw_nominal_decls - 1) define the raw datatype - 2) define the raw binding functions - -Perm.thy/define_raw_perms - 3) define permutations of the raw datatype and show that the raw type is - in the pt typeclass - -Lift.thy/define_fv_alpha_export, Fv.thy/define_fv & define_alpha - 4) define fv and fv_bn - 5) define alpha and alpha_bn - -Perm.thy/distinct_rel - 6) prove alpha_distincts (C1 x \ C2 y ...) (Proof by cases; simp) - -Tacs.thy/build_rel_inj - 6) prove alpha_eq_iff (C1 x = C2 y \ P x y ...) - (left-to-right by intro rule, right-to-left by cases; simp) -Equivp.thy/prove_eqvt - 7) prove bn_eqvt (common induction on the raw datatype) - 8) prove fv_eqvt (common induction on the raw datatype with help of above) -Rsp.thy/build_alpha_eqvts - 9) prove alpha_eqvt and alpha_bn_eqvt - (common alpha-induction, unfolding alpha_gen, permute of #* and =) -Equivp.thy/build_alpha_refl & Equivp.thy/build_equivps - 10) prove that alpha and alpha_bn are equivalence relations - (common induction and application of 'compose' lemmas) -Lift.thy/define_quotient_types - 11) define quotient types -Rsp.thy/build_fvbv_rsps - 12) prove bn respects (common induction and simp with alpha_gen) -Rsp.thy/prove_const_rsp - 13) prove fv respects (common induction and simp with alpha_gen) - 14) prove permute respects (unfolds to alpha_eqvt) -Rsp.thy/prove_alpha_bn_rsp - 15) prove alpha_bn respects - (alpha_induct then cases then sym and trans of the relations) -Rsp.thy/prove_alpha_alphabn - 16) show that alpha implies alpha_bn (by unduction, needed in following step) -Rsp.thy/prove_const_rsp - 17) prove respects for all datatype constructors - (unfold eq_iff and alpha_gen; introduce zero permutations; simp) -Perm.thy/quotient_lift_consts_export - 18) define lifted constructors, fv, bn, alpha_bn, permutations -Perm.thy/define_lifted_perms - 19) lift permutation zero and add properties to show that quotient type is in the pt typeclass -Lift.thy/lift_thm - 20) lift permutation simplifications - 21) lift induction - 22) lift fv - 23) lift bn - 24) lift eq_iff - 25) lift alpha_distincts - 26) lift fv and bn eqvts -Equivp.thy/prove_supports - 27) prove that union of arguments supports constructors -Equivp.thy/prove_fs - 28) show that the lifted type is in fs typeclass (* by q_induct, supports *) -Equivp.thy/supp_eq - 29) prove supp = fv -*) -ML {* -fun nominal_datatype2 dts bn_funs bn_eqs binds lthy = -let - val _ = tracing "Raw declarations"; - val thy = ProofContext.theory_of lthy - 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 morphism_2_1 = ProofContext.export_morphism lthy2 lthy - fun export_fun f (t, l) = (f t, map (map (apsnd (Option.map f))) l); - val raw_bns_exp = map (apsnd (map (export_fun (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 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); - val {descr, sorts, ...} = dtinfo; - fun nth_dtyp i = Datatype_Aux.typ_of_dtyp descr sorts (Datatype_Aux.DtRec i); - val raw_tys = map (fn (i, _) => nth_dtyp i) descr; - val all_typs = map (fn i => Datatype_Aux.typ_of_dtyp descr sorts (Datatype_Aux.DtRec i)) (map fst descr) - val all_full_tnames = map (fn (_, (n, _, _)) => n) descr; - val dtinfos = map (Datatype.the_info (ProofContext.theory_of lthy2)) all_full_tnames; - val rel_dtinfos = List.take (dtinfos, (length dts)); - val inject = flat (map #inject dtinfos); - val distincts = flat (map #distinct dtinfos); - val rel_distinct = map #distinct rel_dtinfos; - val induct = #induct dtinfo; - val exhausts = map #exhaust dtinfos; - val _ = tracing "Defining permutations, fv and alpha"; - val ((raw_perm_def, raw_perm_simps, perms), lthy3) = - Local_Theory.theory_result (define_raw_perms dtinfo (length dts)) lthy2; - val raw_binds_flat = map (map flat) raw_binds; - val ((((_, fv_ts), fv_def), ((alpha_ts, alpha_intros), (alpha_cases, alpha_induct))), lthy4) = - define_fv_alpha_export dtinfo raw_binds_flat bn_funs_decls lthy3; - val (fv, fvbn) = chop (length perms) fv_ts; - - val (alpha_ts_nobn, alpha_ts_bn) = chop (length fv) alpha_ts - val dts_names = map (fn (i, (s, _, _)) => (s, i)) (#descr dtinfo); - val bn_tys = map (domain_type o fastype_of) raw_bn_funs; - val bn_nos = map (dtyp_no_of_typ dts_names) bn_tys; - val bns = raw_bn_funs ~~ bn_nos; - val rel_dists = flat (map (distinct_rel lthy4 alpha_cases) - (rel_distinct ~~ alpha_ts_nobn)); - val rel_dists_bn = flat (map (distinct_rel lthy4 alpha_cases) - ((map (fn i => nth rel_distinct i) bn_nos) ~~ alpha_ts_bn)) - val alpha_eq_iff = build_rel_inj alpha_intros (inject @ distincts) alpha_cases lthy4 - val _ = tracing "Proving equivariance"; - val (bv_eqvt, lthy5) = prove_eqvt raw_tys induct (raw_bn_eqs @ raw_perm_def) (map fst bns) lthy4 - val (fv_eqvt, lthy6) = prove_eqvt raw_tys induct (fv_def @ raw_perm_def) (fv @ fvbn) lthy5 - fun alpha_eqvt_tac' _ = - if !cheat_alpha_eqvt then Skip_Proof.cheat_tac thy - else alpha_eqvt_tac alpha_induct (raw_perm_def @ alpha_eq_iff) lthy6 1 - val alpha_eqvt = build_alpha_eqvts alpha_ts alpha_eqvt_tac' lthy6; - val _ = tracing "Proving equivalence"; - val fv_alpha_all = combine_fv_alpha_bns (fv, fvbn) (alpha_ts_nobn, alpha_ts_bn) bn_nos; - val reflps = build_alpha_refl fv_alpha_all alpha_ts induct alpha_eq_iff lthy6; - val alpha_equivp = - if !cheat_equivp then map (equivp_hack lthy6) alpha_ts_nobn - else build_equivps alpha_ts reflps alpha_induct - inject alpha_eq_iff distincts alpha_cases alpha_eqvt lthy6; - val qty_binds = map (fn (_, b, _, _) => b) dts; - val qty_names = map Name.of_binding qty_binds; - val qty_full_names = map (Long_Name.qualify thy_name) qty_names - val (qtys, lthy7) = define_quotient_types qty_binds all_typs alpha_ts_nobn alpha_equivp lthy6; - val const_names = map Name.of_binding (flat (map (fn (_, _, _, t) => map (fn (b, _, _) => b) t) dts)); - val raw_consts = - flat (map (fn (i, (_, _, l)) => - map (fn (cname, dts) => - Const (cname, map (Datatype_Aux.typ_of_dtyp descr sorts) dts ---> - Datatype_Aux.typ_of_dtyp descr sorts (Datatype_Aux.DtRec i))) l) descr); - val (consts, const_defs, lthy8) = quotient_lift_consts_export qtys (const_names ~~ raw_consts) lthy7; - val _ = tracing "Proving respects"; - val bns_rsp_pre' = build_fvbv_rsps alpha_ts alpha_induct raw_bn_eqs (map fst bns) lthy8; - val (bns_rsp_pre, lthy9) = fold_map ( - fn (bn_t, _) => prove_const_rsp qtys Binding.empty [bn_t] (fn _ => - resolve_tac bns_rsp_pre' 1)) bns lthy8; - val bns_rsp = flat (map snd bns_rsp_pre); - fun fv_rsp_tac _ = if !cheat_fv_rsp then Skip_Proof.cheat_tac thy - else fvbv_rsp_tac alpha_induct fv_def lthy8 1; - val fv_rsps = prove_fv_rsp fv_alpha_all alpha_ts fv_rsp_tac lthy9; - val (fv_rsp_pre, lthy10) = fold_map - (fn fv => fn ctxt => prove_const_rsp qtys Binding.empty [fv] - (fn _ => asm_simp_tac (HOL_ss addsimps fv_rsps) 1) ctxt) (fv @ fvbn) lthy9; - val fv_rsp = flat (map snd fv_rsp_pre); - val (perms_rsp, lthy11) = prove_const_rsp qtys Binding.empty perms - (fn _ => asm_simp_tac (HOL_ss addsimps alpha_eqvt) 1) lthy10; - val alpha_bn_rsp_pre = prove_alpha_bn_rsp alpha_ts alpha_induct (alpha_eq_iff @ rel_dists @ rel_dists_bn) alpha_equivp exhausts alpha_ts_bn lthy11; - val (alpha_bn_rsps, lthy11a) = fold_map (fn cnst => prove_const_rsp qtys Binding.empty [cnst] - (fn _ => asm_simp_tac (HOL_ss addsimps alpha_bn_rsp_pre) 1)) alpha_ts_bn lthy11 -(* val _ = map tracing (map PolyML.makestring alpha_bn_rsps);*) - fun const_rsp_tac _ = - if !cheat_const_rsp then Skip_Proof.cheat_tac thy - else let val alpha_alphabn = prove_alpha_alphabn alpha_ts alpha_induct alpha_eq_iff alpha_ts_bn lthy11a - in constr_rsp_tac alpha_eq_iff (fv_rsp @ bns_rsp @ reflps @ alpha_alphabn) 1 end - val (const_rsps, lthy12) = fold_map (fn cnst => prove_const_rsp qtys Binding.empty [cnst] - const_rsp_tac) raw_consts lthy11a - val qfv_names = map (unsuffix "_raw" o Long_Name.base_name o fst o dest_Const) (fv @ fvbn) - val (qfv_ts, qfv_defs, lthy12a) = quotient_lift_consts_export qtys (qfv_names ~~ (fv @ fvbn)) lthy12; - val (qfv_ts_nobn, qfv_ts_bn) = chop (length perms) qfv_ts; - val qbn_names = map (fn (b, _ , _) => Name.of_binding b) bn_funs - val (qbn_ts, qbn_defs, lthy12b) = quotient_lift_consts_export qtys (qbn_names ~~ raw_bn_funs) lthy12a; - val qalpha_bn_names = map (unsuffix "_raw" o Long_Name.base_name o fst o dest_Const) alpha_ts_bn - val (qalpha_ts_bn, qalphabn_defs, lthy12c) = quotient_lift_consts_export qtys (qalpha_bn_names ~~ alpha_ts_bn) lthy12b; - val _ = tracing "Lifting permutations"; - val thy = Local_Theory.exit_global lthy12c; - val perm_names = map (fn x => "permute_" ^ x) qty_names - val thy' = define_lifted_perms qtys qty_full_names (perm_names ~~ perms) raw_perm_simps thy; - val lthy13 = Theory_Target.init NONE thy'; - val q_name = space_implode "_" qty_names; - fun suffix_bind s = Binding.qualify true q_name (Binding.name s); - val _ = tracing "Lifting induction"; - val constr_names = map (Long_Name.base_name o fst o dest_Const) consts; - val q_induct = Rule_Cases.name constr_names (lift_thm qtys lthy13 induct); - fun note_suffix s th ctxt = - snd (Local_Theory.note ((suffix_bind s, []), th) ctxt); - fun note_simp_suffix s th ctxt = - snd (Local_Theory.note ((suffix_bind s, [Attrib.internal (K Simplifier.simp_add)]), th) ctxt); - val (_, lthy14) = Local_Theory.note ((suffix_bind "induct", - [Attrib.internal (K (Rule_Cases.case_names constr_names))]), [Rule_Cases.name constr_names q_induct]) lthy13; - val q_inducts = Project_Rule.projects lthy13 (1 upto (length fv)) q_induct - val (_, lthy14a) = Local_Theory.note ((suffix_bind "inducts", []), q_inducts) lthy14; - val q_perm = map (lift_thm qtys lthy14) raw_perm_def; - val lthy15 = note_simp_suffix "perm" q_perm lthy14a; - val q_fv = map (lift_thm qtys lthy15) fv_def; - val lthy16 = note_simp_suffix "fv" q_fv lthy15; - val q_bn = map (lift_thm qtys lthy16) raw_bn_eqs; - val lthy17 = note_simp_suffix "bn" q_bn lthy16; - val _ = tracing "Lifting eq-iff"; -(* val _ = map tracing (map PolyML.makestring alpha_eq_iff);*) - val eq_iff_unfolded0 = map (Local_Defs.unfold lthy17 @{thms alphas3}) alpha_eq_iff - val eq_iff_unfolded1 = map (Local_Defs.unfold lthy17 @{thms alphas2}) eq_iff_unfolded0 - val eq_iff_unfolded2 = map (Local_Defs.unfold lthy17 @{thms alphas} ) eq_iff_unfolded1 - val q_eq_iff_pre0 = map (lift_thm qtys lthy17) eq_iff_unfolded2; - val q_eq_iff_pre1 = map (Local_Defs.fold lthy17 @{thms alphas3}) q_eq_iff_pre0 - val q_eq_iff_pre2 = map (Local_Defs.fold lthy17 @{thms alphas2}) q_eq_iff_pre1 - val q_eq_iff = map (Local_Defs.fold lthy17 @{thms alphas}) q_eq_iff_pre2 - val (_, lthy18) = Local_Theory.note ((suffix_bind "eq_iff", []), q_eq_iff) lthy17; - val q_dis = map (lift_thm qtys lthy18) rel_dists; - val lthy19 = note_simp_suffix "distinct" q_dis lthy18; - val q_eqvt = map (lift_thm qtys lthy19) (bv_eqvt @ fv_eqvt); - val (_, lthy20) = Local_Theory.note ((Binding.empty, - [Attrib.internal (fn _ => Nominal_ThmDecls.eqvt_add)]), q_eqvt) lthy19; - val _ = tracing "Finite Support"; - val supports = map (prove_supports lthy20 q_perm) consts; - val fin_supp = HOLogic.conj_elims (prove_fs lthy20 q_induct supports qtys); - val thy3 = Local_Theory.exit_global lthy20; - val lthy21 = Theory_Target.instantiation (qty_full_names, [], @{sort fs}) thy3; - fun tac _ = Class.intro_classes_tac [] THEN (ALLGOALS (resolve_tac fin_supp)) - val lthy22 = Class.prove_instantiation_instance tac lthy21 - val fv_alpha_all = combine_fv_alpha_bns (qfv_ts_nobn, qfv_ts_bn) (alpha_ts_nobn, qalpha_ts_bn) bn_nos; - val (names, supp_eq_t) = supp_eq fv_alpha_all; - val q_supp = HOLogic.conj_elims (Goal.prove lthy22 names [] supp_eq_t (fn _ => supp_eq_tac q_induct q_fv q_perm q_eq_iff lthy22 1)) handle _ => []; - val lthy23 = note_suffix "supp" q_supp lthy22; -in - ((raw_dt_names, raw_bn_funs, raw_bn_eqs, raw_binds), lthy23) -end -*} - - -ML {* -(* parsing the datatypes and declaring *) -(* constructors in the local theory *) -fun prepare_dts dt_strs lthy = -let - val thy = ProofContext.theory_of lthy - - fun mk_type full_tname tvrs = - Type (full_tname, map (fn a => TVar ((a, 0), [])) tvrs) - - fun prep_cnstr lthy full_tname tvs (cname, anno_tys, mx, _) = - let - val tys = map (Syntax.read_typ lthy o snd) anno_tys - val ty = mk_type full_tname tvs - in - ((cname, tys ---> ty, mx), (cname, tys, mx)) - end - - fun prep_dt lthy (tvs, tname, mx, cnstrs) = - let - val full_tname = Sign.full_name thy tname - val (cnstrs', cnstrs'') = - split_list (map (prep_cnstr lthy full_tname tvs) cnstrs) - in - (cnstrs', (tvs, tname, mx, cnstrs'')) - end - - val (cnstrs, dts) = - split_list (map (prep_dt lthy) dt_strs) -in - lthy - |> Local_Theory.theory (Sign.add_consts_i (flat cnstrs)) - |> pair dts -end -*} - -ML {* -(* parsing the binding function specification and *) -(* declaring the functions in the local theory *) -fun prepare_bn_funs bn_fun_strs bn_eq_strs lthy = -let - val ((bn_funs, bn_eqs), _) = - Specification.read_spec bn_fun_strs bn_eq_strs lthy - - fun prep_bn_fun ((bn, T), mx) = (bn, T, mx) - val bn_funs' = map prep_bn_fun bn_funs -in - lthy - |> Local_Theory.theory (Sign.add_consts_i bn_funs') - |> pair (bn_funs', bn_eqs) -end -*} - -ML {* -fun find_all eq xs (k',i) = - maps (fn (k, (v1, v2)) => if eq (k, k') then [(v1, v2, i)] else []) xs -*} - -ML {* -(* associates every SOME with the index in the list; drops NONEs *) -fun mk_env xs = - let - fun mapp (_: int) [] = [] - | mapp i (a :: xs) = - case a of - NONE => mapp (i + 1) xs - | SOME x => (x, i) :: mapp (i + 1) xs - in mapp 0 xs end -*} - -ML {* -fun env_lookup xs x = - case AList.lookup (op =) xs x of - SOME x => x - | NONE => error ("cannot find " ^ x ^ " in the binding specification."); -*} - -ML {* -val recursive = Unsynchronized.ref false -val alpha_type = Unsynchronized.ref AlphaGen -*} - -ML {* -fun prepare_binds dt_strs lthy = -let - fun extract_annos_binds dt_strs = - map (map (fn (_, antys, _, bns) => (map fst antys, bns))) dt_strs - - fun prep_bn env bn_str = - case (Syntax.read_term lthy bn_str) of - Free (x, _) => (NONE, env_lookup env x) - | Const (a, T) $ Free (x, _) => (SOME (Const (a, T), !recursive), env_lookup env x) - | _ => error (bn_str ^ " not allowed as binding specification."); - - fun prep_typ env (i, opt_name) = - case opt_name of - NONE => [] - | SOME x => find_all (op=) env (x,i); - - (* annos - list of annotation for each type (either NONE or SOME fo a type *) - - fun prep_binds (annos, bind_strs) = - let - val env = mk_env annos (* for every label the index *) - val binds = map (fn (x, y) => (x, prep_bn env y)) bind_strs - in - map_index (prep_typ binds) annos - end - - val result = map (map (map (map (fn (a, b, c) => - (a, b, c, if !alpha_type=AlphaLst andalso a = NONE then AlphaGen else !alpha_type))))) - (map (map prep_binds) (extract_annos_binds (get_cnstrs dt_strs))) - - val _ = warning (@{make_string} result) - -in - result -end -*} - -ML {* -fun nominal_datatype2_cmd (dt_strs, bn_fun_strs, bn_eq_strs) lthy = -let - fun prep_typ (tvs, tname, mx, _) = (tname, length tvs, mx) - - val lthy0 = - Local_Theory.theory (Sign.add_types (map prep_typ dt_strs)) lthy - val (dts, lthy1) = - prepare_dts dt_strs lthy0 - val ((bn_funs, bn_eqs), lthy2) = - prepare_bn_funs bn_fun_strs bn_eq_strs lthy1 - val binds = prepare_binds dt_strs lthy2 -in - nominal_datatype2 dts bn_funs bn_eqs binds lthy |> snd -end -*} - - -(* Command Keyword *) - -ML {* -let - val kind = OuterKeyword.thy_decl -in - OuterSyntax.local_theory "nominal_datatype" "test" kind - (main_parser >> nominal_datatype2_cmd) -end -*} - - -end - - - diff -r a6f3e1b08494 -r b6873d123f9b Attic/Prove.thy --- a/Attic/Prove.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,27 +0,0 @@ -theory Prove -imports Plain -begin - -ML {* -val r = Unsynchronized.ref (NONE:(unit -> term) option) -*} - -ML {* -let - fun after_qed thm_name thms lthy = - Local_Theory.note (thm_name, (flat thms)) lthy |> snd - fun setup_proof (name_spec, (txt, _)) lthy = - let - val trm = ML_Context.evaluate lthy true ("r", r) txt - in - Proof.theorem NONE (after_qed name_spec) [[(trm,[])]] lthy - end - - val parser = Parse_Spec.opt_thm_name ":" -- Parse.ML_source -in - Outer_Syntax.local_theory_to_proof "prove" "proving a proposition" - Keyword.thy_goal (parser >> setup_proof) -end -*} - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/AbsRepTest.thy --- a/Attic/Quot/Examples/AbsRepTest.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,240 +0,0 @@ -theory AbsRepTest -imports "../Quotient" "../Quotient_List" "../Quotient_Option" "../Quotient_Sum" "../Quotient_Product" List -begin - - -(* -ML_command "ProofContext.debug := false" -ML_command "ProofContext.verbose := false" -*) - -ML {* open Quotient_Term *} - -ML {* -fun test_funs flag ctxt (rty, qty) = - (absrep_fun_chk flag ctxt (rty, qty) - |> Syntax.string_of_term ctxt - |> writeln; - equiv_relation_chk ctxt (rty, qty) - |> Syntax.string_of_term ctxt - |> writeln) -*} - -definition - erel1 (infixl "\1" 50) -where - "erel1 \ \xs ys. \e. e \ set xs \ e \ set ys" - -quotient_type - 'a fset = "'a list" / erel1 - apply(rule equivpI) - unfolding erel1_def reflp_def symp_def transp_def - by auto - -definition - erel2 (infixl "\2" 50) -where - "erel2 \ \(xs::('a * 'a) list) ys. \e. e \ set xs \ e \ set ys" - -quotient_type - 'a foo = "('a * 'a) list" / erel2 - apply(rule equivpI) - unfolding erel2_def reflp_def symp_def transp_def - by auto - -definition - erel3 (infixl "\3" 50) -where - "erel3 \ \(xs::('a * int) list) ys. \e. e \ set xs \ e \ set ys" - -quotient_type - 'a bar = "('a * int) list" / "erel3" - apply(rule equivpI) - unfolding erel3_def reflp_def symp_def transp_def - by auto - -fun - intrel :: "(nat \ nat) \ (nat \ nat) \ bool" (infixl "\4" 50) -where - "intrel (x, y) (u, v) = (x + v = u + y)" - -quotient_type myint = "nat \ nat" / intrel - by (auto simp add: equivp_def expand_fun_eq) - -ML {* -test_funs AbsF @{context} - (@{typ "nat \ nat"}, - @{typ "myint"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "('a * 'a) list"}, - @{typ "'a foo"}) -*} - -ML {* -test_funs RepF @{context} - (@{typ "(('a * 'a) list * 'b)"}, - @{typ "('a foo * 'b)"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "(('a list) * int) list"}, - @{typ "('a fset) bar"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "('a list)"}, - @{typ "('a fset)"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "('a list) list"}, - @{typ "('a fset) fset"}) -*} - - -ML {* -test_funs AbsF @{context} - (@{typ "((nat * nat) list) list"}, - @{typ "((myint) fset) fset"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "(('a * 'a) list) list"}, - @{typ "(('a * 'a) fset) fset"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "(nat * nat) list"}, - @{typ "myint fset"}) -*} - -ML {* -test_funs AbsF @{context} - (@{typ "('a list) list \ 'a list"}, - @{typ "('a fset) fset \ 'a fset"}) -*} - -lemma OO_sym_inv: - assumes sr: "symp r" - and ss: "symp s" - shows "(r OO s) x y = (s OO r) y x" - using sr ss - unfolding symp_def - apply (metis pred_comp.intros pred_compE ss symp_def) - done - -lemma abs_o_rep: - assumes a: "Quotient r absf repf" - shows "absf o repf = id" - apply(rule ext) - apply(simp add: Quotient_abs_rep[OF a]) - done - -lemma set_in_eq: "(\e. ((e \ A) \ (e \ B))) \ A = B" - apply (rule eq_reflection) - apply auto - done - -lemma map_rel_cong: "b \1 ba \ map f b \1 map f ba" - unfolding erel1_def - apply(simp only: set_map set_in_eq) - done - -lemma quotient_compose_list_gen_pre: - assumes a: "equivp r2" - and b: "Quotient r2 abs2 rep2" - shows "(list_rel r2 OOO op \1) r s = - ((list_rel r2 OOO op \1) r r \ (list_rel r2 OOO op \1) s s \ - abs_fset (map abs2 r) = abs_fset (map abs2 s))" - apply rule - apply rule - apply rule - apply (rule list_rel_refl) - apply (metis equivp_def a) - apply rule - apply (rule equivp_reflp[OF fset_equivp]) - apply (rule list_rel_refl) - apply (metis equivp_def a) - apply(rule) - apply rule - apply (rule list_rel_refl) - apply (metis equivp_def a) - apply rule - apply (rule equivp_reflp[OF fset_equivp]) - apply (rule list_rel_refl) - apply (metis equivp_def a) - apply (subgoal_tac "map abs2 r \1 map abs2 s") - apply (metis Quotient_rel[OF Quotient_fset]) - apply (auto)[1] - apply (subgoal_tac "map abs2 r = map abs2 b") - prefer 2 - apply (metis Quotient_rel[OF list_quotient[OF b]]) - apply (subgoal_tac "map abs2 s = map abs2 ba") - prefer 2 - apply (metis Quotient_rel[OF list_quotient[OF b]]) - apply (simp add: map_rel_cong) - apply rule - apply (rule rep_abs_rsp[of "list_rel r2" "map abs2"]) - apply (rule list_quotient) - apply (rule b) - apply (rule list_rel_refl) - apply (metis equivp_def a) - apply rule - prefer 2 - apply (rule rep_abs_rsp_left[of "list_rel r2" "map abs2"]) - apply (rule list_quotient) - apply (rule b) - apply (rule list_rel_refl) - apply (metis equivp_def a) - apply (erule conjE)+ - apply (subgoal_tac "map abs2 r \1 map abs2 s") - apply (rule map_rel_cong) - apply (assumption) - apply (metis Quotient_def Quotient_fset equivp_reflp fset_equivp a b) - done - -lemma quotient_compose_list_gen: - assumes a: "Quotient r2 abs2 rep2" - and b: "equivp r2" (* reflp is not enough *) - shows "Quotient ((list_rel r2) OOO (op \1)) - (abs_fset \ (map abs2)) ((map rep2) \ rep_fset)" - unfolding Quotient_def comp_def - apply (rule)+ - apply (simp add: abs_o_rep[OF a] id_simps Quotient_abs_rep[OF Quotient_fset]) - apply (rule) - apply (rule) - apply (rule) - apply (rule list_rel_refl) - apply (metis b equivp_def) - apply (rule) - apply (rule equivp_reflp[OF fset_equivp]) - apply (rule list_rel_refl) - apply (metis b equivp_def) - apply rule - apply rule - apply(rule quotient_compose_list_gen_pre[OF b a]) - done - -(* This is the general statement but the types of abs2 and rep2 - are wrong as can be seen in following exanples *) -lemma quotient_compose_general: - assumes a2: "Quotient r1 abs1 rep1" - and "Quotient r2 abs2 rep2" - shows "Quotient ((list_rel r2) OOO r1) - (abs1 \ (map abs2)) ((map rep2) \ rep1)" -sorry - -thm quotient_compose_list_gen[OF Quotient_fset fset_equivp] -thm quotient_compose_general[OF Quotient_fset] -(* Doesn't work: *) -(* thm quotient_compose_general[OF Quotient_fset Quotient_fset] *) - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/FSet3.thy --- a/Attic/Quot/Examples/FSet3.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -theory FSet3 -imports "../../../Nominal/FSet" -begin - -(* TBD *) - -text {* syntax for fset comprehensions (adapted from lists) *} - -nonterminals fsc_qual fsc_quals - -syntax -"_fsetcompr" :: "'a \ fsc_qual \ fsc_quals \ 'a fset" ("{|_ . __") -"_fsc_gen" :: "'a \ 'a fset \ fsc_qual" ("_ <- _") -"_fsc_test" :: "bool \ fsc_qual" ("_") -"_fsc_end" :: "fsc_quals" ("|}") -"_fsc_quals" :: "fsc_qual \ fsc_quals \ fsc_quals" (", __") -"_fsc_abs" :: "'a => 'b fset => 'b fset" - -syntax (xsymbols) -"_fsc_gen" :: "'a \ 'a fset \ fsc_qual" ("_ \ _") -syntax (HTML output) -"_fsc_gen" :: "'a \ 'a fset \ fsc_qual" ("_ \ _") - -parse_translation (advanced) {* -let - val femptyC = Syntax.const @{const_name fempty}; - val finsertC = Syntax.const @{const_name finsert}; - val fmapC = Syntax.const @{const_name fmap}; - val fconcatC = Syntax.const @{const_name fconcat}; - val IfC = Syntax.const @{const_name If}; - fun fsingl x = finsertC $ x $ femptyC; - - fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *) - let - val x = Free (Name.variant (fold Term.add_free_names [p, e] []) "x", dummyT); - val e = if opti then fsingl e else e; - val case1 = Syntax.const "_case1" $ p $ e; - val case2 = Syntax.const "_case1" $ Syntax.const Term.dummy_patternN - $ femptyC; - val cs = Syntax.const "_case2" $ case1 $ case2 - val ft = Datatype_Case.case_tr false Datatype.info_of_constr - ctxt [x, cs] - in lambda x ft end; - - fun abs_tr ctxt (p as Free(s,T)) e opti = - let val thy = ProofContext.theory_of ctxt; - val s' = Sign.intern_const thy s - in if Sign.declared_const thy s' - then (pat_tr ctxt p e opti, false) - else (lambda p e, true) - end - | abs_tr ctxt p e opti = (pat_tr ctxt p e opti, false); - - fun fsc_tr ctxt [e, Const("_fsc_test",_) $ b, qs] = - let - val res = case qs of - Const("_fsc_end",_) => fsingl e - | Const("_fsc_quals",_)$ q $ qs => fsc_tr ctxt [e, q, qs]; - in - IfC $ b $ res $ femptyC - end - - | fsc_tr ctxt [e, Const("_fsc_gen",_) $ p $ es, Const("_fsc_end",_)] = - (case abs_tr ctxt p e true of - (f,true) => fmapC $ f $ es - | (f, false) => fconcatC $ (fmapC $ f $ es)) - - | fsc_tr ctxt [e, Const("_fsc_gen",_) $ p $ es, Const("_fsc_quals",_) $ q $ qs] = - let - val e' = fsc_tr ctxt [e, q, qs]; - in - fconcatC $ (fmapC $ (fst (abs_tr ctxt p e' false)) $ es) - end - -in [("_fsetcompr", fsc_tr)] end -*} - - -(* NEEDS FIXING *) -(* examles *) -(* -term "{|(x,y,z). b|}" -term "{|x. x \ xs|}" -term "{|(x,y,z). x\xs|}" -term "{|e x y. x\xs, y\ys|}" -term "{|(x,y,z). xb|}" -term "{|(x,y,z). x\xs, x>b|}" -term "{|(x,y,z). xxs|}" -term "{|(x,y). Cons True x \ xs|}" -term "{|(x,y,z). Cons x [] \ xs|}" -term "{|(x,y,z). xb, x=d|}" -term "{|(x,y,z). xb, y\ys|}" -term "{|(x,y,z). xxs,y>b|}" -term "{|(x,y,z). xxs, y\ys|}" -term "{|(x,y,z). x\xs, x>b, yxs, x>b, y\ys|}" -term "{|(x,y,z). x\xs, y\ys,y>x|}" -term "{|(x,y,z). x\xs, y\ys,z\zs|}" -*) - -(* BELOW CONSTRUCTION SITE *) - - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/FSet_BallBex.thy --- a/Attic/Quot/Examples/FSet_BallBex.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,36 +0,0 @@ -theory FSet_ballbex -imports "../../../Nominal/FSet" -begin - -notation - list_eq (infix "\" 50) - -lemma test: - "\xs \ (\xs. memb x xs). memb x (y # xs)" - apply (simp add: memb_def) - apply (metis mem_def) - done - -thm test[quot_lifted] - -lemma "\xs \ (\xs. x |\| xs). x |\| finsert y xs" - unfolding Ball_def - by (lifting test[unfolded Ball_def]) - -ML {* Quotient_Tacs.lifted @{context} [@{typ "'a fset"}] @{thms Ball_def Bex_def} @{thm test}*} - -lemma test2: - "\xs \ (\xs. xs \ []). xs \ []" - apply (rule_tac x="[]" in bexI) - apply (auto simp add: mem_def) - done - -thm test2[quot_lifted] - -lemma "\xs \ (\xs. xs = {||}). xs = {||}" - unfolding Bex_def - by (lifting test2[unfolded Bex_def]) - -ML {* Quotient_Tacs.lifted @{context} [@{typ "'a fset"}] @{thms Bex_def} @{thm test2}*} - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/IntEx2.thy --- a/Attic/Quot/Examples/IntEx2.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,111 +0,0 @@ -theory IntEx2 -imports "Quotient_Int" -begin - -subsection {* Embedding of the Integers into any @{text ring_1}: @{text of_int}*} - -(* -context ring_1 -begin - - -definition - of_int :: "int \ 'a" -where - "of_int -*) - - -subsection {* Binary representation *} - -text {* - This formalization defines binary arithmetic in terms of the integers - rather than using a datatype. This avoids multiple representations (leading - zeroes, etc.) See @{text "ZF/Tools/twos-compl.ML"}, function @{text - int_of_binary}, for the numerical interpretation. - - The representation expects that @{text "(m mod 2)"} is 0 or 1, - even if m is negative; - For instance, @{text "-5 div 2 = -3"} and @{text "-5 mod 2 = 1"}; thus - @{text "-5 = (-3)*2 + 1"}. - - This two's complement binary representation derives from the paper - "An Efficient Representation of Arithmetic for Term Rewriting" by - Dave Cohen and Phil Watson, Rewriting Techniques and Applications, - Springer LNCS 488 (240-251), 1991. -*} - -subsubsection {* The constructors @{term Bit0}, @{term Bit1}, @{term Pls} and @{term Min} *} - -definition - Pls :: int where - [code del]: "Pls = 0" - -definition - Min :: int where - [code del]: "Min = - 1" - -definition - Bit0 :: "int \ int" where - [code del]: "Bit0 k = k + k" - -definition - Bit1 :: "int \ int" where - [code del]: "Bit1 k = 1 + k + k" - -class number = -- {* for numeric types: nat, int, real, \dots *} - fixes number_of :: "int \ 'a" - -(*use "~~/src/HOL/Tools/numeral.ML" - -syntax - "_Numeral" :: "num_const \ 'a" ("_") - -use "~~/src/HOL/Tools/numeral_syntax.ML" - -setup NumeralSyntax.setup - -abbreviation - "Numeral0 \ number_of Pls" - -abbreviation - "Numeral1 \ number_of (Bit1 Pls)" - -lemma Let_number_of [simp]: "Let (number_of v) f = f (number_of v)" - -- {* Unfold all @{text let}s involving constants *} - unfolding Let_def .. - -definition - succ :: "int \ int" where - [code del]: "succ k = k + 1" - -definition - pred :: "int \ int" where - [code del]: "pred k = k - 1" - -lemmas - max_number_of [simp] = max_def - [of "number_of u" "number_of v", standard, simp] -and - min_number_of [simp] = min_def - [of "number_of u" "number_of v", standard, simp] - -- {* unfolding @{text minx} and @{text max} on numerals *} - -lemmas numeral_simps = - succ_def pred_def Pls_def Min_def Bit0_def Bit1_def - -text {* Removal of leading zeroes *} - -lemma Bit0_Pls [simp, code_post]: - "Bit0 Pls = Pls" - unfolding numeral_simps by simp - -lemma Bit1_Min [simp, code_post]: - "Bit1 Min = Min" - unfolding numeral_simps by simp - -lemmas normalize_bin_simps = - Bit0_Pls Bit1_Min -*) - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/LFex.thy --- a/Attic/Quot/Examples/LFex.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,331 +0,0 @@ -theory LFex -imports Nominal "../Quotient_List" -begin - -atom_decl name ident - -nominal_datatype kind = - Type - | KPi "ty" "name" "kind" -and ty = - TConst "ident" - | TApp "ty" "trm" - | TPi "ty" "name" "ty" -and trm = - Const "ident" - | Var "name" - | App "trm" "trm" - | Lam "ty" "name" "trm" - -function - fv_kind :: "kind \ name set" -and fv_ty :: "ty \ name set" -and fv_trm :: "trm \ name set" -where - "fv_kind (Type) = {}" -| "fv_kind (KPi A x K) = (fv_ty A) \ ((fv_kind K) - {x})" -| "fv_ty (TConst i) = {}" -| "fv_ty (TApp A M) = (fv_ty A) \ (fv_trm M)" -| "fv_ty (TPi A x B) = (fv_ty A) \ ((fv_ty B) - {x})" -| "fv_trm (Const i) = {}" -| "fv_trm (Var x) = {x}" -| "fv_trm (App M N) = (fv_trm M) \ (fv_trm N)" -| "fv_trm (Lam A x M) = (fv_ty A) \ ((fv_trm M) - {x})" -sorry - -termination fv_kind sorry - -inductive - akind :: "kind \ kind \ bool" ("_ \ki _" [100, 100] 100) -and aty :: "ty \ ty \ bool" ("_ \ty _" [100, 100] 100) -and atrm :: "trm \ trm \ bool" ("_ \tr _" [100, 100] 100) -where - a1: "(Type) \ki (Type)" -| a21: "\A \ty A'; K \ki K'\ \ (KPi A x K) \ki (KPi A' x K')" -| a22: "\A \ty A'; K \ki ([(x,x')]\K'); x \ (fv_ty A'); x \ ((fv_kind K') - {x'})\ - \ (KPi A x K) \ki (KPi A' x' K')" -| a3: "i = j \ (TConst i) \ty (TConst j)" -| a4: "\A \ty A'; M \tr M'\ \ (TApp A M) \ty (TApp A' M')" -| a51: "\A \ty A'; B \ty B'\ \ (TPi A x B) \ty (TPi A' x B')" -| a52: "\A \ty A'; B \ty ([(x,x')]\B'); x \ (fv_ty B'); x \ ((fv_ty B') - {x'})\ - \ (TPi A x B) \ty (TPi A' x' B')" -| a6: "i = j \ (Const i) \trm (Const j)" -| a7: "x = y \ (Var x) \trm (Var y)" -| a8: "\M \trm M'; N \tr N'\ \ (App M N) \tr (App M' N')" -| a91: "\A \ty A'; M \tr M'\ \ (Lam A x M) \tr (Lam A' x M')" -| a92: "\A \ty A'; M \tr ([(x,x')]\M'); x \ (fv_ty B'); x \ ((fv_trm M') - {x'})\ - \ (Lam A x M) \tr (Lam A' x' M')" - -lemma al_refl: - fixes K::"kind" - and A::"ty" - and M::"trm" - shows "K \ki K" - and "A \ty A" - and "M \tr M" - apply(induct K and A and M rule: kind_ty_trm.inducts) - apply(auto intro: akind_aty_atrm.intros) - done - -lemma alpha_equivps: - shows "equivp akind" - and "equivp aty" - and "equivp atrm" -sorry - -quotient_type KIND = kind / akind - by (rule alpha_equivps) - -quotient_type - TY = ty / aty and - TRM = trm / atrm - by (auto intro: alpha_equivps) - -quotient_definition - "TYP :: KIND" -is - "Type" - -quotient_definition - "KPI :: TY \ name \ KIND \ KIND" -is - "KPi" - -quotient_definition - "TCONST :: ident \ TY" -is - "TConst" - -quotient_definition - "TAPP :: TY \ TRM \ TY" -is - "TApp" - -quotient_definition - "TPI :: TY \ name \ TY \ TY" -is - "TPi" - -(* FIXME: does not work with CONST *) -quotient_definition - "CONS :: ident \ TRM" -is - "Const" - -quotient_definition - "VAR :: name \ TRM" -is - "Var" - -quotient_definition - "APP :: TRM \ TRM \ TRM" -is - "App" - -quotient_definition - "LAM :: TY \ name \ TRM \ TRM" -is - "Lam" - -thm TYP_def -thm KPI_def -thm TCONST_def -thm TAPP_def -thm TPI_def -thm VAR_def -thm CONS_def -thm APP_def -thm LAM_def - -(* FIXME: print out a warning if the type contains a liftet type, like kind \ name set *) -quotient_definition - "FV_kind :: KIND \ name set" -is - "fv_kind" - -quotient_definition - "FV_ty :: TY \ name set" -is - "fv_ty" - -quotient_definition - "FV_trm :: TRM \ name set" -is - "fv_trm" - -thm FV_kind_def -thm FV_ty_def -thm FV_trm_def - -(* FIXME: does not work yet *) -overloading - perm_kind \ "perm :: 'x prm \ KIND \ KIND" (unchecked) - perm_ty \ "perm :: 'x prm \ TY \ TY" (unchecked) - perm_trm \ "perm :: 'x prm \ TRM \ TRM" (unchecked) -begin - -quotient_definition - "perm_kind :: 'x prm \ KIND \ KIND" -is - "(perm::'x prm \ kind \ kind)" - -quotient_definition - "perm_ty :: 'x prm \ TY \ TY" -is - "(perm::'x prm \ ty \ ty)" - -quotient_definition - "perm_trm :: 'x prm \ TRM \ TRM" -is - "(perm::'x prm \ trm \ trm)" - -end - -(* TODO/FIXME: Think whether these RSP theorems are true. *) -lemma kpi_rsp[quot_respect]: - "(aty ===> op = ===> akind ===> akind) KPi KPi" sorry -lemma tconst_rsp[quot_respect]: - "(op = ===> aty) TConst TConst" sorry -lemma tapp_rsp[quot_respect]: - "(aty ===> atrm ===> aty) TApp TApp" sorry -lemma tpi_rsp[quot_respect]: - "(aty ===> op = ===> aty ===> aty) TPi TPi" sorry -lemma var_rsp[quot_respect]: - "(op = ===> atrm) Var Var" sorry -lemma app_rsp[quot_respect]: - "(atrm ===> atrm ===> atrm) App App" sorry -lemma const_rsp[quot_respect]: - "(op = ===> atrm) Const Const" sorry -lemma lam_rsp[quot_respect]: - "(aty ===> op = ===> atrm ===> atrm) Lam Lam" sorry - -lemma perm_kind_rsp[quot_respect]: - "(op = ===> akind ===> akind) op \ op \" sorry -lemma perm_ty_rsp[quot_respect]: - "(op = ===> aty ===> aty) op \ op \" sorry -lemma perm_trm_rsp[quot_respect]: - "(op = ===> atrm ===> atrm) op \ op \" sorry - -lemma fv_ty_rsp[quot_respect]: - "(aty ===> op =) fv_ty fv_ty" sorry -lemma fv_kind_rsp[quot_respect]: - "(akind ===> op =) fv_kind fv_kind" sorry -lemma fv_trm_rsp[quot_respect]: - "(atrm ===> op =) fv_trm fv_trm" sorry - - -thm akind_aty_atrm.induct -thm kind_ty_trm.induct - - -lemma - assumes a0: - "P1 TYP TYP" - and a1: - "\A A' K K' x. \(A::TY) = A'; P2 A A'; (K::KIND) = K'; P1 K K'\ - \ P1 (KPI A x K) (KPI A' x K')" - and a2: - "\A A' K K' x x'. \(A ::TY) = A'; P2 A A'; (K :: KIND) = ([(x, x')] \ K'); P1 K ([(x, x')] \ K'); - x \ FV_ty A'; x \ FV_kind K' - {x'}\ \ P1 (KPI A x K) (KPI A' x' K')" - and a3: - "\i j. i = j \ P2 (TCONST i) (TCONST j)" - and a4: - "\A A' M M'. \(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\ \ P2 (TAPP A M) (TAPP A' M')" - and a5: - "\A A' B B' x. \(A ::TY) = A'; P2 A A'; (B ::TY) = B'; P2 B B'\ \ P2 (TPI A x B) (TPI A' x B')" - and a6: - "\A A' B x x' B'. \(A ::TY) = A'; P2 A A'; (B ::TY) = ([(x, x')] \ B'); P2 B ([(x, x')] \ B'); - x \ FV_ty B'; x \ FV_ty B' - {x'}\ \ P2 (TPI A x B) (TPI A' x' B')" - and a7: - "\i j m. i = j \ P3 (CONS i) (m (CONS j))" - and a8: - "\x y m. x = y \ P3 (VAR x) (m (VAR y))" - and a9: - "\M m M' N N'. \(M :: TRM) = m M'; P3 M (m M'); (N :: TRM) = N'; P3 N N'\ \ P3 (APP M N) (APP M' N')" - and a10: - "\A A' M M' x. \(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\ \ P3 (LAM A x M) (LAM A' x M')" - and a11: - "\A A' M x x' M' B'. \(A ::TY) = A'; P2 A A'; (M :: TRM) = ([(x, x')] \ M'); P3 M ([(x, x')] \ M'); - x \ FV_ty B'; x \ FV_trm M' - {x'}\ \ P3 (LAM A x M) (LAM A' x' M')" - shows "((x1 :: KIND) = x2 \ P1 x1 x2) \ - ((x3 ::TY) = x4 \ P2 x3 x4) \ - ((x5 :: TRM) = x6 \ P3 x5 x6)" -using a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 -apply(lifting_setup akind_aty_atrm.induct) -defer -apply injection -apply cleaning -apply (simp only: ball_reg_eqv[OF KIND_equivp] ball_reg_eqv[OF TRM_equivp] ball_reg_eqv[OF TY_equivp]) -apply (rule ball_reg_right)+ -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -defer -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -defer -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -defer -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply (tactic {* resolve_tac (Inductive.get_monos @{context}) 1 *}) -apply simp -apply simp -apply regularize+ -done - -(* Does not work: -lemma - assumes a0: "P1 TYP" - and a1: "\ty name kind. \P2 ty; P1 kind\ \ P1 (KPI ty name kind)" - and a2: "\id. P2 (TCONST id)" - and a3: "\ty trm. \P2 ty; P3 trm\ \ P2 (TAPP ty trm)" - and a4: "\ty1 name ty2. \P2 ty1; P2 ty2\ \ P2 (TPI ty1 name ty2)" - and a5: "\id. P3 (CONS id)" - and a6: "\name. P3 (VAR name)" - and a7: "\trm1 trm2. \P3 trm1; P3 trm2\ \ P3 (APP trm1 trm2)" - and a8: "\ty name trm. \P2 ty; P3 trm\ \ P3 (LAM ty name trm)" - shows "P1 mkind \ P2 mty \ P3 mtrm" -using a0 a1 a2 a3 a4 a5 a6 a7 a8 -*) - - -lemma "\P TYP; - \ty name kind. \Q ty; P kind\ \ P (KPI ty name kind); - \id. Q (TCONST id); - \ty trm. \Q ty; R trm\ \ Q (TAPP ty trm); - \ty1 name ty2. \Q ty1; Q ty2\ \ Q (TPI ty1 name ty2); - \id. R (CONS id); \name. R (VAR name); - \trm1 trm2. \R trm1; R trm2\ \ R (APP trm1 trm2); - \ty name trm. \Q ty; R trm\ \ R (LAM ty name trm)\ - \ P mkind \ Q mty \ R mtrm" -apply(lifting kind_ty_trm.induct) -done - -end - - - - diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/LamEx.thy --- a/Attic/Quot/Examples/LamEx.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,619 +0,0 @@ -theory LamEx -imports Nominal "../Quotient" "../Quotient_List" -begin - -atom_decl name - -datatype rlam = - rVar "name" -| rApp "rlam" "rlam" -| rLam "name" "rlam" - -fun - rfv :: "rlam \ name set" -where - rfv_var: "rfv (rVar a) = {a}" -| rfv_app: "rfv (rApp t1 t2) = (rfv t1) \ (rfv t2)" -| rfv_lam: "rfv (rLam a t) = (rfv t) - {a}" - -overloading - perm_rlam \ "perm :: 'x prm \ rlam \ rlam" (unchecked) -begin - -fun - perm_rlam -where - "perm_rlam pi (rVar a) = rVar (pi \ a)" -| "perm_rlam pi (rApp t1 t2) = rApp (perm_rlam pi t1) (perm_rlam pi t2)" -| "perm_rlam pi (rLam a t) = rLam (pi \ a) (perm_rlam pi t)" - -end - -declare perm_rlam.simps[eqvt] - -instance rlam::pt_name - apply(default) - apply(induct_tac [!] x rule: rlam.induct) - apply(simp_all add: pt_name2 pt_name3) - done - -instance rlam::fs_name - apply(default) - apply(induct_tac [!] x rule: rlam.induct) - apply(simp add: supp_def) - apply(fold supp_def) - apply(simp add: supp_atm) - apply(simp add: supp_def Collect_imp_eq Collect_neg_eq) - apply(simp add: supp_def) - apply(simp add: supp_def Collect_imp_eq Collect_neg_eq[symmetric]) - apply(fold supp_def) - apply(simp add: supp_atm) - done - -declare set_diff_eqvt[eqvt] - -lemma rfv_eqvt[eqvt]: - fixes pi::"name prm" - shows "(pi\rfv t) = rfv (pi\t)" - apply(induct t) - apply(simp_all) - apply(simp add: perm_set_eq) - apply(simp add: union_eqvt) - apply(simp add: set_diff_eqvt) - apply(simp add: perm_set_eq) - done - -inductive - alpha :: "rlam \ rlam \ bool" ("_ \ _" [100, 100] 100) -where - a1: "a = b \ (rVar a) \ (rVar b)" -| a2: "\t1 \ t2; s1 \ s2\ \ rApp t1 s1 \ rApp t2 s2" -| a3: "\pi::name prm. (rfv t - {a} = rfv s - {b} \ (rfv t - {a})\* pi \ (pi \ t) \ s \ (pi \ a) = b) - \ rLam a t \ rLam b s" - - -(* should be automatic with new version of eqvt-machinery *) -lemma alpha_eqvt: - fixes pi::"name prm" - shows "t \ s \ (pi \ t) \ (pi \ s)" - apply(induct rule: alpha.induct) - apply(simp add: a1) - apply(simp add: a2) - apply(simp) - apply(rule a3) - apply(erule conjE) - apply(erule exE) - apply(erule conjE) - apply(rule_tac x="pi \ pia" in exI) - apply(rule conjI) - apply(rule_tac pi1="rev pi" in perm_bij[THEN iffD1]) - apply(perm_simp add: eqvts) - apply(rule conjI) - apply(rule_tac pi1="rev pi" in pt_fresh_star_bij(1)[OF pt_name_inst at_name_inst, THEN iffD1]) - apply(perm_simp add: eqvts) - apply(rule conjI) - apply(subst perm_compose[symmetric]) - apply(simp) - apply(subst perm_compose[symmetric]) - apply(simp) - done - -lemma alpha_refl: - shows "t \ t" - apply(induct t rule: rlam.induct) - apply(simp add: a1) - apply(simp add: a2) - apply(rule a3) - apply(rule_tac x="[]" in exI) - apply(simp_all add: fresh_star_def fresh_list_nil) - done - -lemma alpha_sym: - shows "t \ s \ s \ t" - apply(induct rule: alpha.induct) - apply(simp add: a1) - apply(simp add: a2) - apply(rule a3) - apply(erule exE) - apply(rule_tac x="rev pi" in exI) - apply(simp) - apply(simp add: fresh_star_def fresh_list_rev) - apply(rule conjI) - apply(erule conjE)+ - apply(rotate_tac 3) - apply(drule_tac pi="rev pi" in alpha_eqvt) - apply(perm_simp) - apply(rule pt_bij2[OF pt_name_inst at_name_inst]) - apply(simp) - done - -lemma alpha_trans: - shows "t1 \ t2 \ t2 \ t3 \ t1 \ t3" - apply(induct arbitrary: t3 rule: alpha.induct) - apply(erule alpha.cases) - apply(simp_all) - apply(simp add: a1) - apply(rotate_tac 4) - apply(erule alpha.cases) - apply(simp_all) - apply(simp add: a2) - apply(rotate_tac 1) - apply(erule alpha.cases) - apply(simp_all) - apply(erule conjE)+ - apply(erule exE)+ - apply(erule conjE)+ - apply(rule a3) - apply(rule_tac x="pia @ pi" in exI) - apply(simp add: fresh_star_def fresh_list_append) - apply(simp add: pt_name2) - apply(drule_tac x="rev pia \ sa" in spec) - apply(drule mp) - apply(rotate_tac 8) - apply(drule_tac pi="rev pia" in alpha_eqvt) - apply(perm_simp) - apply(rotate_tac 11) - apply(drule_tac pi="pia" in alpha_eqvt) - apply(perm_simp) - done - -lemma alpha_equivp: - shows "equivp alpha" - apply(rule equivpI) - unfolding reflp_def symp_def transp_def - apply(auto intro: alpha_refl alpha_sym alpha_trans) - done - -lemma alpha_rfv: - shows "t \ s \ rfv t = rfv s" - apply(induct rule: alpha.induct) - apply(simp) - apply(simp) - apply(simp) - done - -quotient_type lam = rlam / alpha - by (rule alpha_equivp) - - -quotient_definition - "Var :: name \ lam" -is - "rVar" - -quotient_definition - "App :: lam \ lam \ lam" -is - "rApp" - -quotient_definition - "Lam :: name \ lam \ lam" -is - "rLam" - -quotient_definition - "fv :: lam \ name set" -is - "rfv" - -(* definition of overloaded permutation function *) -(* for the lifted type lam *) -overloading - perm_lam \ "perm :: 'x prm \ lam \ lam" (unchecked) -begin - -quotient_definition - "perm_lam :: 'x prm \ lam \ lam" -is - "perm::'x prm \ rlam \ rlam" - -end - -lemma perm_rsp[quot_respect]: - "(op = ===> alpha ===> alpha) op \ (op \ :: (name \ name) list \ rlam \ rlam)" - apply auto - apply(erule alpha_eqvt) - done - -lemma rVar_rsp[quot_respect]: - "(op = ===> alpha) rVar rVar" - by (auto intro: a1) - -lemma rApp_rsp[quot_respect]: "(alpha ===> alpha ===> alpha) rApp rApp" - by (auto intro: a2) - -lemma rLam_rsp[quot_respect]: "(op = ===> alpha ===> alpha) rLam rLam" - apply(auto) - apply(rule a3) - apply(rule_tac x="[]" in exI) - unfolding fresh_star_def - apply(simp add: fresh_list_nil) - apply(simp add: alpha_rfv) - done - -lemma rfv_rsp[quot_respect]: - "(alpha ===> op =) rfv rfv" - apply(simp add: alpha_rfv) - done - -section {* lifted theorems *} - -lemma lam_induct: - "\\name. P (Var name); - \lam1 lam2. \P lam1; P lam2\ \ P (App lam1 lam2); - \name lam. P lam \ P (Lam name lam)\ - \ P lam" - by (lifting rlam.induct) - -lemma perm_lam [simp]: - fixes pi::"name prm" - shows "pi \ Var a = Var (pi \ a)" - and "pi \ App t1 t2 = App (pi \ t1) (pi \ t2)" - and "pi \ Lam a t = Lam (pi \ a) (pi \ t)" - by (lifting perm_rlam.simps[where 'a="name"]) - -instance lam::pt_name - apply(default) - apply(induct_tac [!] x rule: lam_induct) - apply(simp_all add: pt_name2 pt_name3) - done - -lemma fv_lam [simp]: - shows "fv (Var a) = {a}" - and "fv (App t1 t2) = fv t1 \ fv t2" - and "fv (Lam a t) = fv t - {a}" - by(lifting rfv_var rfv_app rfv_lam) - -lemma a1: - "a = b \ Var a = Var b" - by (lifting a1) - -lemma a2: - "\x = xa; xb = xc\ \ App x xb = App xa xc" - by (lifting a2) - -lemma a3: - "\\pi::name prm. (fv t - {a} = fv s - {b} \ (fv t - {a})\* pi \ (pi \ t) = s \ (pi \ a) = b)\ - \ Lam a t = Lam b s" - by (lifting a3) - -lemma alpha_cases: - "\a1 = a2; \a b. \a1 = Var a; a2 = Var b; a = b\ \ P; - \x xa xb xc. \a1 = App x xb; a2 = App xa xc; x = xa; xb = xc\ \ P; - \t a s b. \a1 = Lam a t; a2 = Lam b s; - \pi::name prm. fv t - {a} = fv s - {b} \ (fv t - {a}) \* pi \ (pi \ t) = s \ pi \ a = b\ \ P\ - \ P" - by (lifting alpha.cases) - -lemma alpha_induct: - "\qx = qxa; \a b. a = b \ qxb (Var a) (Var b); - \x xa xb xc. \x = xa; qxb x xa; xb = xc; qxb xb xc\ \ qxb (App x xb) (App xa xc); - \t a s b. - \\pi::name prm. fv t - {a} = fv s - {b} \ - (fv t - {a}) \* pi \ ((pi \ t) = s \ qxb (pi \ t) s) \ pi \ a = b\ \ qxb (Lam a t) (Lam b s)\ - \ qxb qx qxa" - by (lifting alpha.induct) - -lemma lam_inject [simp]: - shows "(Var a = Var b) = (a = b)" - and "(App t1 t2 = App s1 s2) = (t1 = s1 \ t2 = s2)" - apply(lifting rlam.inject(1) rlam.inject(2)) - apply(auto) - apply(drule alpha.cases) - apply(simp_all) - apply(simp add: alpha.a1) - apply(drule alpha.cases) - apply(simp_all) - apply(drule alpha.cases) - apply(simp_all) - apply(rule alpha.a2) - apply(simp_all) - done - -lemma rlam_distinct: - shows "\(rVar nam \ rApp rlam1' rlam2')" - and "\(rApp rlam1' rlam2' \ rVar nam)" - and "\(rVar nam \ rLam nam' rlam')" - and "\(rLam nam' rlam' \ rVar nam)" - and "\(rApp rlam1 rlam2 \ rLam nam' rlam')" - and "\(rLam nam' rlam' \ rApp rlam1 rlam2)" - apply auto - apply(erule alpha.cases) - apply simp_all - apply(erule alpha.cases) - apply simp_all - apply(erule alpha.cases) - apply simp_all - apply(erule alpha.cases) - apply simp_all - apply(erule alpha.cases) - apply simp_all - apply(erule alpha.cases) - apply simp_all - done - -lemma lam_distinct[simp]: - shows "Var nam \ App lam1' lam2'" - and "App lam1' lam2' \ Var nam" - and "Var nam \ Lam nam' lam'" - and "Lam nam' lam' \ Var nam" - and "App lam1 lam2 \ Lam nam' lam'" - and "Lam nam' lam' \ App lam1 lam2" - by(lifting rlam_distinct(1) rlam_distinct(2) rlam_distinct(3) rlam_distinct(4) rlam_distinct(5) rlam_distinct(6)) - -lemma var_supp1: - shows "(supp (Var a)) = ((supp a)::name set)" - by (simp add: supp_def) - -lemma var_supp: - shows "(supp (Var a)) = {a::name}" - using var_supp1 by (simp add: supp_atm) - -lemma app_supp: - shows "supp (App t1 t2) = (supp t1) \ ((supp t2)::name set)" - apply(simp only: perm_lam supp_def lam_inject) - apply(simp add: Collect_imp_eq Collect_neg_eq) - done - -lemma lam_supp: - shows "supp (Lam x t) = ((supp ([x].t))::name set)" - apply(simp add: supp_def) - apply(simp add: abs_perm) - sorry - -instance lam::fs_name - apply(default) - apply(induct_tac x rule: lam_induct) - apply(simp add: var_supp) - apply(simp add: app_supp) - apply(simp add: lam_supp abs_supp) - done - -lemma fresh_lam: - "(a \ Lam b t) \ (a = b) \ (a \ b \ a \ t)" - apply(simp add: fresh_def) - apply(simp add: lam_supp abs_supp) - apply(auto) - done - -lemma lam_induct_strong: - fixes a::"'a::fs_name" - assumes a1: "\name b. P b (Var name)" - and a2: "\lam1 lam2 b. \\c. P c lam1; \c. P c lam2\ \ P b (App lam1 lam2)" - and a3: "\name lam b. \\c. P c lam; name \ b\ \ P b (Lam name lam)" - shows "P a lam" -proof - - have "\(pi::name prm) a. P a (pi \ lam)" - proof (induct lam rule: lam_induct) - case (1 name pi) - show "P a (pi \ Var name)" - apply (simp) - apply (rule a1) - done - next - case (2 lam1 lam2 pi) - have b1: "\(pi::name prm) a. P a (pi \ lam1)" by fact - have b2: "\(pi::name prm) a. P a (pi \ lam2)" by fact - show "P a (pi \ App lam1 lam2)" - apply (simp) - apply (rule a2) - apply (rule b1) - apply (rule b2) - done - next - case (3 name lam pi a) - have b: "\(pi::name prm) a. P a (pi \ lam)" by fact - obtain c::name where fr: "c\(a, pi\name, pi\lam)" - apply(rule exists_fresh[of "(a, pi\name, pi\lam)"]) - apply(simp_all add: fs_name1) - done - from b fr have p: "P a (Lam c (([(c, pi\name)]@pi)\lam))" - apply - - apply(rule a3) - apply(blast) - apply(simp) - done - have eq: "[(c, pi\name)] \ Lam (pi \ name) (pi \ lam) = Lam (pi \ name) (pi \ lam)" - apply(rule perm_fresh_fresh) - using fr - apply(simp add: fresh_lam) - apply(simp add: fresh_lam) - done - show "P a (pi \ Lam name lam)" - apply (simp) - apply(subst eq[symmetric]) - using p - apply(simp only: perm_lam pt_name2 swap_simps) - done - qed - then have "P a (([]::name prm) \ lam)" by blast - then show "P a lam" by simp -qed - - -lemma var_fresh: - fixes a::"name" - shows "(a \ (Var b)) = (a \ b)" - apply(simp add: fresh_def) - apply(simp add: var_supp1) - done - -(* lemma hom_reg: *) - -lemma rlam_rec_eqvt: - fixes pi::"name prm" - and f1::"name \ ('a::pt_name)" - shows "(pi\rlam_rec f1 f2 f3 t) = rlam_rec (pi\f1) (pi\f2) (pi\f3) (pi\t)" -apply(induct t) -apply(simp_all) -apply(simp add: perm_fun_def) -apply(perm_simp) -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -back -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -apply(simp) -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -back -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -apply(subst pt_fun_app_eq[OF pt_name_inst at_name_inst]) -apply(simp) -done - - -lemma rlam_rec_respects: - assumes f1: "f_var \ Respects (op= ===> op=)" - and f2: "f_app \ Respects (alpha ===> alpha ===> op= ===> op= ===> op=)" - and f3: "f_lam \ Respects (op= ===> alpha ===> op= ===> op=)" - shows "rlam_rec f_var f_app f_lam \ Respects (alpha ===> op =)" -apply(simp add: mem_def) -apply(simp add: Respects_def) -apply(rule allI) -apply(rule allI) -apply(rule impI) -apply(erule alpha.induct) -apply(simp) -apply(simp) -using f2 -apply(simp add: mem_def) -apply(simp add: Respects_def) -using f3[simplified mem_def Respects_def] -apply(simp) -apply(case_tac "a=b") -apply(clarify) -apply(simp) -(* probably true *) -sorry - -function - term1_hom :: "(name \ 'a) \ - (rlam \ rlam \ 'a \ 'a \ 'a) \ - ((name \ rlam) \ (name \ 'a) \ 'a) \ rlam \ 'a" -where - "term1_hom var app abs' (rVar x) = (var x)" -| "term1_hom var app abs' (rApp t u) = - app t u (term1_hom var app abs' t) (term1_hom var app abs' u)" -| "term1_hom var app abs' (rLam x u) = - abs' (\y. [(x, y)] \ u) (\y. term1_hom var app abs' ([(x, y)] \ u))" -apply(pat_completeness) -apply(auto) -done - -lemma pi_size: - fixes pi::"name prm" - and t::"rlam" - shows "size (pi \ t) = size t" -apply(induct t) -apply(auto) -done - -termination term1_hom - apply(relation "measure (\(f1, f2, f3, t). size t)") -apply(auto simp add: pi_size) -done - -lemma lam_exhaust: - "\\name. y = Var name \ P; \rlam1 rlam2. y = App rlam1 rlam2 \ P; \name rlam. y = Lam name rlam \ P\ - \ P" -apply(lifting rlam.exhaust) -done - -(* THIS IS NOT TRUE, but it lets prove the existence of the hom function *) -lemma lam_inject': - "(Lam a x = Lam b y) = ((\c. [(a, c)] \ x) = (\c. [(b, c)] \ y))" -sorry - -function - hom :: "(name \ 'a) \ - (lam \ lam \ 'a \ 'a \ 'a) \ - ((name \ lam) \ (name \ 'a) \ 'a) \ lam \ 'a" -where - "hom f_var f_app f_lam (Var x) = f_var x" -| "hom f_var f_app f_lam (App l r) = f_app l r (hom f_var f_app f_lam l) (hom f_var f_app f_lam r)" -| "hom f_var f_app f_lam (Lam a x) = f_lam (\b. ([(a,b)] \ x)) (\b. hom f_var f_app f_lam ([(a,b)] \ x))" -defer -apply(simp_all add: lam_inject') (* inject, distinct *) -apply(tactic {* Cong_Tac.cong_tac @{thm cong} 1 *}) -apply(rule refl) -apply(rule ext) -apply(tactic {* Cong_Tac.cong_tac @{thm cong} 1 *}) -apply simp_all -apply(erule conjE)+ -apply(rule_tac x="b" in cong) -apply simp_all -apply auto -apply(rule_tac y="b" in lam_exhaust) -apply simp_all -apply auto -apply meson -apply(simp_all add: lam_inject') -apply metis -done - -termination hom - apply - -(* -ML_prf {* Size.size_thms @{theory} "LamEx.lam" *} -*) -sorry - -thm hom.simps - -lemma term1_hom_rsp: - "\(alpha ===> alpha ===> op =) f_app f_app; ((op = ===> alpha) ===> op =) f_lam f_lam\ - \ (alpha ===> op =) (term1_hom f_var f_app f_lam) (term1_hom f_var f_app f_lam)" -apply(simp) -apply(rule allI)+ -apply(rule impI) -apply(erule alpha.induct) -apply(auto)[1] -apply(auto)[1] -apply(simp) -apply(erule conjE)+ -apply(erule exE)+ -apply(erule conjE)+ -apply(clarify) -sorry - -lemma hom: " -\f_var. \f_app \ Respects(alpha ===> alpha ===> op =). -\f_lam \ Respects((op = ===> alpha) ===> op =). -\hom\Respects (alpha ===> op =). - ((\x. hom (rVar x) = f_var x) \ - (\l r. hom (rApp l r) = f_app l r (hom l) (hom r)) \ - (\x a. hom (rLam a x) = f_lam (\b. ([(a,b)]\ x)) (\b. hom ([(a,b)] \ x))))" -apply(rule allI) -apply(rule ballI)+ -apply(rule_tac x="term1_hom f_var f_app f_lam" in bexI) -apply(simp_all) -apply(simp only: in_respects) -apply(rule term1_hom_rsp) -apply(assumption)+ -done - -lemma hom': -"\hom. - ((\x. hom (Var x) = f_var x) \ - (\l r. hom (App l r) = f_app l r (hom l) (hom r)) \ - (\x a. hom (Lam a x) = f_lam (\b. ([(a,b)] \ x)) (\b. hom ([(a,b)] \ x))))" -apply (lifting hom) -done - -(* test test -lemma raw_hom_correct: - assumes f1: "f_var \ Respects (op= ===> op=)" - and f2: "f_app \ Respects (alpha ===> alpha ===> op= ===> op= ===> op=)" - and f3: "f_lam \ Respects ((op= ===> alpha) ===> (op= ===> op=) ===> op=)" - shows "\!hom\Respects (alpha ===> op =). - ((\x. hom (rVar x) = f_var x) \ - (\l r. hom (rApp l r) = f_app l r (hom l) (hom r)) \ - (\x a. hom (rLam a x) = f_lam (\b. ([(a,b)]\ x)) (\b. hom ([(a,b)] \ x))))" -unfolding Bex1_def -apply(rule ex1I) -sorry -*) - - -end - diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/Pair.thy --- a/Attic/Quot/Examples/Pair.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,120 +0,0 @@ -theory Pair -imports Quotient_Product "../../../Nominal/FSet" -begin - -fun alpha :: "('a \ 'a) \ ('a \ 'a) \ bool" (infix "\" 100) -where - "(a, b) \ (c, d) = (a = c \ b = d \ a = d \ b = c)" - -lemma alpha_refl: - shows "z \ z" - by (case_tac z, auto) - -lemma alpha_equivp: - shows "equivp op \" - unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def - by auto - -quotient_type - 'a pair_set = "'a \ 'a" / alpha - by (auto intro: alpha_equivp) - -quotient_definition - "Two :: 'a \ 'a \ 'a pair_set" -is - "Pair :: 'a \ 'a \ ('a \ 'a)" - -fun - memb_both_lists -where - "memb_both_lists a (b, c) = (memb a b \ memb a c)" - -quotient_definition - "mem_fsets :: 'a \ 'a fset pair_set \ bool" -is memb_both_lists - -lemma prod_hlp: "prod_fun abs_fset abs_fset (prod_fun rep_fset rep_fset x) = x" - by (cases x, auto simp add: Quotient_abs_rep[OF Quotient_fset]) - -lemma prod_hlp2: - "prod_rel list_eq list_eq (prod_fun rep_fset rep_fset z) (prod_fun rep_fset rep_fset z)" - by (cases z, simp) - -lemma [quot_thm]: - shows "Quotient ((op \) OOO (prod_rel list_eq list_eq)) - (abs_pair_set \ prod_fun abs_fset abs_fset) - (prod_fun rep_fset rep_fset \ rep_pair_set)" - unfolding Quotient_def comp_def - apply (intro conjI allI) - apply (simp add: prod_hlp Quotient_abs_rep[OF Quotient_pair_set]) - apply rule - apply (rule alpha_refl) - apply rule - apply (rule prod_hlp2) - apply (rule alpha_refl) - apply (intro iffI conjI) - sorry - -lemma [quot_respect]: - "(op = ===> op \ OOO prod_rel list_eq list_eq ===> op =) memb_both_lists memb_both_lists" - apply (intro fun_relI) - apply clarify - apply (simp only: memb_both_lists.simps) - sorry - -lemma [quot_respect]: - "(list_eq ===> list_eq ===> op \ OOO prod_rel list_eq list_eq) Pair Pair" - apply (intro fun_relI) - apply rule - apply (rule alpha_refl) - apply rule - prefer 2 - apply (rule alpha_refl) - apply simp - done - -lemma [quot_preserve]: - "(rep_fset ---> rep_fset ---> abs_pair_set \ prod_fun abs_fset abs_fset) Pair = Two" - by (simp add: expand_fun_eq Quotient_abs_rep[OF Quotient_fset] Two_def) - -lemma "mem_fsets a (Two b c) = (a |\| b \ a |\| c)" - by (lifting memb_both_lists.simps) - -(* Doing it in 2 steps *) - -quotient_definition - "mem_lists :: 'a \ 'a list pair_set \ bool" -is memb_both_lists - -lemma [quot_respect]: "(op = ===> op \ ===> op =) memb_both_lists memb_both_lists" - by auto - -lemma [quot_respect]: "(op = ===> op = ===> op \) Pair Pair" - by auto - -lemma step1: "mem_lists a (Two b c) = (memb a b \ memb a c)" - by (lifting memb_both_lists.simps) - -lemma step2: "mem_fsets a (Two b c) = (a |\| b \ a |\| c)" - (* apply (lifting step1) ??? *) - oops - -(* Doing it in 2 steps the other way *) - -quotient_definition - "memb_both_fsets :: 'a \ 'a fset \ 'a fset \ bool" -is memb_both_lists - -lemma [quot_respect]: - "(op = ===> prod_rel list_eq list_eq ===> op =) memb_both_lists memb_both_lists" - by (auto simp add: memb_def[symmetric]) - -lemma bla: "memb_both_fsets a (b, c) = (a |\| b \ a |\| c)" - by (lifting memb_both_lists.simps) - -lemma step2: "mem_fsets a (Two b c) = (a |\| b \ a |\| c)" - (* ??? *) - oops - -end - diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/SigmaEx.thy --- a/Attic/Quot/Examples/SigmaEx.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,253 +0,0 @@ -theory SigmaEx -imports Nominal "../Quotient" "../Quotient_List" "../Quotient_Product" -begin - -atom_decl name - -datatype robj = - rVar "name" -| rObj "(string \ rmethod) list" -| rInv "robj" "string" -| rUpd "robj" "string" "rmethod" -and rmethod = - rSig "name" "robj" - -inductive - alpha_obj :: "robj \ robj \ bool" ("_ \o _" [100, 100] 100) -and alpha_method :: "rmethod \ rmethod \ bool" ("_ \m _" [100, 100] 100) -where - a1: "a = b \ (rVar a) \o (rVar b)" -| a2: "rObj [] \o rObj []" -| a3: "rObj t1 \o rObj t2 \ m1 \m r2 \ rObj ((l1, m1) # t1) \o rObj ((l2, m2) # t2)" -| a4: "x \o y \ rInv x l1 \o rInv y l2" -| a5: "\pi::name prm. (rfv t - {a} = rfv s - {b} \ (rfv t - {a})\* pi \ (pi \ t) \o s \ (pi \ a) = b) - \ rSig a t \m rSig b s" - -lemma alpha_equivps: - shows "equivp alpha_obj" - and "equivp alpha_method" -sorry - -quotient_type - obj = robj / alpha_obj -and method = rmethod / alpha_method - by (auto intro: alpha_equivps) - -quotient_definition - "Var :: name \ obj" -is - "rVar" - -quotient_definition - "Obj :: (string \ method) list \ obj" -is - "rObj" - -quotient_definition - "Inv :: obj \ string \ obj" -is - "rInv" - -quotient_definition - "Upd :: obj \ string \ method \ obj" -is - "rUpd" - -quotient_definition - "Sig :: name \ obj \ method" -is - "rSig" - -overloading - perm_obj \ "perm :: 'x prm \ obj \ obj" (unchecked) - perm_method \ "perm :: 'x prm \ method \ method" (unchecked) -begin - -quotient_definition - "perm_obj :: 'x prm \ obj \ obj" -is - "(perm::'x prm \ robj \ robj)" - -quotient_definition - "perm_method :: 'x prm \ method \ method" -is - "(perm::'x prm \ rmethod \ rmethod)" - -end - - - -lemma tolift: -"\ fvar. - \ fobj\Respects (op = ===> list_rel (prod_rel (op =) alpha_method) ===> op =). - \ fnvk\Respects (op = ===> alpha_obj ===> op =). - \ fupd\Respects (op = ===> op = ===> alpha_obj ===> op = ===> alpha_method ===> op =). - \ fcns\Respects (op = ===> op = ===> prod_rel (op =) alpha_method ===> list_rel (prod_rel (op =) alpha_method) ===> op =). - \ fnil. - \ fpar\Respects (op = ===> op = ===> alpha_method ===> op =). - \ fsgm\Respects (op = ===> (op = ===> alpha_obj) ===> op =). - - Ex1 (\x. -(x \ (Respects (prod_rel (alpha_obj ===> op =) - (prod_rel (list_rel (prod_rel (op =) alpha_method) ===> op =) - (prod_rel ((prod_rel (op =) alpha_method) ===> op =) - (alpha_method ===> op =) - ) - )))) \ -(\ (hom_o\robj \ 'a, hom_d\(char list \ rmethod) list \ 'b, hom_e\char list \ rmethod \ 'c, hom_m\rmethod \ 'd). - -((\x. hom_o (rVar x) = fvar x) \ - (\d. hom_o (rObj d) = fobj (hom_d d) d) \ - (\a l. hom_o (rInv a l) = fnvk (hom_o a) a l) \ - (\a l m. hom_o (rUpd a l m) = fupd (hom_o a) (hom_m m) a l m) \ - (\e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \ - (hom_d [] = fnil) \ - (\l m. hom_e (l, m) = fpar (hom_m m) l m) \ - (\x a. hom_m (rSig x a) = fsgm (\y. hom_o ([(x, y)] \ a)) (\y. [(x, y)] \ a)) -)) x) " -sorry - -lemma test_to: "Ex1 (\x. (x \ (Respects alpha_obj)) \ P x)" -ML_prf {* prop_of (#goal (Isar.goal ())) *} -sorry -lemma test_tod: "Ex1 (P :: obj \ bool)" -apply (lifting test_to) -done - - - - -(*syntax - "_expttrn" :: "pttrn => bool => bool" ("(3\\ _./ _)" [0, 10] 10) - -translations - "\\ x. P" == "Ex (%x. P)" -*) - -lemma rvar_rsp[quot_respect]: "(op = ===> alpha_obj) rVar rVar" - by (simp add: a1) - -lemma robj_rsp[quot_respect]: "(list_rel (prod_rel op = alpha_method) ===> alpha_obj) rObj rObj" -sorry -lemma rinv_rsp[quot_respect]: "(alpha_obj ===> op = ===> alpha_obj) rInv rInv" -sorry -lemma rupd_rsp[quot_respect]: "(alpha_obj ===> op = ===> alpha_method ===> alpha_obj) rUpd rUpd" -sorry -lemma rsig_rsp[quot_respect]: "(op = ===> alpha_obj ===> alpha_method) rSig rSig" -sorry -lemma operm_rsp[quot_respect]: "(op = ===> alpha_obj ===> alpha_obj) op \ op \" -sorry - - -lemma bex1_bex1reg: "(\!x\Respects R. P x) \ (Bex1_rel R (\x. P x))" -apply (simp add: Ex1_def Bex1_rel_def in_respects) -apply clarify -apply auto -apply (rule bexI) -apply assumption -apply (simp add: in_respects) -apply (simp add: in_respects) -apply auto -done - -lemma liftd: " -Ex1 (\(hom_o, hom_d, hom_e, hom_m). - - (\x. hom_o (Var x) = fvar x) \ - (\d. hom_o (Obj d) = fobj (hom_d d) d) \ - (\a l. hom_o (Inv a l) = fnvk (hom_o a) a l) \ - (\a l m. hom_o (Upd a l m) = fupd (hom_o a) (hom_m m) a l m) \ - (\e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \ - (hom_d [] = fnil) \ - (\l m. hom_e (l, m) = fpar (hom_m m) l m) \ - (\x a. hom_m (Sig x a) = fsgm (\y. hom_o ([(x, y)] \ a)) (\y. [(x, y)] \ a)) -)" -apply (lifting tolift) -done - -lemma tolift': -"\ fvar. - \ fobj\Respects (op = ===> list_rel (prod_rel (op =) alpha_method) ===> op =). - \ fnvk\Respects (op = ===> alpha_obj ===> op =). - \ fupd\Respects (op = ===> op = ===> alpha_obj ===> op = ===> alpha_method ===> op =). - \ fcns\Respects (op = ===> op = ===> prod_rel (op =) alpha_method ===> list_rel (prod_rel (op =) alpha_method) ===> op =). - \ fnil. - \ fpar\Respects (op = ===> op = ===> alpha_method ===> op =). - \ fsgm\Respects (op = ===> (op = ===> alpha_obj) ===> op =). - - \ hom_o\robj \ 'a \ Respects (alpha_obj ===> op =). - \ hom_d\(char list \ rmethod) list \ 'b \ Respects (list_rel (prod_rel (op =) alpha_method) ===> op =). - \ hom_e\char list \ rmethod \ 'c \ Respects ((prod_rel (op =) alpha_method) ===> op =). - \ hom_m\rmethod \ 'd \ Respects (alpha_method ===> op =). -( - (\x. hom_o (rVar x) = fvar x) \ - (\d. hom_o (rObj d) = fobj (hom_d d) d) \ - (\a l. hom_o (rInv a l) = fnvk (hom_o a) a l) \ - (\a l m. hom_o (rUpd a l m) = fupd (hom_o a) (hom_m m) a l m) \ - (\e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \ - (hom_d [] = fnil) \ - (\l m. hom_e (l, m) = fpar (hom_m m) l m) \ - (\x a. hom_m (rSig x a) = fsgm (\y. hom_o ([(x, y)] \ a)) (\y. [(x, y)] \ a)) -)" -sorry - -lemma liftd': " -\hom_o. \hom_d. \hom_e. \hom_m. -( - (\x. hom_o (Var x) = fvar x) \ - (\d. hom_o (Obj d) = fobj (hom_d d) d) \ - (\a l. hom_o (Inv a l) = fnvk (hom_o a) a l) \ - (\a l m. hom_o (Upd a l m) = fupd (hom_o a) (hom_m m) a l m) \ - (\e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \ - (hom_d [] = fnil) \ - (\l m. hom_e (l, m) = fpar (hom_m m) l m) \ - (\x a. hom_m (Sig x a) = fsgm (\y. hom_o ([(x, y)] \ a)) (\y. [(x, y)] \ a)) -)" -apply (lifting tolift') -done - -lemma tolift'': -"\ fvar. - \ fobj\Respects (op = ===> list_rel (prod_rel (op =) alpha_method) ===> op =). - \ fnvk\Respects (op = ===> alpha_obj ===> op =). - \ fupd\Respects (op = ===> op = ===> alpha_obj ===> op = ===> alpha_method ===> op =). - \ fcns\Respects (op = ===> op = ===> prod_rel (op =) alpha_method ===> list_rel (prod_rel (op =) alpha_method) ===> op =). - \ fnil. - \ fpar\Respects (op = ===> op = ===> alpha_method ===> op =). - \ fsgm\Respects (op = ===> (op = ===> alpha_obj) ===> op =). - - Bex1_rel (alpha_obj ===> op =) (\hom_o\robj \ 'a . - Bex1_rel (list_rel (prod_rel (op =) alpha_method) ===> op =) (\hom_d\(char list \ rmethod) list \ 'b. - Bex1_rel ((prod_rel (op =) alpha_method) ===> op =) (\hom_e\char list \ rmethod \ 'c. - Bex1_rel (alpha_method ===> op =) (\hom_m\rmethod \ 'd. -( - (\x. hom_o (rVar x) = fvar x) \ - (\d. hom_o (rObj d) = fobj (hom_d d) d) \ - (\a l. hom_o (rInv a l) = fnvk (hom_o a) a l) \ - (\a l m. hom_o (rUpd a l m) = fupd (hom_o a) (hom_m m) a l m) \ - (\e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \ - (hom_d [] = fnil) \ - (\l m. hom_e (l, m) = fpar (hom_m m) l m) \ - (\x a. hom_m (rSig x a) = fsgm (\y. hom_o ([(x, y)] \ a)) (\y. [(x, y)] \ a)) -) -))))" -sorry - -lemma liftd'': " -\!hom_o. \!hom_d. \!hom_e. \!hom_m. -( - (\x. hom_o (Var x) = fvar x) \ - (\d. hom_o (Obj d) = fobj (hom_d d) d) \ - (\a l. hom_o (Inv a l) = fnvk (hom_o a) a l) \ - (\a l m. hom_o (Upd a l m) = fupd (hom_o a) (hom_m m) a l m) \ - (\e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \ - (hom_d [] = fnil) \ - (\l m. hom_e (l, m) = fpar (hom_m m) l m) \ - (\x a. hom_m (Sig x a) = fsgm (\y. hom_o ([(x, y)] \ a)) (\y. [(x, y)] \ a)) -)" -apply (lifting tolift'') -done - - -end - diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Examples/Terms.thy --- a/Attic/Quot/Examples/Terms.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,271 +0,0 @@ -theory Terms -imports Nominal "../Quotient" "../Quotient_List" -begin - -atom_decl name - -text {* primrec seems to be genarally faster than fun *} - -section {*** lets with binding patterns ***} - -datatype trm1 = - Vr1 "name" -| Ap1 "trm1" "trm1" -| Lm1 "name" "trm1" --"name is bound in trm1" -| Lt1 "bp" "trm1" "trm1" --"all variables in bp are bound in the 2nd trm1" -and bp = - BUnit -| BVr "name" -| BPr "bp" "bp" - -(* to be given by the user *) -primrec - bv1 -where - "bv1 (BUnit) = {}" -| "bv1 (BVr x) = {x}" -| "bv1 (BPr bp1 bp2) = (bv1 bp1) \ (bv1 bp1)" - -(* needs to be calculated by the package *) -primrec - fv_trm1 and fv_bp -where - "fv_trm1 (Vr1 x) = {x}" -| "fv_trm1 (Ap1 t1 t2) = (fv_trm1 t1) \ (fv_trm1 t2)" -| "fv_trm1 (Lm1 x t) = (fv_trm1 t) - {x}" -| "fv_trm1 (Lt1 bp t1 t2) = (fv_trm1 t1) \ (fv_trm1 t2 - bv1 bp)" -| "fv_bp (BUnit) = {}" -| "fv_bp (BVr x) = {x}" -| "fv_bp (BPr b1 b2) = (fv_bp b1) \ (fv_bp b2)" - -(* needs to be stated by the package *) -overloading - perm_trm1 \ "perm :: 'x prm \ trm1 \ trm1" (unchecked) - perm_bp \ "perm :: 'x prm \ bp \ bp" (unchecked) -begin - -primrec - perm_trm1 and perm_bp -where - "perm_trm1 pi (Vr1 a) = Vr1 (pi \ a)" -| "perm_trm1 pi (Ap1 t1 t2) = Ap1 (perm_trm1 pi t1) (perm_trm1 pi t2)" -| "perm_trm1 pi (Lm1 a t) = Lm1 (pi \ a) (perm_trm1 pi t)" -| "perm_trm1 pi (Lt1 bp t1 t2) = Lt1 (perm_bp pi bp) (perm_trm1 pi t1) (perm_trm1 pi t2)" -| "perm_bp pi (BUnit) = BUnit" -| "perm_bp pi (BVr a) = BVr (pi \ a)" -| "perm_bp pi (BPr bp1 bp2) = BPr (perm_bp pi bp1) (perm_bp pi bp2)" - -end - -inductive - alpha1 :: "trm1 \ trm1 \ bool" ("_ \1 _" [100, 100] 100) -where - a1: "a = b \ (Vr1 a) \1 (Vr1 b)" -| a2: "\t1 \1 t2; s1 \1 s2\ \ Ap1 t1 s1 \1 Ap1 t2 s2" -| a3: "\pi::name prm. (fv_trm1 t - {a} = fv_trm1 s - {b} \ - (fv_trm1 t - {a})\* pi \ - (pi \ t) \1 s \ (pi \ a) = b) - \ Lm1 a t \1 Lm1 b s" -| a4: "\pi::name prm.( - t1 \1 t2 \ - (fv_trm1 s1 - fv_bp b1 = fv_trm1 s2 - fv_bp b2) \ - (fv_trm1 s1 - fv_bp b1) \* pi \ - (pi \ s1 = s2) (* Optional: \ (pi \ b1 = b2) *) - ) \ Lt1 b1 t1 s1 \1 Lt1 b2 t2 s2" - -lemma alpha1_equivp: "equivp alpha1" sorry - -quotient_type qtrm1 = trm1 / alpha1 - by (rule alpha1_equivp) - - -section {*** lets with single assignments ***} - -datatype trm2 = - Vr2 "name" -| Ap2 "trm2" "trm2" -| Lm2 "name" "trm2" -| Lt2 "assign" "trm2" -and assign = - As "name" "trm2" - -(* to be given by the user *) -primrec - bv2 -where - "bv2 (As x t) = {x}" - -(* needs to be calculated by the package *) -primrec - fv_trm2 and fv_assign -where - "fv_trm2 (Vr2 x) = {x}" -| "fv_trm2 (Ap2 t1 t2) = (fv_trm2 t1) \ (fv_trm2 t2)" -| "fv_trm2 (Lm2 x t) = (fv_trm2 t) - {x}" -| "fv_trm2 (Lt2 as t) = (fv_trm2 t - bv2 as) \ (fv_assign as)" -| "fv_assign (As x t) = (fv_trm2 t)" - -(* needs to be stated by the package *) -overloading - perm_trm2 \ "perm :: 'x prm \ trm2 \ trm2" (unchecked) - perm_assign \ "perm :: 'x prm \ assign \ assign" (unchecked) -begin - -primrec - perm_trm2 and perm_assign -where - "perm_trm2 pi (Vr2 a) = Vr2 (pi \ a)" -| "perm_trm2 pi (Ap2 t1 t2) = Ap2 (perm_trm2 pi t1) (perm_trm2 pi t2)" -| "perm_trm2 pi (Lm2 a t) = Lm2 (pi \ a) (perm_trm2 pi t)" -| "perm_trm2 pi (Lt2 as t) = Lt2 (perm_assign pi as) (perm_trm2 pi t)" -| "perm_assign pi (As a t) = As (pi \ a) (perm_trm2 pi t)" - -end - -inductive - alpha2 :: "trm2 \ trm2 \ bool" ("_ \2 _" [100, 100] 100) -where - a1: "a = b \ (Vr2 a) \2 (Vr2 b)" -| a2: "\t1 \2 t2; s1 \2 s2\ \ Ap2 t1 s1 \2 Ap2 t2 s2" -| a3: "\pi::name prm. (fv_trm2 t - {a} = fv_trm2 s - {b} \ - (fv_trm2 t - {a})\* pi \ - (pi \ t) \2 s \ - (pi \ a) = b) - \ Lm2 a t \2 Lm2 b s" -| a4: "\pi::name prm. ( - fv_trm2 t1 - fv_assign b1 = fv_trm2 t2 - fv_assign b2 \ - (fv_trm2 t1 - fv_assign b1) \* pi \ - pi \ t1 = t2 (* \ (pi \ b1 = b2) *) - ) \ Lt2 b1 t1 \2 Lt2 b2 t2" - -lemma alpha2_equivp: "equivp alpha2" sorry - -quotient_type qtrm2 = trm2 / alpha2 - by (rule alpha2_equivp) - -section {*** lets with many assignments ***} - -datatype trm3 = - Vr3 "name" -| Ap3 "trm3" "trm3" -| Lm3 "name" "trm3" -| Lt3 "assigns" "trm3" -and assigns = - ANil -| ACons "name" "trm3" "assigns" - -(* to be given by the user *) -primrec - bv3 -where - "bv3 ANil = {}" -| "bv3 (ACons x t as) = {x} \ (bv3 as)" - -primrec - fv_trm3 and fv_assigns -where - "fv_trm3 (Vr3 x) = {x}" -| "fv_trm3 (Ap3 t1 t2) = (fv_trm3 t1) \ (fv_trm3 t2)" -| "fv_trm3 (Lm3 x t) = (fv_trm3 t) - {x}" -| "fv_trm3 (Lt3 as t) = (fv_trm3 t - bv3 as) \ (fv_assigns as)" -| "fv_assigns (ANil) = {}" -| "fv_assigns (ACons x t as) = (fv_trm3 t) \ (fv_assigns as)" - -(* needs to be stated by the package *) -overloading - perm_trm3 \ "perm :: 'x prm \ trm3 \ trm3" (unchecked) - perm_assigns \ "perm :: 'x prm \ assigns \ assigns" (unchecked) -begin - -primrec - perm_trm3 and perm_assigns -where - "perm_trm3 pi (Vr3 a) = Vr3 (pi \ a)" -| "perm_trm3 pi (Ap3 t1 t2) = Ap3 (perm_trm3 pi t1) (perm_trm3 pi t2)" -| "perm_trm3 pi (Lm3 a t) = Lm3 (pi \ a) (perm_trm3 pi t)" -| "perm_trm3 pi (Lt3 as t) = Lt3 (perm_assigns pi as) (perm_trm3 pi t)" -| "perm_assigns pi (ANil) = ANil" -| "perm_assigns pi (ACons a t as) = ACons (pi \ a) (perm_trm3 pi t) (perm_assigns pi as)" - -end - -inductive - alpha3 :: "trm3 \ trm3 \ bool" ("_ \3 _" [100, 100] 100) -where - a1: "a = b \ (Vr3 a) \3 (Vr3 b)" -| a2: "\t1 \3 t2; s1 \3 s2\ \ Ap3 t1 s1 \3 Ap3 t2 s2" -| a3: "\pi::name prm. (fv_trm3 t - {a} = fv_trm3 s - {b} \ - (fv_trm3 t - {a})\* pi \ - (pi \ t) \3 s \ - (pi \ a) = b) - \ Lm3 a t \3 Lm3 b s" -| a4: "\pi::name prm. ( - fv_trm3 t1 - fv_assigns b1 = fv_trm3 t2 - fv_assigns b2 \ - (fv_trm3 t1 - fv_assigns b1) \* pi \ - pi \ t1 = t2 (* \ (pi \ b1 = b2) *) - ) \ Lt3 b1 t1 \3 Lt3 b2 t2" - -lemma alpha3_equivp: "equivp alpha3" sorry - -quotient_type qtrm3 = trm3 / alpha3 - by (rule alpha3_equivp) - - -section {*** lam with indirect list recursion ***} - -datatype trm4 = - Vr4 "name" -| Ap4 "trm4" "trm4 list" -| Lm4 "name" "trm4" - -thm trm4.recs - -primrec - fv_trm4 and fv_trm4_list -where - "fv_trm4 (Vr4 x) = {x}" -| "fv_trm4 (Ap4 t ts) = (fv_trm4 t) \ (fv_trm4_list ts)" -| "fv_trm4 (Lm4 x t) = (fv_trm4 t) - {x}" -| "fv_trm4_list ([]) = {}" -| "fv_trm4_list (t#ts) = (fv_trm4 t) \ (fv_trm4_list ts)" - - -(* needs to be stated by the package *) -(* there cannot be a clause for lists, as *) -(* permutations are already defined in Nominal (also functions, options, and so on) *) -overloading - perm_trm4 \ "perm :: 'x prm \ trm4 \ trm4" (unchecked) -begin - -primrec - perm_trm4 -where - "perm_trm4 pi (Vr4 a) = Vr4 (pi \ a)" -| "perm_trm4 pi (Ap4 t ts) = Ap4 (perm_trm4 pi t) (pi \ ts)" -| "perm_trm4 pi (Lm4 a t) = Lm4 (pi \ a) (perm_trm4 pi t)" - -end - -inductive - alpha4 :: "trm4 \ trm4 \ bool" ("_ \4 _" [100, 100] 100) -and alpha4list :: "trm4 list \ trm4 list \ bool" ("_ \4list _" [100, 100] 100) -where - a1: "a = b \ (Vr4 a) \4 (Vr4 b)" -| a2: "\t1 \4 t2; s1 \4list s2\ \ Ap4 t1 s1 \4 Ap4 t2 s2" -| a4: "\pi::name prm. (fv_trm4 t - {a} = fv_trm4 s - {b} \ - (fv_trm4 t - {a})\* pi \ - (pi \ t) \4 s \ - (pi \ a) = b) - \ Lm4 a t \4 Lm4 b s" -| a5: "[] \4list []" -| a6: "\t \4 s; ts \4list ss\ \ (t#ts) \4list (s#ss)" - -lemma alpha4_equivp: "equivp alpha4" sorry -lemma alpha4list_equivp: "equivp alpha4list" sorry - -quotient_type - qtrm4 = trm4 / alpha4 and - qtrm4list = "trm4 list" / alpha4list - by (simp_all add: alpha4_equivp alpha4list_equivp) - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Quotient.thy --- a/Attic/Quot/Quotient.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,797 +0,0 @@ -(* Title: Quotient.thy - Author: Cezary Kaliszyk and Christian Urban -*) - -theory Quotient -imports Plain ATP_Linkup -uses - ("quotient_info.ML") - ("quotient_typ.ML") - ("quotient_def.ML") - ("quotient_term.ML") - ("quotient_tacs.ML") -begin - - -text {* - Basic definition for equivalence relations - that are represented by predicates. -*} - -definition - "equivp E \ \x y. E x y = (E x = E y)" - -definition - "reflp E \ \x. E x x" - -definition - "symp E \ \x y. E x y \ E y x" - -definition - "transp E \ \x y z. E x y \ E y z \ E x z" - -lemma equivp_reflp_symp_transp: - shows "equivp E = (reflp E \ symp E \ transp E)" - unfolding equivp_def reflp_def symp_def transp_def expand_fun_eq - by blast - -lemma equivp_reflp: - shows "equivp E \ E x x" - by (simp only: equivp_reflp_symp_transp reflp_def) - -lemma equivp_symp: - shows "equivp E \ E x y \ E y x" - by (metis equivp_reflp_symp_transp symp_def) - -lemma equivp_transp: - shows "equivp E \ E x y \ E y z \ E x z" - by (metis equivp_reflp_symp_transp transp_def) - -lemma equivpI: - assumes "reflp R" "symp R" "transp R" - shows "equivp R" - using assms by (simp add: equivp_reflp_symp_transp) - -lemma identity_equivp: - shows "equivp (op =)" - unfolding equivp_def - by auto - -text {* Partial equivalences: not yet used anywhere *} - -definition - "part_equivp E \ (\x. E x x) \ (\x y. E x y = (E x x \ E y y \ (E x = E y)))" - -lemma equivp_implies_part_equivp: - assumes a: "equivp E" - shows "part_equivp E" - using a - unfolding equivp_def part_equivp_def - by auto - -text {* Composition of Relations *} - -abbreviation - rel_conj (infixr "OOO" 75) -where - "r1 OOO r2 \ r1 OO r2 OO r1" - -lemma eq_comp_r: - shows "((op =) OOO R) = R" - by (auto simp add: expand_fun_eq) - -section {* Respects predicate *} - -definition - Respects -where - "Respects R x \ R x x" - -lemma in_respects: - shows "(x \ Respects R) = R x x" - unfolding mem_def Respects_def - by simp - -section {* Function map and function relation *} - -definition - fun_map (infixr "--->" 55) -where -[simp]: "fun_map f g h x = g (h (f x))" - -definition - fun_rel (infixr "===>" 55) -where -[simp]: "fun_rel E1 E2 f g = (\x y. E1 x y \ E2 (f x) (g y))" - - -lemma fun_map_id: - shows "(id ---> id) = id" - by (simp add: expand_fun_eq id_def) - -lemma fun_rel_eq: - shows "((op =) ===> (op =)) = (op =)" - by (simp add: expand_fun_eq) - -lemma fun_rel_id: - assumes a: "\x y. R1 x y \ R2 (f x) (g y)" - shows "(R1 ===> R2) f g" - using a by simp - -lemma fun_rel_id_asm: - assumes a: "\x y. R1 x y \ (A \ R2 (f x) (g y))" - shows "A \ (R1 ===> R2) f g" - using a by auto - - -section {* Quotient Predicate *} - -definition - "Quotient E Abs Rep \ - (\a. Abs (Rep a) = a) \ (\a. E (Rep a) (Rep a)) \ - (\r s. E r s = (E r r \ E s s \ (Abs r = Abs s)))" - -lemma Quotient_abs_rep: - assumes a: "Quotient E Abs Rep" - shows "Abs (Rep a) = a" - using a - unfolding Quotient_def - by simp - -lemma Quotient_rep_reflp: - assumes a: "Quotient E Abs Rep" - shows "E (Rep a) (Rep a)" - using a - unfolding Quotient_def - by blast - -lemma Quotient_rel: - assumes a: "Quotient E Abs Rep" - shows " E r s = (E r r \ E s s \ (Abs r = Abs s))" - using a - unfolding Quotient_def - by blast - -lemma Quotient_rel_rep: - assumes a: "Quotient R Abs Rep" - shows "R (Rep a) (Rep b) = (a = b)" - using a - unfolding Quotient_def - by metis - -lemma Quotient_rep_abs: - assumes a: "Quotient R Abs Rep" - shows "R r r \ R (Rep (Abs r)) r" - using a unfolding Quotient_def - by blast - -lemma Quotient_rel_abs: - assumes a: "Quotient E Abs Rep" - shows "E r s \ Abs r = Abs s" - using a unfolding Quotient_def - by blast - -lemma Quotient_symp: - assumes a: "Quotient E Abs Rep" - shows "symp E" - using a unfolding Quotient_def symp_def - by metis - -lemma Quotient_transp: - assumes a: "Quotient E Abs Rep" - shows "transp E" - using a unfolding Quotient_def transp_def - by metis - -lemma identity_quotient: - shows "Quotient (op =) id id" - unfolding Quotient_def id_def - by blast - -lemma fun_quotient: - assumes q1: "Quotient R1 abs1 rep1" - and q2: "Quotient R2 abs2 rep2" - shows "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)" -proof - - have "\a. (rep1 ---> abs2) ((abs1 ---> rep2) a) = a" - using q1 q2 - unfolding Quotient_def - unfolding expand_fun_eq - by simp - moreover - have "\a. (R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)" - using q1 q2 - unfolding Quotient_def - by (simp (no_asm)) (metis) - moreover - have "\r s. (R1 ===> R2) r s = ((R1 ===> R2) r r \ (R1 ===> R2) s s \ - (rep1 ---> abs2) r = (rep1 ---> abs2) s)" - unfolding expand_fun_eq - apply(auto) - using q1 q2 unfolding Quotient_def - apply(metis) - using q1 q2 unfolding Quotient_def - apply(metis) - using q1 q2 unfolding Quotient_def - apply(metis) - using q1 q2 unfolding Quotient_def - apply(metis) - done - ultimately - show "Quotient (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)" - unfolding Quotient_def by blast -qed - -lemma abs_o_rep: - assumes a: "Quotient R Abs Rep" - shows "Abs o Rep = id" - unfolding expand_fun_eq - by (simp add: Quotient_abs_rep[OF a]) - -lemma equals_rsp: - assumes q: "Quotient R Abs Rep" - and a: "R xa xb" "R ya yb" - shows "R xa ya = R xb yb" - using a Quotient_symp[OF q] Quotient_transp[OF q] - unfolding symp_def transp_def - by blast - -lemma lambda_prs: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "(Rep1 ---> Abs2) (\x. Rep2 (f (Abs1 x))) = (\x. f x)" - unfolding expand_fun_eq - using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] - by simp - -lemma lambda_prs1: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "(Rep1 ---> Abs2) (\x. (Abs1 ---> Rep2) f x) = (\x. f x)" - unfolding expand_fun_eq - using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] - by simp - -lemma rep_abs_rsp: - assumes q: "Quotient R Abs Rep" - and a: "R x1 x2" - shows "R x1 (Rep (Abs x2))" - using a Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q] - by metis - -lemma rep_abs_rsp_left: - assumes q: "Quotient R Abs Rep" - and a: "R x1 x2" - shows "R (Rep (Abs x1)) x2" - using a Quotient_rel[OF q] Quotient_abs_rep[OF q] Quotient_rep_reflp[OF q] - by metis - -text{* - In the following theorem R1 can be instantiated with anything, - but we know some of the types of the Rep and Abs functions; - so by solving Quotient assumptions we can get a unique R1 that - will be provable; which is why we need to use apply_rsp and - not the primed version *} - -lemma apply_rsp: - fixes f g::"'a \ 'c" - assumes q: "Quotient R1 Abs1 Rep1" - and a: "(R1 ===> R2) f g" "R1 x y" - shows "R2 (f x) (g y)" - using a by simp - -lemma apply_rsp': - assumes a: "(R1 ===> R2) f g" "R1 x y" - shows "R2 (f x) (g y)" - using a by simp - -section {* lemmas for regularisation of ball and bex *} - -lemma ball_reg_eqv: - fixes P :: "'a \ bool" - assumes a: "equivp R" - shows "Ball (Respects R) P = (All P)" - using a - unfolding equivp_def - by (auto simp add: in_respects) - -lemma bex_reg_eqv: - fixes P :: "'a \ bool" - assumes a: "equivp R" - shows "Bex (Respects R) P = (Ex P)" - using a - unfolding equivp_def - by (auto simp add: in_respects) - -lemma ball_reg_right: - assumes a: "\x. R x \ P x \ Q x" - shows "All P \ Ball R Q" - using a by (metis COMBC_def Collect_def Collect_mem_eq) - -lemma bex_reg_left: - assumes a: "\x. R x \ Q x \ P x" - shows "Bex R Q \ Ex P" - using a by (metis COMBC_def Collect_def Collect_mem_eq) - -lemma ball_reg_left: - assumes a: "equivp R" - shows "(\x. (Q x \ P x)) \ Ball (Respects R) Q \ All P" - using a by (metis equivp_reflp in_respects) - -lemma bex_reg_right: - assumes a: "equivp R" - shows "(\x. (Q x \ P x)) \ Ex Q \ Bex (Respects R) P" - using a by (metis equivp_reflp in_respects) - -lemma ball_reg_eqv_range: - fixes P::"'a \ bool" - and x::"'a" - assumes a: "equivp R2" - shows "(Ball (Respects (R1 ===> R2)) (\f. P (f x)) = All (\f. P (f x)))" - apply(rule iffI) - apply(rule allI) - apply(drule_tac x="\y. f x" in bspec) - apply(simp add: in_respects) - apply(rule impI) - using a equivp_reflp_symp_transp[of "R2"] - apply(simp add: reflp_def) - apply(simp) - apply(simp) - done - -lemma bex_reg_eqv_range: - assumes a: "equivp R2" - shows "(Bex (Respects (R1 ===> R2)) (\f. P (f x)) = Ex (\f. P (f x)))" - apply(auto) - apply(rule_tac x="\y. f x" in bexI) - apply(simp) - apply(simp add: Respects_def in_respects) - apply(rule impI) - using a equivp_reflp_symp_transp[of "R2"] - apply(simp add: reflp_def) - done - -(* Next four lemmas are unused *) -lemma all_reg: - assumes a: "!x :: 'a. (P x --> Q x)" - and b: "All P" - shows "All Q" - using a b by (metis) - -lemma ex_reg: - assumes a: "!x :: 'a. (P x --> Q x)" - and b: "Ex P" - shows "Ex Q" - using a b by metis - -lemma ball_reg: - assumes a: "!x :: 'a. (R x --> P x --> Q x)" - and b: "Ball R P" - shows "Ball R Q" - using a b by (metis COMBC_def Collect_def Collect_mem_eq) - -lemma bex_reg: - assumes a: "!x :: 'a. (R x --> P x --> Q x)" - and b: "Bex R P" - shows "Bex R Q" - using a b by (metis COMBC_def Collect_def Collect_mem_eq) - - -lemma ball_all_comm: - assumes "\y. (\x\P. A x y) \ (\x. B x y)" - shows "(\x\P. \y. A x y) \ (\x. \y. B x y)" - using assms by auto - -lemma bex_ex_comm: - assumes "(\y. \x. A x y) \ (\y. \x\P. B x y)" - shows "(\x. \y. A x y) \ (\x\P. \y. B x y)" - using assms by auto - -section {* Bounded abstraction *} - -definition - Babs :: "('a \ bool) \ ('a \ 'b) \ 'a \ 'b" -where - "x \ p \ Babs p m x = m x" - -lemma babs_rsp: - assumes q: "Quotient R1 Abs1 Rep1" - and a: "(R1 ===> R2) f g" - shows "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)" - apply (auto simp add: Babs_def in_respects) - apply (subgoal_tac "x \ Respects R1 \ y \ Respects R1") - using a apply (simp add: Babs_def) - apply (simp add: in_respects) - using Quotient_rel[OF q] - by metis - -lemma babs_prs: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "((Rep1 ---> Abs2) (Babs (Respects R1) ((Abs1 ---> Rep2) f))) = f" - apply (rule ext) - apply (simp) - apply (subgoal_tac "Rep1 x \ Respects R1") - apply (simp add: Babs_def Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]) - apply (simp add: in_respects Quotient_rel_rep[OF q1]) - done - -lemma babs_simp: - assumes q: "Quotient R1 Abs Rep" - shows "((R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)) = ((R1 ===> R2) f g)" - apply(rule iffI) - apply(simp_all only: babs_rsp[OF q]) - apply(auto simp add: Babs_def) - apply (subgoal_tac "x \ Respects R1 \ y \ Respects R1") - apply(metis Babs_def) - apply (simp add: in_respects) - using Quotient_rel[OF q] - by metis - -(* If a user proves that a particular functional relation - is an equivalence this may be useful in regularising *) -lemma babs_reg_eqv: - shows "equivp R \ Babs (Respects R) P = P" - by (simp add: expand_fun_eq Babs_def in_respects equivp_reflp) - - -(* 3 lemmas needed for proving repabs_inj *) -lemma ball_rsp: - assumes a: "(R ===> (op =)) f g" - shows "Ball (Respects R) f = Ball (Respects R) g" - using a by (simp add: Ball_def in_respects) - -lemma bex_rsp: - assumes a: "(R ===> (op =)) f g" - shows "(Bex (Respects R) f = Bex (Respects R) g)" - using a by (simp add: Bex_def in_respects) - -lemma bex1_rsp: - assumes a: "(R ===> (op =)) f g" - shows "Ex1 (\x. x \ Respects R \ f x) = Ex1 (\x. x \ Respects R \ g x)" - using a - by (simp add: Ex1_def in_respects) auto - -(* 2 lemmas needed for cleaning of quantifiers *) -lemma all_prs: - assumes a: "Quotient R absf repf" - shows "Ball (Respects R) ((absf ---> id) f) = All f" - using a unfolding Quotient_def Ball_def in_respects fun_map_def id_apply - by metis - -lemma ex_prs: - assumes a: "Quotient R absf repf" - shows "Bex (Respects R) ((absf ---> id) f) = Ex f" - using a unfolding Quotient_def Bex_def in_respects fun_map_def id_apply - by metis - -section {* Bex1_rel quantifier *} - -definition - Bex1_rel :: "('a \ 'a \ bool) \ ('a \ bool) \ bool" -where - "Bex1_rel R P \ (\x \ Respects R. P x) \ (\x \ Respects R. \y \ Respects R. ((P x \ P y) \ (R x y)))" - -lemma bex1_rel_aux: - "\\xa ya. R xa ya \ x xa = y ya; Bex1_rel R x\ \ Bex1_rel R y" - unfolding Bex1_rel_def - apply (erule conjE)+ - apply (erule bexE) - apply rule - apply (rule_tac x="xa" in bexI) - apply metis - apply metis - apply rule+ - apply (erule_tac x="xaa" in ballE) - prefer 2 - apply (metis) - apply (erule_tac x="ya" in ballE) - prefer 2 - apply (metis) - apply (metis in_respects) - done - -lemma bex1_rel_aux2: - "\\xa ya. R xa ya \ x xa = y ya; Bex1_rel R y\ \ Bex1_rel R x" - unfolding Bex1_rel_def - apply (erule conjE)+ - apply (erule bexE) - apply rule - apply (rule_tac x="xa" in bexI) - apply metis - apply metis - apply rule+ - apply (erule_tac x="xaa" in ballE) - prefer 2 - apply (metis) - apply (erule_tac x="ya" in ballE) - prefer 2 - apply (metis) - apply (metis in_respects) - done - -lemma bex1_rel_rsp: - assumes a: "Quotient R absf repf" - shows "((R ===> op =) ===> op =) (Bex1_rel R) (Bex1_rel R)" - apply simp - apply clarify - apply rule - apply (simp_all add: bex1_rel_aux bex1_rel_aux2) - apply (erule bex1_rel_aux2) - apply assumption - done - - -lemma ex1_prs: - assumes a: "Quotient R absf repf" - shows "((absf ---> id) ---> id) (Bex1_rel R) f = Ex1 f" -apply simp -apply (subst Bex1_rel_def) -apply (subst Bex_def) -apply (subst Ex1_def) -apply simp -apply rule - apply (erule conjE)+ - apply (erule_tac exE) - apply (erule conjE) - apply (subgoal_tac "\y. R y y \ f (absf y) \ R x y") - apply (rule_tac x="absf x" in exI) - apply (simp) - apply rule+ - using a unfolding Quotient_def - apply metis - apply rule+ - apply (erule_tac x="x" in ballE) - apply (erule_tac x="y" in ballE) - apply simp - apply (simp add: in_respects) - apply (simp add: in_respects) -apply (erule_tac exE) - apply rule - apply (rule_tac x="repf x" in exI) - apply (simp only: in_respects) - apply rule - apply (metis Quotient_rel_rep[OF a]) -using a unfolding Quotient_def apply (simp) -apply rule+ -using a unfolding Quotient_def in_respects -apply metis -done - -lemma bex1_bexeq_reg: "(\!x\Respects R. P x) \ (Bex1_rel R (\x. P x))" - apply (simp add: Ex1_def Bex1_rel_def in_respects) - apply clarify - apply auto - apply (rule bexI) - apply assumption - apply (simp add: in_respects) - apply (simp add: in_respects) - apply auto - done - -section {* Various respects and preserve lemmas *} - -lemma quot_rel_rsp: - assumes a: "Quotient R Abs Rep" - shows "(R ===> R ===> op =) R R" - apply(rule fun_rel_id)+ - apply(rule equals_rsp[OF a]) - apply(assumption)+ - done - -lemma o_prs: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - and q3: "Quotient R3 Abs3 Rep3" - shows "(Rep1 ---> Abs3) (((Abs2 ---> Rep3) f) o ((Abs1 ---> Rep2) g)) = f o g" - using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] Quotient_abs_rep[OF q3] - unfolding o_def expand_fun_eq by simp - -lemma o_rsp: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - and q3: "Quotient R3 Abs3 Rep3" - and a1: "(R2 ===> R3) f1 f2" - and a2: "(R1 ===> R2) g1 g2" - shows "(R1 ===> R3) (f1 o g1) (f2 o g2)" - using a1 a2 unfolding o_def expand_fun_eq - by (auto) - -lemma cond_prs: - assumes a: "Quotient R absf repf" - shows "absf (if a then repf b else repf c) = (if a then b else c)" - using a unfolding Quotient_def by auto - -lemma if_prs: - assumes q: "Quotient R Abs Rep" - shows "Abs (If a (Rep b) (Rep c)) = If a b c" - using Quotient_abs_rep[OF q] by auto - -(* q not used *) -lemma if_rsp: - assumes q: "Quotient R Abs Rep" - and a: "a1 = a2" "R b1 b2" "R c1 c2" - shows "R (If a1 b1 c1) (If a2 b2 c2)" - using a by auto - -lemma let_prs: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "Abs2 (Let (Rep1 x) ((Abs1 ---> Rep2) f)) = Let x f" - using Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2] by auto - -lemma let_rsp: - assumes q1: "Quotient R1 Abs1 Rep1" - and a1: "(R1 ===> R2) f g" - and a2: "R1 x y" - shows "R2 ((Let x f)::'c) ((Let y g)::'c)" - using apply_rsp[OF q1 a1] a2 by auto - -locale quot_type = - fixes R :: "'a \ 'a \ bool" - and Abs :: "('a \ bool) \ 'b" - and Rep :: "'b \ ('a \ bool)" - assumes equivp: "equivp R" - and rep_prop: "\y. \x. Rep y = R x" - and rep_inverse: "\x. Abs (Rep x) = x" - and abs_inverse: "\x. (Rep (Abs (R x))) = (R x)" - and rep_inject: "\x y. (Rep x = Rep y) = (x = y)" -begin - -definition - abs::"'a \ 'b" -where - "abs x \ Abs (R x)" - -definition - rep::"'b \ 'a" -where - "rep a = Eps (Rep a)" - -lemma homeier_lem9: - shows "R (Eps (R x)) = R x" -proof - - have a: "R x x" using equivp by (simp add: equivp_reflp_symp_transp reflp_def) - then have "R x (Eps (R x))" by (rule someI) - then show "R (Eps (R x)) = R x" - using equivp unfolding equivp_def by simp -qed - -theorem homeier_thm10: - shows "abs (rep a) = a" - unfolding abs_def rep_def -proof - - from rep_prop - obtain x where eq: "Rep a = R x" by auto - have "Abs (R (Eps (Rep a))) = Abs (R (Eps (R x)))" using eq by simp - also have "\ = Abs (R x)" using homeier_lem9 by simp - also have "\ = Abs (Rep a)" using eq by simp - also have "\ = a" using rep_inverse by simp - finally - show "Abs (R (Eps (Rep a))) = a" by simp -qed - -lemma homeier_lem7: - shows "(R x = R y) = (Abs (R x) = Abs (R y))" (is "?LHS = ?RHS") -proof - - have "?RHS = (Rep (Abs (R x)) = Rep (Abs (R y)))" by (simp add: rep_inject) - also have "\ = ?LHS" by (simp add: abs_inverse) - finally show "?LHS = ?RHS" by simp -qed - -theorem homeier_thm11: - shows "R r r' = (abs r = abs r')" - unfolding abs_def - by (simp only: equivp[simplified equivp_def] homeier_lem7) - -lemma rep_refl: - shows "R (rep a) (rep a)" - unfolding rep_def - by (simp add: equivp[simplified equivp_def]) - - -lemma rep_abs_rsp: - shows "R f (rep (abs g)) = R f g" - and "R (rep (abs g)) f = R g f" - by (simp_all add: homeier_thm10 homeier_thm11) - -lemma Quotient: - shows "Quotient R abs rep" - unfolding Quotient_def - apply(simp add: homeier_thm10) - apply(simp add: rep_refl) - apply(subst homeier_thm11[symmetric]) - apply(simp add: equivp[simplified equivp_def]) - done - -end - -section {* ML setup *} - -text {* Auxiliary data for the quotient package *} - -use "quotient_info.ML" - -declare [[map "fun" = (fun_map, fun_rel)]] - -lemmas [quot_thm] = fun_quotient -lemmas [quot_respect] = quot_rel_rsp -lemmas [quot_equiv] = identity_equivp - - -text {* Lemmas about simplifying id's. *} -lemmas [id_simps] = - id_def[symmetric] - fun_map_id - id_apply - id_o - o_id - eq_comp_r - -text {* Translation functions for the lifting process. *} -use "quotient_term.ML" - - -text {* Definitions of the quotient types. *} -use "quotient_typ.ML" - - -text {* Definitions for quotient constants. *} -use "quotient_def.ML" - - -text {* - An auxiliary constant for recording some information - about the lifted theorem in a tactic. -*} -definition - "Quot_True x \ True" - -lemma - shows QT_all: "Quot_True (All P) \ Quot_True P" - and QT_ex: "Quot_True (Ex P) \ Quot_True P" - and QT_ex1: "Quot_True (Ex1 P) \ Quot_True P" - and QT_lam: "Quot_True (\x. P x) \ (\x. Quot_True (P x))" - and QT_ext: "(\x. Quot_True (a x) \ f x = g x) \ (Quot_True a \ f = g)" - by (simp_all add: Quot_True_def ext) - -lemma QT_imp: "Quot_True a \ Quot_True b" - by (simp add: Quot_True_def) - - -text {* Tactics for proving the lifted theorems *} -use "quotient_tacs.ML" - -section {* Methods / Interface *} - -method_setup lifting = - {* Attrib.thms >> (fn thms => fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.lift_tac ctxt thms))) *} - {* lifts theorems to quotient types *} - -method_setup lifting_setup = - {* Attrib.thm >> (fn thms => fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.procedure_tac ctxt thms))) *} - {* sets up the three goals for the quotient lifting procedure *} - -method_setup regularize = - {* Scan.succeed (fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.regularize_tac ctxt))) *} - {* proves the regularization goals from the quotient lifting procedure *} - -method_setup injection = - {* Scan.succeed (fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.all_injection_tac ctxt))) *} - {* proves the rep/abs injection goals from the quotient lifting procedure *} - -method_setup cleaning = - {* Scan.succeed (fn ctxt => SIMPLE_METHOD (HEADGOAL (Quotient_Tacs.clean_tac ctxt))) *} - {* proves the cleaning goals from the quotient lifting procedure *} - -attribute_setup quot_lifted = - {* Scan.succeed Quotient_Tacs.lifted_attrib *} - {* lifts theorems to quotient types *} - -no_notation - rel_conj (infixr "OOO" 75) and - fun_map (infixr "--->" 55) and - fun_rel (infixr "===>" 55) - -end - diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Quotient_List.thy --- a/Attic/Quot/Quotient_List.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,232 +0,0 @@ -(* Title: Quotient_List.thy - Author: Cezary Kaliszyk and Christian Urban -*) -theory Quotient_List -imports Quotient Quotient_Syntax List -begin - -section {* Quotient infrastructure for the list type. *} - -fun - list_rel -where - "list_rel R [] [] = True" -| "list_rel R (x#xs) [] = False" -| "list_rel R [] (x#xs) = False" -| "list_rel R (x#xs) (y#ys) = (R x y \ list_rel R xs ys)" - -declare [[map list = (map, list_rel)]] - -lemma split_list_all: - shows "(\x. P x) \ P [] \ (\x xs. P (x#xs))" - apply(auto) - apply(case_tac x) - apply(simp_all) - done - -lemma map_id[id_simps]: - shows "map id = id" - apply(simp add: expand_fun_eq) - apply(rule allI) - apply(induct_tac x) - apply(simp_all) - done - - -lemma list_rel_reflp: - shows "equivp R \ list_rel R xs xs" - apply(induct xs) - apply(simp_all add: equivp_reflp) - done - -lemma list_rel_symp: - assumes a: "equivp R" - shows "list_rel R xs ys \ list_rel R ys xs" - apply(induct xs ys rule: list_induct2') - apply(simp_all) - apply(rule equivp_symp[OF a]) - apply(simp) - done - -lemma list_rel_transp: - assumes a: "equivp R" - shows "list_rel R xs1 xs2 \ list_rel R xs2 xs3 \ list_rel R xs1 xs3" - apply(induct xs1 xs2 arbitrary: xs3 rule: list_induct2') - apply(simp_all) - apply(case_tac xs3) - apply(simp_all) - apply(rule equivp_transp[OF a]) - apply(auto) - done - -lemma list_equivp[quot_equiv]: - assumes a: "equivp R" - shows "equivp (list_rel R)" - apply(rule equivpI) - unfolding reflp_def symp_def transp_def - apply(subst split_list_all) - apply(simp add: equivp_reflp[OF a] list_rel_reflp[OF a]) - apply(blast intro: list_rel_symp[OF a]) - apply(blast intro: list_rel_transp[OF a]) - done - -lemma list_rel_rel: - assumes q: "Quotient R Abs Rep" - shows "list_rel R r s = (list_rel R r r \ list_rel R s s \ (map Abs r = map Abs s))" - apply(induct r s rule: list_induct2') - apply(simp_all) - using Quotient_rel[OF q] - apply(metis) - done - -lemma list_quotient[quot_thm]: - assumes q: "Quotient R Abs Rep" - shows "Quotient (list_rel R) (map Abs) (map Rep)" - unfolding Quotient_def - apply(subst split_list_all) - apply(simp add: Quotient_abs_rep[OF q] abs_o_rep[OF q] map_id) - apply(rule conjI) - apply(rule allI) - apply(induct_tac a) - apply(simp) - apply(simp) - apply(simp add: Quotient_rep_reflp[OF q]) - apply(rule allI)+ - apply(rule list_rel_rel[OF q]) - done - - -lemma cons_prs_aux: - assumes q: "Quotient R Abs Rep" - shows "(map Abs) ((Rep h) # (map Rep t)) = h # t" - by (induct t) (simp_all add: Quotient_abs_rep[OF q]) - -lemma cons_prs[quot_preserve]: - assumes q: "Quotient R Abs Rep" - shows "(Rep ---> (map Rep) ---> (map Abs)) (op #) = (op #)" - by (simp only: expand_fun_eq fun_map_def cons_prs_aux[OF q]) - (simp) - -lemma cons_rsp[quot_respect]: - assumes q: "Quotient R Abs Rep" - shows "(R ===> list_rel R ===> list_rel R) (op #) (op #)" - by (auto) - -lemma nil_prs[quot_preserve]: - assumes q: "Quotient R Abs Rep" - shows "map Abs [] = []" - by simp - -lemma nil_rsp[quot_respect]: - assumes q: "Quotient R Abs Rep" - shows "list_rel R [] []" - by simp - -lemma map_prs_aux: - assumes a: "Quotient R1 abs1 rep1" - and b: "Quotient R2 abs2 rep2" - shows "(map abs2) (map ((abs1 ---> rep2) f) (map rep1 l)) = map f l" - by (induct l) - (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b]) - - -lemma map_prs[quot_preserve]: - assumes a: "Quotient R1 abs1 rep1" - and b: "Quotient R2 abs2 rep2" - shows "((abs1 ---> rep2) ---> (map rep1) ---> (map abs2)) map = map" - by (simp only: expand_fun_eq fun_map_def map_prs_aux[OF a b]) - (simp) - - -lemma map_rsp[quot_respect]: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "((R1 ===> R2) ===> (list_rel R1) ===> list_rel R2) map map" - apply(simp) - apply(rule allI)+ - apply(rule impI) - apply(rule allI)+ - apply (induct_tac xa ya rule: list_induct2') - apply simp_all - done - -lemma foldr_prs_aux: - assumes a: "Quotient R1 abs1 rep1" - and b: "Quotient R2 abs2 rep2" - shows "abs2 (foldr ((abs1 ---> abs2 ---> rep2) f) (map rep1 l) (rep2 e)) = foldr f l e" - by (induct l) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b]) - -lemma foldr_prs[quot_preserve]: - assumes a: "Quotient R1 abs1 rep1" - and b: "Quotient R2 abs2 rep2" - shows "((abs1 ---> abs2 ---> rep2) ---> (map rep1) ---> rep2 ---> abs2) foldr = foldr" - by (simp only: expand_fun_eq fun_map_def foldr_prs_aux[OF a b]) - (simp) - -lemma foldl_prs_aux: - assumes a: "Quotient R1 abs1 rep1" - and b: "Quotient R2 abs2 rep2" - shows "abs1 (foldl ((abs1 ---> abs2 ---> rep1) f) (rep1 e) (map rep2 l)) = foldl f e l" - by (induct l arbitrary:e) (simp_all add: Quotient_abs_rep[OF a] Quotient_abs_rep[OF b]) - - -lemma foldl_prs[quot_preserve]: - assumes a: "Quotient R1 abs1 rep1" - and b: "Quotient R2 abs2 rep2" - shows "((abs1 ---> abs2 ---> rep1) ---> rep1 ---> (map rep2) ---> abs1) foldl = foldl" - by (simp only: expand_fun_eq fun_map_def foldl_prs_aux[OF a b]) - (simp) - -lemma list_rel_empty: - shows "list_rel R [] b \ length b = 0" - by (induct b) (simp_all) - -lemma list_rel_len: - shows "list_rel R a b \ length a = length b" - apply (induct a arbitrary: b) - apply (simp add: list_rel_empty) - apply (case_tac b) - apply simp_all - done - -(* induct_tac doesn't accept 'arbitrary', so we manually 'spec' *) -lemma foldl_rsp[quot_respect]: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "((R1 ===> R2 ===> R1) ===> R1 ===> list_rel R2 ===> R1) foldl foldl" - apply(auto) - apply (subgoal_tac "R1 xa ya \ list_rel R2 xb yb \ R1 (foldl x xa xb) (foldl y ya yb)") - apply simp - apply (rule_tac x="xa" in spec) - apply (rule_tac x="ya" in spec) - apply (rule_tac xs="xb" and ys="yb" in list_induct2) - apply (rule list_rel_len) - apply (simp_all) - done - -lemma foldr_rsp[quot_respect]: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "((R1 ===> R2 ===> R2) ===> list_rel R1 ===> R2 ===> R2) foldr foldr" - apply auto - apply(subgoal_tac "R2 xb yb \ list_rel R1 xa ya \ R2 (foldr x xa xb) (foldr y ya yb)") - apply simp - apply (rule_tac xs="xa" and ys="ya" in list_induct2) - apply (rule list_rel_len) - apply (simp_all) - done - -lemma list_rel_eq[id_simps]: - shows "(list_rel (op =)) = (op =)" - unfolding expand_fun_eq - apply(rule allI)+ - apply(induct_tac x xa rule: list_induct2') - apply(simp_all) - done - -lemma list_rel_refl: - assumes a: "\x y. R x y = (R x = R y)" - shows "list_rel R x x" - by (induct x) (auto simp add: a) - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Quotient_Option.thy --- a/Attic/Quot/Quotient_Option.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,80 +0,0 @@ -(* Title: Quotient_Option.thy - Author: Cezary Kaliszyk and Christian Urban -*) -theory Quotient_Option -imports Quotient Quotient_Syntax -begin - -section {* Quotient infrastructure for the option type. *} - -fun - option_rel -where - "option_rel R None None = True" -| "option_rel R (Some x) None = False" -| "option_rel R None (Some x) = False" -| "option_rel R (Some x) (Some y) = R x y" - -declare [[map option = (Option.map, option_rel)]] - -text {* should probably be in Option.thy *} -lemma split_option_all: - shows "(\x. P x) \ P None \ (\a. P (Some a))" - apply(auto) - apply(case_tac x) - apply(simp_all) - done - -lemma option_quotient[quot_thm]: - assumes q: "Quotient R Abs Rep" - shows "Quotient (option_rel R) (Option.map Abs) (Option.map Rep)" - unfolding Quotient_def - apply(simp add: split_option_all) - apply(simp add: Quotient_abs_rep[OF q] Quotient_rel_rep[OF q]) - using q - unfolding Quotient_def - apply(blast) - done - -lemma option_equivp[quot_equiv]: - assumes a: "equivp R" - shows "equivp (option_rel R)" - apply(rule equivpI) - unfolding reflp_def symp_def transp_def - apply(simp_all add: split_option_all) - apply(blast intro: equivp_reflp[OF a]) - apply(blast intro: equivp_symp[OF a]) - apply(blast intro: equivp_transp[OF a]) - done - -lemma option_None_rsp[quot_respect]: - assumes q: "Quotient R Abs Rep" - shows "option_rel R None None" - by simp - -lemma option_Some_rsp[quot_respect]: - assumes q: "Quotient R Abs Rep" - shows "(R ===> option_rel R) Some Some" - by simp - -lemma option_None_prs[quot_preserve]: - assumes q: "Quotient R Abs Rep" - shows "Option.map Abs None = None" - by simp - -lemma option_Some_prs[quot_preserve]: - assumes q: "Quotient R Abs Rep" - shows "(Rep ---> Option.map Abs) Some = Some" - apply(simp add: expand_fun_eq) - apply(simp add: Quotient_abs_rep[OF q]) - done - -lemma option_map_id[id_simps]: - shows "Option.map id = id" - by (simp add: expand_fun_eq split_option_all) - -lemma option_rel_eq[id_simps]: - shows "option_rel (op =) = (op =)" - by (simp add: expand_fun_eq split_option_all) - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Quotient_Product.thy --- a/Attic/Quot/Quotient_Product.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,104 +0,0 @@ -(* Title: Quotient_Product.thy - Author: Cezary Kaliszyk and Christian Urban -*) -theory Quotient_Product -imports Quotient Quotient_Syntax -begin - -section {* Quotient infrastructure for the product type. *} - -fun - prod_rel -where - "prod_rel R1 R2 = (\(a, b) (c, d). R1 a c \ R2 b d)" - -declare [[map * = (prod_fun, prod_rel)]] - - -lemma prod_equivp[quot_equiv]: - assumes a: "equivp R1" - assumes b: "equivp R2" - shows "equivp (prod_rel R1 R2)" - apply(rule equivpI) - unfolding reflp_def symp_def transp_def - apply(simp_all add: split_paired_all) - apply(blast intro: equivp_reflp[OF a] equivp_reflp[OF b]) - apply(blast intro: equivp_symp[OF a] equivp_symp[OF b]) - apply(blast intro: equivp_transp[OF a] equivp_transp[OF b]) - done - -lemma prod_quotient[quot_thm]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "Quotient (prod_rel R1 R2) (prod_fun Abs1 Abs2) (prod_fun Rep1 Rep2)" - unfolding Quotient_def - apply(simp add: split_paired_all) - apply(simp add: Quotient_abs_rep[OF q1] Quotient_rel_rep[OF q1]) - apply(simp add: Quotient_abs_rep[OF q2] Quotient_rel_rep[OF q2]) - using q1 q2 - unfolding Quotient_def - apply(blast) - done - -lemma Pair_rsp[quot_respect]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(R1 ===> R2 ===> prod_rel R1 R2) Pair Pair" - by simp - -lemma Pair_prs[quot_preserve]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(Rep1 ---> Rep2 ---> (prod_fun Abs1 Abs2)) Pair = Pair" - apply(simp add: expand_fun_eq) - apply(simp add: Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]) - done - -lemma fst_rsp[quot_respect]: - assumes "Quotient R1 Abs1 Rep1" - assumes "Quotient R2 Abs2 Rep2" - shows "(prod_rel R1 R2 ===> R1) fst fst" - by simp - -lemma fst_prs[quot_preserve]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(prod_fun Rep1 Rep2 ---> Abs1) fst = fst" - apply(simp add: expand_fun_eq) - apply(simp add: Quotient_abs_rep[OF q1]) - done - -lemma snd_rsp[quot_respect]: - assumes "Quotient R1 Abs1 Rep1" - assumes "Quotient R2 Abs2 Rep2" - shows "(prod_rel R1 R2 ===> R2) snd snd" - by simp - -lemma snd_prs[quot_preserve]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(prod_fun Rep1 Rep2 ---> Abs2) snd = snd" - apply(simp add: expand_fun_eq) - apply(simp add: Quotient_abs_rep[OF q2]) - done - -lemma split_rsp[quot_respect]: - shows "((R1 ===> R2 ===> (op =)) ===> (prod_rel R1 R2) ===> (op =)) split split" - by auto - -lemma split_prs[quot_preserve]: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "(((Abs1 ---> Abs2 ---> id) ---> prod_fun Rep1 Rep2 ---> id) split) = split" - by (simp add: expand_fun_eq Quotient_abs_rep[OF q1] Quotient_abs_rep[OF q2]) - -lemma prod_fun_id[id_simps]: - shows "prod_fun id id = id" - by (simp add: prod_fun_def) - -lemma prod_rel_eq[id_simps]: - shows "prod_rel (op =) (op =) = (op =)" - by (simp add: expand_fun_eq) - - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Quotient_Sum.thy --- a/Attic/Quot/Quotient_Sum.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,96 +0,0 @@ -(* Title: Quotient_Sum.thy - Author: Cezary Kaliszyk and Christian Urban -*) -theory Quotient_Sum -imports Quotient Quotient_Syntax -begin - -section {* Quotient infrastructure for the sum type. *} - -fun - sum_rel -where - "sum_rel R1 R2 (Inl a1) (Inl b1) = R1 a1 b1" -| "sum_rel R1 R2 (Inl a1) (Inr b2) = False" -| "sum_rel R1 R2 (Inr a2) (Inl b1) = False" -| "sum_rel R1 R2 (Inr a2) (Inr b2) = R2 a2 b2" - -fun - sum_map -where - "sum_map f1 f2 (Inl a) = Inl (f1 a)" -| "sum_map f1 f2 (Inr a) = Inr (f2 a)" - -declare [[map "+" = (sum_map, sum_rel)]] - - -text {* should probably be in Sum_Type.thy *} -lemma split_sum_all: - shows "(\x. P x) \ (\x. P (Inl x)) \ (\x. P (Inr x))" - apply(auto) - apply(case_tac x) - apply(simp_all) - done - -lemma sum_equivp[quot_equiv]: - assumes a: "equivp R1" - assumes b: "equivp R2" - shows "equivp (sum_rel R1 R2)" - apply(rule equivpI) - unfolding reflp_def symp_def transp_def - apply(simp_all add: split_sum_all) - apply(blast intro: equivp_reflp[OF a] equivp_reflp[OF b]) - apply(blast intro: equivp_symp[OF a] equivp_symp[OF b]) - apply(blast intro: equivp_transp[OF a] equivp_transp[OF b]) - done - -lemma sum_quotient[quot_thm]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "Quotient (sum_rel R1 R2) (sum_map Abs1 Abs2) (sum_map Rep1 Rep2)" - unfolding Quotient_def - apply(simp add: split_sum_all) - apply(simp_all add: Quotient_abs_rep[OF q1] Quotient_rel_rep[OF q1]) - apply(simp_all add: Quotient_abs_rep[OF q2] Quotient_rel_rep[OF q2]) - using q1 q2 - unfolding Quotient_def - apply(blast)+ - done - -lemma sum_Inl_rsp[quot_respect]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(R1 ===> sum_rel R1 R2) Inl Inl" - by simp - -lemma sum_Inr_rsp[quot_respect]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(R2 ===> sum_rel R1 R2) Inr Inr" - by simp - -lemma sum_Inl_prs[quot_preserve]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(Rep1 ---> sum_map Abs1 Abs2) Inl = Inl" - apply(simp add: expand_fun_eq) - apply(simp add: Quotient_abs_rep[OF q1]) - done - -lemma sum_Inr_prs[quot_preserve]: - assumes q1: "Quotient R1 Abs1 Rep1" - assumes q2: "Quotient R2 Abs2 Rep2" - shows "(Rep2 ---> sum_map Abs1 Abs2) Inr = Inr" - apply(simp add: expand_fun_eq) - apply(simp add: Quotient_abs_rep[OF q2]) - done - -lemma sum_map_id[id_simps]: - shows "sum_map id id = id" - by (simp add: expand_fun_eq split_sum_all) - -lemma sum_rel_eq[id_simps]: - shows "sum_rel (op =) (op =) = (op =)" - by (simp add: expand_fun_eq split_sum_all) - -end diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/Quotient_Syntax.thy --- a/Attic/Quot/Quotient_Syntax.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,18 +0,0 @@ -(* Title: Quotient_Syntax.thy - Author: Cezary Kaliszyk and Christian Urban -*) - -header {* Pretty syntax for Quotient operations *} - -(*<*) -theory Quotient_Syntax -imports Quotient -begin - -notation - rel_conj (infixr "OOO" 75) and - fun_map (infixr "--->" 55) and - fun_rel (infixr "===>" 55) - -end -(*>*) diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/ROOT.ML --- a/Attic/Quot/ROOT.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,15 +0,0 @@ -quick_and_dirty := true; - -no_document use_thys - ["Quotient", - "Examples/AbsRepTest", - "Examples/FSet", - "Examples/FSet2", - "Examples/FSet3", - "Examples/IntEx", - "Examples/IntEx2", - "Examples/LFex", - "Examples/LamEx", - "Examples/LarryDatatype", - "Examples/LarryInt", - "Examples/Terms"]; diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/quotient_def.ML --- a/Attic/Quot/quotient_def.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,109 +0,0 @@ -(* Title: HOL/Tools/Quotient/quotient_def.thy - Author: Cezary Kaliszyk and Christian Urban - -Definitions for constants on quotient types. -*) - -signature QUOTIENT_DEF = -sig - val quotient_def: (binding option * mixfix) * (Attrib.binding * (term * term)) -> - local_theory -> (term * thm) * local_theory - - val quotdef_cmd: (binding option * mixfix) * (Attrib.binding * (string * string)) -> - local_theory -> (term * thm) * local_theory - - val quotient_lift_const: string * term -> local_theory -> (term * thm) * local_theory -end; - -structure Quotient_Def: QUOTIENT_DEF = -struct - -open Quotient_Info; -open Quotient_Term; - -(** Interface and Syntax Setup **) - -(* The ML-interface for a quotient definition takes - as argument: - - - an optional binding and mixfix annotation - - attributes - - the new constant as term - - the rhs of the definition as term - - It returns the defined constant and its definition - theorem; stores the data in the qconsts data slot. - - Restriction: At the moment the right-hand side of the - definition must be a constant. Similarly the left-hand - side must be a constant. -*) -fun error_msg bind str = -let - val name = Binding.name_of bind - val pos = Position.str_of (Binding.pos_of bind) -in - error ("Head of quotient_definition " ^ - (quote str) ^ " differs from declaration " ^ name ^ pos) -end - -fun quotient_def ((optbind, mx), (attr, (lhs, rhs))) lthy = -let - val (lhs_str, lhs_ty) = dest_Free lhs handle TERM _ => error "Constant already defined." - val _ = if null (strip_abs_vars rhs) then () else error "The definiens cannot be an abstraction" - - fun sanity_test NONE _ = true - | sanity_test (SOME bind) str = - if Name.of_binding bind = str then true - else error_msg bind str - - val _ = sanity_test optbind lhs_str - - val qconst_bname = Binding.name lhs_str - val absrep_trm = absrep_fun AbsF lthy (fastype_of rhs, lhs_ty) $ rhs - val prop = Logic.mk_equals (lhs, Syntax.check_term lthy absrep_trm) - val (_, prop') = Local_Defs.cert_def lthy prop - val (_, newrhs) = Primitive_Defs.abs_def prop' - - val ((trm, (_ , thm)), lthy') = Local_Theory.define ((qconst_bname, mx), (attr, newrhs)) lthy - - (* data storage *) - fun qcinfo phi = transform_qconsts phi {qconst = trm, rconst = rhs, def = thm} - fun trans_name phi = (fst o dest_Const o #qconst) (qcinfo phi) - val lthy'' = Local_Theory.declaration true - (fn phi => qconsts_update_gen (trans_name phi) (qcinfo phi)) lthy' -in - ((trm, thm), lthy'') -end - -fun quotdef_cmd (decl, (attr, (lhs_str, rhs_str))) lthy = -let - val lhs = Syntax.read_term lthy lhs_str - val rhs = Syntax.read_term lthy rhs_str - val lthy' = Variable.declare_term lhs lthy - val lthy'' = Variable.declare_term rhs lthy' -in - quotient_def (decl, (attr, (lhs, rhs))) lthy'' -end - -fun quotient_lift_const (b, t) ctxt = - quotient_def ((NONE, NoSyn), (Attrib.empty_binding, - (Quotient_Term.quotient_lift_const (b, t) ctxt, t))) ctxt - -local - structure P = OuterParse; -in - -val quotdef_decl = (P.binding >> SOME) -- P.opt_mixfix' --| P.$$$ "where" - -val quotdef_parser = - Scan.optional quotdef_decl (NONE, NoSyn) -- - P.!!! (SpecParse.opt_thm_name ":" -- (P.term --| P.$$$ "is" -- P.term)) -end - -val _ = - OuterSyntax.local_theory "quotient_definition" - "definition for constants over the quotient type" - OuterKeyword.thy_decl (quotdef_parser >> (snd oo quotdef_cmd)) - -end; (* structure *) diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/quotient_info.ML --- a/Attic/Quot/quotient_info.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,290 +0,0 @@ -(* Title: HOL/Tools/Quotient/quotient_info.thy - Author: Cezary Kaliszyk and Christian Urban - -Data slots for the quotient package. -*) - -signature QUOTIENT_INFO = -sig - exception NotFound - - type maps_info = {mapfun: string, relmap: string} - val maps_defined: theory -> string -> bool - val maps_lookup: theory -> string -> maps_info (* raises NotFound *) - val maps_update_thy: string -> maps_info -> theory -> theory - val maps_update: string -> maps_info -> Proof.context -> Proof.context - val print_mapsinfo: Proof.context -> unit - - type quotdata_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm} - val transform_quotdata: morphism -> quotdata_info -> quotdata_info - val quotdata_lookup_raw: theory -> string -> quotdata_info option - val quotdata_lookup: theory -> string -> quotdata_info (* raises NotFound *) - val quotdata_update_thy: string -> quotdata_info -> theory -> theory - val quotdata_update_gen: string -> quotdata_info -> Context.generic -> Context.generic - val quotdata_dest: Proof.context -> quotdata_info list - val print_quotinfo: Proof.context -> unit - - type qconsts_info = {qconst: term, rconst: term, def: thm} - val transform_qconsts: morphism -> qconsts_info -> qconsts_info - val qconsts_lookup: theory -> term -> qconsts_info (* raises NotFound *) - val qconsts_update_thy: string -> qconsts_info -> theory -> theory - val qconsts_update_gen: string -> qconsts_info -> Context.generic -> Context.generic - val qconsts_dest: Proof.context -> qconsts_info list - val print_qconstinfo: Proof.context -> unit - - val equiv_rules_get: Proof.context -> thm list - val equiv_rules_add: attribute - val rsp_rules_get: Proof.context -> thm list - val rsp_rules_add: attribute - val prs_rules_get: Proof.context -> thm list - val prs_rules_add: attribute - val id_simps_get: Proof.context -> thm list - val quotient_rules_get: Proof.context -> thm list - val quotient_rules_add: attribute -end; - - -structure Quotient_Info: QUOTIENT_INFO = -struct - -exception NotFound - - -(** data containers **) - -(* info about map- and rel-functions for a type *) -type maps_info = {mapfun: string, relmap: string} - -structure MapsData = Theory_Data - (type T = maps_info Symtab.table - val empty = Symtab.empty - val extend = I - fun merge data = Symtab.merge (K true) data) - -fun maps_defined thy s = - Symtab.defined (MapsData.get thy) s - -fun maps_lookup thy s = - case (Symtab.lookup (MapsData.get thy) s) of - SOME map_fun => map_fun - | NONE => raise NotFound - -fun maps_update_thy k minfo = MapsData.map (Symtab.update (k, minfo)) -fun maps_update k minfo = ProofContext.theory (maps_update_thy k minfo) - -fun maps_attribute_aux s minfo = Thm.declaration_attribute - (fn _ => Context.mapping (maps_update_thy s minfo) (maps_update s minfo)) - -(* attribute to be used in declare statements *) -fun maps_attribute (ctxt, (tystr, (mapstr, relstr))) = -let - val thy = ProofContext.theory_of ctxt - val tyname = Sign.intern_type thy tystr - val mapname = Sign.intern_const thy mapstr - val relname = Sign.intern_const thy relstr - - fun sanity_check s = (Const (s, dummyT) |> Syntax.check_term ctxt; ()) - val _ = List.app sanity_check [mapname, relname] -in - maps_attribute_aux tyname {mapfun = mapname, relmap = relname} -end - -val maps_attr_parser = - Args.context -- Scan.lift - ((Args.name --| OuterParse.$$$ "=") -- - (OuterParse.$$$ "(" |-- Args.name --| OuterParse.$$$ "," -- - Args.name --| OuterParse.$$$ ")")) - -val _ = Context.>> (Context.map_theory - (Attrib.setup @{binding "map"} (maps_attr_parser >> maps_attribute) - "declaration of map information")) - -fun print_mapsinfo ctxt = -let - fun prt_map (ty_name, {mapfun, relmap}) = - Pretty.block (Library.separate (Pretty.brk 2) - (map Pretty.str - ["type:", ty_name, - "map:", mapfun, - "relation map:", relmap])) -in - MapsData.get (ProofContext.theory_of ctxt) - |> Symtab.dest - |> map (prt_map) - |> Pretty.big_list "maps for type constructors:" - |> Pretty.writeln -end - - -(* info about quotient types *) -type quotdata_info = {qtyp: typ, rtyp: typ, equiv_rel: term, equiv_thm: thm} - -structure QuotData = Theory_Data - (type T = quotdata_info Symtab.table - val empty = Symtab.empty - val extend = I - fun merge data = Symtab.merge (K true) data) - -fun transform_quotdata phi {qtyp, rtyp, equiv_rel, equiv_thm} = - {qtyp = Morphism.typ phi qtyp, - rtyp = Morphism.typ phi rtyp, - equiv_rel = Morphism.term phi equiv_rel, - equiv_thm = Morphism.thm phi equiv_thm} - -fun quotdata_lookup_raw thy str = Symtab.lookup (QuotData.get thy) str - -fun quotdata_lookup thy str = - case Symtab.lookup (QuotData.get thy) str of - SOME qinfo => qinfo - | NONE => raise NotFound - -fun quotdata_update_thy str qinfo = QuotData.map (Symtab.update (str, qinfo)) -fun quotdata_update_gen str qinfo = Context.mapping (quotdata_update_thy str qinfo) I - -fun quotdata_dest lthy = - map snd (Symtab.dest (QuotData.get (ProofContext.theory_of lthy))) - -fun print_quotinfo ctxt = -let - fun prt_quot {qtyp, rtyp, equiv_rel, equiv_thm} = - Pretty.block (Library.separate (Pretty.brk 2) - [Pretty.str "quotient type:", - Syntax.pretty_typ ctxt qtyp, - Pretty.str "raw type:", - Syntax.pretty_typ ctxt rtyp, - Pretty.str "relation:", - Syntax.pretty_term ctxt equiv_rel, - Pretty.str "equiv. thm:", - Syntax.pretty_term ctxt (prop_of equiv_thm)]) -in - QuotData.get (ProofContext.theory_of ctxt) - |> Symtab.dest - |> map (prt_quot o snd) - |> Pretty.big_list "quotients:" - |> Pretty.writeln -end - - -(* info about quotient constants *) -type qconsts_info = {qconst: term, rconst: term, def: thm} - -fun qconsts_info_eq (x : qconsts_info, y : qconsts_info) = #qconst x = #qconst y - -(* We need to be able to lookup instances of lifted constants, - for example given "nat fset" we need to find "'a fset"; - but overloaded constants share the same name *) -structure QConstsData = Theory_Data - (type T = (qconsts_info list) Symtab.table - val empty = Symtab.empty - val extend = I - val merge = Symtab.merge_list qconsts_info_eq) - -fun transform_qconsts phi {qconst, rconst, def} = - {qconst = Morphism.term phi qconst, - rconst = Morphism.term phi rconst, - def = Morphism.thm phi def} - -fun qconsts_update_thy name qcinfo = QConstsData.map (Symtab.cons_list (name, qcinfo)) -fun qconsts_update_gen name qcinfo = Context.mapping (qconsts_update_thy name qcinfo) I - -fun qconsts_dest lthy = - flat (map snd (Symtab.dest (QConstsData.get (ProofContext.theory_of lthy)))) - -fun qconsts_lookup thy t = - let - val (name, qty) = dest_Const t - fun matches (x: qconsts_info) = - let - val (name', qty') = dest_Const (#qconst x); - in - name = name' andalso Sign.typ_instance thy (qty, qty') - end - in - case Symtab.lookup (QConstsData.get thy) name of - NONE => raise NotFound - | SOME l => - (case (find_first matches l) of - SOME x => x - | NONE => raise NotFound) - end - -fun print_qconstinfo ctxt = -let - fun prt_qconst {qconst, rconst, def} = - Pretty.block (separate (Pretty.brk 1) - [Syntax.pretty_term ctxt qconst, - Pretty.str ":=", - Syntax.pretty_term ctxt rconst, - Pretty.str "as", - Syntax.pretty_term ctxt (prop_of def)]) -in - QConstsData.get (ProofContext.theory_of ctxt) - |> Symtab.dest - |> map snd - |> flat - |> map prt_qconst - |> Pretty.big_list "quotient constants:" - |> Pretty.writeln -end - -(* equivalence relation theorems *) -structure EquivRules = Named_Thms - (val name = "quot_equiv" - val description = "Equivalence relation theorems.") - -val equiv_rules_get = EquivRules.get -val equiv_rules_add = EquivRules.add - -(* respectfulness theorems *) -structure RspRules = Named_Thms - (val name = "quot_respect" - val description = "Respectfulness theorems.") - -val rsp_rules_get = RspRules.get -val rsp_rules_add = RspRules.add - -(* preservation theorems *) -structure PrsRules = Named_Thms - (val name = "quot_preserve" - val description = "Preservation theorems.") - -val prs_rules_get = PrsRules.get -val prs_rules_add = PrsRules.add - -(* id simplification theorems *) -structure IdSimps = Named_Thms - (val name = "id_simps" - val description = "Identity simp rules for maps.") - -val id_simps_get = IdSimps.get - -(* quotient theorems *) -structure QuotientRules = Named_Thms - (val name = "quot_thm" - val description = "Quotient theorems.") - -val quotient_rules_get = QuotientRules.get -val quotient_rules_add = QuotientRules.add - -(* setup of the theorem lists *) - -val _ = Context.>> (Context.map_theory - (EquivRules.setup #> - RspRules.setup #> - PrsRules.setup #> - IdSimps.setup #> - QuotientRules.setup)) - -(* setup of the printing commands *) - -fun improper_command (pp_fn, cmd_name, descr_str) = - OuterSyntax.improper_command cmd_name descr_str - OuterKeyword.diag (Scan.succeed (Toplevel.keep (pp_fn o Toplevel.context_of))) - -val _ = map improper_command - [(print_mapsinfo, "print_quotmaps", "prints out all map functions"), - (print_quotinfo, "print_quotients", "prints out all quotients"), - (print_qconstinfo, "print_quotconsts", "prints out all quotient constants")] - - -end; (* structure *) diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/quotient_tacs.ML --- a/Attic/Quot/quotient_tacs.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,665 +0,0 @@ -(* Title: HOL/Tools/Quotient/quotient_tacs.thy - Author: Cezary Kaliszyk and Christian Urban - -Tactics for solving goal arising from lifting theorems to quotient -types. -*) - -signature QUOTIENT_TACS = -sig - val regularize_tac: Proof.context -> int -> tactic - val injection_tac: Proof.context -> int -> tactic - val all_injection_tac: Proof.context -> int -> tactic - val clean_tac: Proof.context -> int -> tactic - val procedure_tac: Proof.context -> thm -> int -> tactic - val lift_tac: Proof.context -> thm list -> int -> tactic - val quotient_tac: Proof.context -> int -> tactic - val quot_true_tac: Proof.context -> (term -> term) -> int -> tactic - val lifted_attrib: attribute -end; - -structure Quotient_Tacs: QUOTIENT_TACS = -struct - -open Quotient_Info; -open Quotient_Term; - - -(** various helper fuctions **) - -(* Since HOL_basic_ss is too "big" for us, we *) -(* need to set up our own minimal simpset. *) -fun mk_minimal_ss ctxt = - Simplifier.context ctxt empty_ss - setsubgoaler asm_simp_tac - setmksimps (mksimps []) - -(* composition of two theorems, used in maps *) -fun OF1 thm1 thm2 = thm2 RS thm1 - -(* prints a warning, if the subgoal is not solved *) -fun WARN (tac, msg) i st = - case Seq.pull (SOLVED' tac i st) of - NONE => (warning msg; Seq.single st) - | seqcell => Seq.make (fn () => seqcell) - -fun RANGE_WARN tacs = RANGE (map WARN tacs) - -fun atomize_thm thm = -let - val thm' = Thm.freezeT (forall_intr_vars thm) (* FIXME/TODO: is this proper Isar-technology? *) - val thm'' = Object_Logic.atomize (cprop_of thm') -in - @{thm equal_elim_rule1} OF [thm'', thm'] -end - - - -(*** Regularize Tactic ***) - -(** solvers for equivp and quotient assumptions **) - -fun equiv_tac ctxt = - REPEAT_ALL_NEW (resolve_tac (equiv_rules_get ctxt)) - -fun equiv_solver_tac ss = equiv_tac (Simplifier.the_context ss) -val equiv_solver = Simplifier.mk_solver' "Equivalence goal solver" equiv_solver_tac - -fun quotient_tac ctxt = - (REPEAT_ALL_NEW (FIRST' - [rtac @{thm identity_quotient}, - resolve_tac (quotient_rules_get ctxt)])) - -fun quotient_solver_tac ss = quotient_tac (Simplifier.the_context ss) -val quotient_solver = - Simplifier.mk_solver' "Quotient goal solver" quotient_solver_tac - -fun solve_quotient_assm ctxt thm = - case Seq.pull (quotient_tac ctxt 1 thm) of - SOME (t, _) => t - | _ => error "Solve_quotient_assm failed. Possibly a quotient theorem is missing." - - -fun prep_trm thy (x, (T, t)) = - (cterm_of thy (Var (x, T)), cterm_of thy t) - -fun prep_ty thy (x, (S, ty)) = - (ctyp_of thy (TVar (x, S)), ctyp_of thy ty) - -fun get_match_inst thy pat trm = -let - val univ = Unify.matchers thy [(pat, trm)] - val SOME (env, _) = Seq.pull univ (* raises Bind, if no unifier *) (* FIXME fragile *) - val tenv = Vartab.dest (Envir.term_env env) - val tyenv = Vartab.dest (Envir.type_env env) -in - (map (prep_ty thy) tyenv, map (prep_trm thy) tenv) -end - -(* Calculates the instantiations for the lemmas: - - ball_reg_eqv_range and bex_reg_eqv_range - - Since the left-hand-side contains a non-pattern '?P (f ?x)' - we rely on unification/instantiation to check whether the - theorem applies and return NONE if it doesn't. -*) -fun calculate_inst ctxt ball_bex_thm redex R1 R2 = -let - val thy = ProofContext.theory_of ctxt - fun get_lhs thm = fst (Logic.dest_equals (Thm.concl_of thm)) - val ty_inst = map (SOME o ctyp_of thy) [domain_type (fastype_of R2)] - val trm_inst = map (SOME o cterm_of thy) [R2, R1] -in - case try (Drule.instantiate' ty_inst trm_inst) ball_bex_thm of - NONE => NONE - | SOME thm' => - (case try (get_match_inst thy (get_lhs thm')) redex of - NONE => NONE - | SOME inst2 => try (Drule.instantiate inst2) thm') -end - -fun ball_bex_range_simproc ss redex = -let - val ctxt = Simplifier.the_context ss -in - case redex of - (Const (@{const_name "Ball"}, _) $ (Const (@{const_name "Respects"}, _) $ - (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) => - calculate_inst ctxt @{thm ball_reg_eqv_range[THEN eq_reflection]} redex R1 R2 - - | (Const (@{const_name "Bex"}, _) $ (Const (@{const_name "Respects"}, _) $ - (Const (@{const_name "fun_rel"}, _) $ R1 $ R2)) $ _) => - calculate_inst ctxt @{thm bex_reg_eqv_range[THEN eq_reflection]} redex R1 R2 - - | _ => NONE -end - -(* Regularize works as follows: - - 0. preliminary simplification step according to - ball_reg_eqv bex_reg_eqv babs_reg_eqv ball_reg_eqv_range bex_reg_eqv_range - - 1. eliminating simple Ball/Bex instances (ball_reg_right bex_reg_left) - - 2. monos - - 3. commutation rules for ball and bex (ball_all_comm bex_ex_comm) - - 4. then rel-equalities, which need to be instantiated with 'eq_imp_rel' - to avoid loops - - 5. then simplification like 0 - - finally jump back to 1 -*) - -fun regularize_tac ctxt = -let - val thy = ProofContext.theory_of ctxt - val ball_pat = @{term "Ball (Respects (R1 ===> R2)) P"} - val bex_pat = @{term "Bex (Respects (R1 ===> R2)) P"} - val simproc = Simplifier.simproc_i thy "" [ball_pat, bex_pat] (K (ball_bex_range_simproc)) - val simpset = (mk_minimal_ss ctxt) - addsimps @{thms ball_reg_eqv bex_reg_eqv babs_reg_eqv babs_simp} - addsimprocs [simproc] - addSolver equiv_solver addSolver quotient_solver - val eq_imp_rel = @{lemma "equivp R ==> a = b --> R a b" by (simp add: equivp_reflp)} - val eq_eqvs = map (OF1 eq_imp_rel) (equiv_rules_get ctxt) -in - simp_tac simpset THEN' - REPEAT_ALL_NEW (CHANGED o FIRST' - [resolve_tac @{thms ball_reg_right bex_reg_left bex1_bexeq_reg}, - resolve_tac (Inductive.get_monos ctxt), - resolve_tac @{thms ball_all_comm bex_ex_comm}, - resolve_tac eq_eqvs, - simp_tac simpset]) -end - - - -(*** Injection Tactic ***) - -(* Looks for Quot_True assumptions, and in case its parameter - is an application, it returns the function and the argument. -*) -fun find_qt_asm asms = -let - fun find_fun trm = - case trm of - (Const(@{const_name Trueprop}, _) $ (Const (@{const_name Quot_True}, _) $ _)) => true - | _ => false -in - case find_first find_fun asms of - SOME (_ $ (_ $ (f $ a))) => SOME (f, a) - | _ => NONE -end - -fun quot_true_simple_conv ctxt fnctn ctrm = - case (term_of ctrm) of - (Const (@{const_name Quot_True}, _) $ x) => - let - val fx = fnctn x; - val thy = ProofContext.theory_of ctxt; - val cx = cterm_of thy x; - val cfx = cterm_of thy fx; - val cxt = ctyp_of thy (fastype_of x); - val cfxt = ctyp_of thy (fastype_of fx); - val thm = Drule.instantiate' [SOME cxt, SOME cfxt] [SOME cx, SOME cfx] @{thm QT_imp} - in - Conv.rewr_conv thm ctrm - end - -fun quot_true_conv ctxt fnctn ctrm = - case (term_of ctrm) of - (Const (@{const_name Quot_True}, _) $ _) => - quot_true_simple_conv ctxt fnctn ctrm - | _ $ _ => Conv.comb_conv (quot_true_conv ctxt fnctn) ctrm - | Abs _ => Conv.abs_conv (fn (_, ctxt) => quot_true_conv ctxt fnctn) ctxt ctrm - | _ => Conv.all_conv ctrm - -fun quot_true_tac ctxt fnctn = - CONVERSION - ((Conv.params_conv ~1 (fn ctxt => - (Conv.prems_conv ~1 (quot_true_conv ctxt fnctn)))) ctxt) - -fun dest_comb (f $ a) = (f, a) -fun dest_bcomb ((_ $ l) $ r) = (l, r) - -fun unlam t = - case t of - (Abs a) => snd (Term.dest_abs a) - | _ => unlam (Abs("", domain_type (fastype_of t), (incr_boundvars 1 t) $ (Bound 0))) - -fun dest_fun_type (Type("fun", [T, S])) = (T, S) - | dest_fun_type _ = error "dest_fun_type" - -val bare_concl = HOLogic.dest_Trueprop o Logic.strip_assums_concl - -(* We apply apply_rsp only in case if the type needs lifting. - This is the case if the type of the data in the Quot_True - assumption is different from the corresponding type in the goal. -*) -val apply_rsp_tac = - Subgoal.FOCUS (fn {concl, asms, context,...} => - let - val bare_concl = HOLogic.dest_Trueprop (term_of concl) - val qt_asm = find_qt_asm (map term_of asms) - in - case (bare_concl, qt_asm) of - (R2 $ (f $ x) $ (g $ y), SOME (qt_fun, qt_arg)) => - if fastype_of qt_fun = fastype_of f - then no_tac - else - let - val ty_x = fastype_of x - val ty_b = fastype_of qt_arg - val ty_f = range_type (fastype_of f) - val thy = ProofContext.theory_of context - val ty_inst = map (SOME o (ctyp_of thy)) [ty_x, ty_b, ty_f] - val t_inst = map (SOME o (cterm_of thy)) [R2, f, g, x, y]; - val inst_thm = Drule.instantiate' ty_inst - ([NONE, NONE, NONE] @ t_inst) @{thm apply_rsp} - in - (rtac inst_thm THEN' quotient_tac context) 1 - end - | _ => no_tac - end) - -(* Instantiates and applies 'equals_rsp'. Since the theorem is - complex we rely on instantiation to tell us if it applies -*) -fun equals_rsp_tac R ctxt = -let - val thy = ProofContext.theory_of ctxt -in - case try (cterm_of thy) R of (* There can be loose bounds in R *) - SOME ctm => - let - val ty = domain_type (fastype_of R) - in - case try (Drule.instantiate' [SOME (ctyp_of thy ty)] - [SOME (cterm_of thy R)]) @{thm equals_rsp} of - SOME thm => rtac thm THEN' quotient_tac ctxt - | NONE => K no_tac - end - | _ => K no_tac -end - -fun rep_abs_rsp_tac ctxt = - SUBGOAL (fn (goal, i) => - case (try bare_concl goal) of - SOME (rel $ _ $ (rep $ (abs $ _))) => - let - val thy = ProofContext.theory_of ctxt; - val (ty_a, ty_b) = dest_fun_type (fastype_of abs); - val ty_inst = map (SOME o (ctyp_of thy)) [ty_a, ty_b]; - in - case try (map (SOME o (cterm_of thy))) [rel, abs, rep] of - SOME t_inst => - (case try (Drule.instantiate' ty_inst t_inst) @{thm rep_abs_rsp} of - SOME inst_thm => (rtac inst_thm THEN' quotient_tac ctxt) i - | NONE => no_tac) - | NONE => no_tac - end - | _ => no_tac) - - - -(* Injection means to prove that the regularised theorem implies - the abs/rep injected one. - - The deterministic part: - - remove lambdas from both sides - - prove Ball/Bex/Babs equalities using ball_rsp, bex_rsp, babs_rsp - - prove Ball/Bex relations unfolding fun_rel_id - - reflexivity of equality - - prove equality of relations using equals_rsp - - use user-supplied RSP theorems - - solve 'relation of relations' goals using quot_rel_rsp - - remove rep_abs from the right side - (Lambdas under respects may have left us some assumptions) - - Then in order: - - split applications of lifted type (apply_rsp) - - split applications of non-lifted type (cong_tac) - - apply extentionality - - assumption - - reflexivity of the relation -*) -fun injection_match_tac ctxt = SUBGOAL (fn (goal, i) => -(case (bare_concl goal) of - (* (R1 ===> R2) (%x...) (%x...) ----> [|R1 x y|] ==> R2 (...x) (...y) *) - (Const (@{const_name fun_rel}, _) $ _ $ _) $ (Abs _) $ (Abs _) - => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam - - (* (op =) (Ball...) (Ball...) ----> (op =) (...) (...) *) -| (Const (@{const_name "op ="},_) $ - (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $ - (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _)) - => rtac @{thm ball_rsp} THEN' dtac @{thm QT_all} - - (* (R1 ===> op =) (Ball...) (Ball...) ----> [|R1 x y|] ==> (Ball...x) = (Ball...y) *) -| (Const (@{const_name fun_rel}, _) $ _ $ _) $ - (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $ - (Const(@{const_name Ball},_) $ (Const (@{const_name Respects}, _) $ _) $ _) - => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam - - (* (op =) (Bex...) (Bex...) ----> (op =) (...) (...) *) -| Const (@{const_name "op ="},_) $ - (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $ - (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) - => rtac @{thm bex_rsp} THEN' dtac @{thm QT_ex} - - (* (R1 ===> op =) (Bex...) (Bex...) ----> [|R1 x y|] ==> (Bex...x) = (Bex...y) *) -| (Const (@{const_name fun_rel}, _) $ _ $ _) $ - (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $ - (Const(@{const_name Bex},_) $ (Const (@{const_name Respects}, _) $ _) $ _) - => rtac @{thm fun_rel_id} THEN' quot_true_tac ctxt unlam - -| (Const (@{const_name fun_rel}, _) $ _ $ _) $ - (Const(@{const_name Bex1_rel},_) $ _) $ (Const(@{const_name Bex1_rel},_) $ _) - => rtac @{thm bex1_rel_rsp} THEN' quotient_tac ctxt - -| (_ $ - (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _) $ - (Const(@{const_name Babs},_) $ (Const (@{const_name Respects}, _) $ _) $ _)) - => rtac @{thm babs_rsp} THEN' RANGE [quotient_tac ctxt] - -| Const (@{const_name "op ="},_) $ (R $ _ $ _) $ (_ $ _ $ _) => - (rtac @{thm refl} ORELSE' - (equals_rsp_tac R ctxt THEN' RANGE [ - quot_true_tac ctxt (fst o dest_bcomb), quot_true_tac ctxt (snd o dest_bcomb)])) - - (* reflexivity of operators arising from Cong_tac *) -| Const (@{const_name "op ="},_) $ _ $ _ => rtac @{thm refl} - - (* respectfulness of constants; in particular of a simple relation *) -| _ $ (Const _) $ (Const _) (* fun_rel, list_rel, etc but not equality *) - => resolve_tac (rsp_rules_get ctxt) THEN_ALL_NEW quotient_tac ctxt - - (* R (...) (Rep (Abs ...)) ----> R (...) (...) *) - (* observe fun_map *) -| _ $ _ $ _ - => (rtac @{thm quot_rel_rsp} THEN_ALL_NEW quotient_tac ctxt) - ORELSE' rep_abs_rsp_tac ctxt - -| _ => K no_tac -) i) - -fun injection_step_tac ctxt rel_refl = - FIRST' [ - injection_match_tac ctxt, - - (* R (t $ ...) (t' $ ...) ----> apply_rsp provided type of t needs lifting *) - apply_rsp_tac ctxt THEN' - RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)], - - (* (op =) (t $ ...) (t' $ ...) ----> Cong provided type of t does not need lifting *) - (* merge with previous tactic *) - Cong_Tac.cong_tac @{thm cong} THEN' - RANGE [quot_true_tac ctxt (fst o dest_comb), quot_true_tac ctxt (snd o dest_comb)], - - (* (op =) (%x...) (%y...) ----> (op =) (...) (...) *) - rtac @{thm ext} THEN' quot_true_tac ctxt unlam, - - (* resolving with R x y assumptions *) - atac, - - (* reflexivity of the basic relations *) - (* R ... ... *) - resolve_tac rel_refl] - -fun injection_tac ctxt = -let - val rel_refl = map (OF1 @{thm equivp_reflp}) (equiv_rules_get ctxt) -in - injection_step_tac ctxt rel_refl -end - -fun all_injection_tac ctxt = - REPEAT_ALL_NEW (injection_tac ctxt) - - - -(*** Cleaning of the Theorem ***) - -(* expands all fun_maps, except in front of the (bound) variables listed in xs *) -fun fun_map_simple_conv xs ctrm = - case (term_of ctrm) of - ((Const (@{const_name "fun_map"}, _) $ _ $ _) $ h $ _) => - if member (op=) xs h - then Conv.all_conv ctrm - else Conv.rewr_conv @{thm fun_map_def[THEN eq_reflection]} ctrm - | _ => Conv.all_conv ctrm - -fun fun_map_conv xs ctxt ctrm = - case (term_of ctrm) of - _ $ _ => (Conv.comb_conv (fun_map_conv xs ctxt) then_conv - fun_map_simple_conv xs) ctrm - | Abs _ => Conv.abs_conv (fn (x, ctxt) => fun_map_conv ((term_of x)::xs) ctxt) ctxt ctrm - | _ => Conv.all_conv ctrm - -fun fun_map_tac ctxt = CONVERSION (fun_map_conv [] ctxt) - -(* custom matching functions *) -fun mk_abs u i t = - if incr_boundvars i u aconv t then Bound i else - case t of - t1 $ t2 => mk_abs u i t1 $ mk_abs u i t2 - | Abs (s, T, t') => Abs (s, T, mk_abs u (i + 1) t') - | Bound j => if i = j then error "make_inst" else t - | _ => t - -fun make_inst lhs t = -let - val _ $ (Abs (_, _, (_ $ ((f as Var (_, Type ("fun", [T, _]))) $ u)))) = lhs; - val _ $ (Abs (_, _, (_ $ g))) = t; -in - (f, Abs ("x", T, mk_abs u 0 g)) -end - -fun make_inst_id lhs t = -let - val _ $ (Abs (_, _, (f as Var (_, Type ("fun", [T, _]))) $ u)) = lhs; - val _ $ (Abs (_, _, g)) = t; -in - (f, Abs ("x", T, mk_abs u 0 g)) -end - -(* Simplifies a redex using the 'lambda_prs' theorem. - First instantiates the types and known subterms. - Then solves the quotient assumptions to get Rep2 and Abs1 - Finally instantiates the function f using make_inst - If Rep2 is an identity then the pattern is simpler and - make_inst_id is used -*) -fun lambda_prs_simple_conv ctxt ctrm = - case (term_of ctrm) of - (Const (@{const_name fun_map}, _) $ r1 $ a2) $ (Abs _) => - let - val thy = ProofContext.theory_of ctxt - val (ty_b, ty_a) = dest_fun_type (fastype_of r1) - val (ty_c, ty_d) = dest_fun_type (fastype_of a2) - val tyinst = map (SOME o (ctyp_of thy)) [ty_a, ty_b, ty_c, ty_d] - val tinst = [NONE, NONE, SOME (cterm_of thy r1), NONE, SOME (cterm_of thy a2)] - val thm1 = Drule.instantiate' tyinst tinst @{thm lambda_prs[THEN eq_reflection]} - val thm2 = solve_quotient_assm ctxt (solve_quotient_assm ctxt thm1) - val thm3 = MetaSimplifier.rewrite_rule @{thms id_apply[THEN eq_reflection]} thm2 - val (insp, inst) = - if ty_c = ty_d - then make_inst_id (term_of (Thm.lhs_of thm3)) (term_of ctrm) - else make_inst (term_of (Thm.lhs_of thm3)) (term_of ctrm) - val thm4 = Drule.instantiate ([], [(cterm_of thy insp, cterm_of thy inst)]) thm3 - in - Conv.rewr_conv thm4 ctrm - end - | _ => Conv.all_conv ctrm - -fun lambda_prs_conv ctxt = More_Conv.top_conv lambda_prs_simple_conv ctxt -fun lambda_prs_tac ctxt = CONVERSION (lambda_prs_conv ctxt) - - -(* Cleaning consists of: - - 1. unfolding of ---> in front of everything, except - bound variables (this prevents lambda_prs from - becoming stuck) - - 2. simplification with lambda_prs - - 3. simplification with: - - - Quotient_abs_rep Quotient_rel_rep - babs_prs all_prs ex_prs ex1_prs - - - id_simps and preservation lemmas and - - - symmetric versions of the definitions - (that is definitions of quotient constants - are folded) - - 4. test for refl -*) -fun clean_tac lthy = -let - val defs = map (symmetric o #def) (qconsts_dest lthy) - val prs = prs_rules_get lthy - val ids = id_simps_get lthy - val thms = @{thms Quotient_abs_rep Quotient_rel_rep babs_prs all_prs ex_prs ex1_prs} @ ids @ prs @ defs - - val ss = (mk_minimal_ss lthy) addsimps thms addSolver quotient_solver -in - EVERY' [fun_map_tac lthy, - lambda_prs_tac lthy, - simp_tac ss, - TRY o rtac refl] -end - - - -(** Tactic for Generalising Free Variables in a Goal **) - -fun inst_spec ctrm = - Drule.instantiate' [SOME (ctyp_of_term ctrm)] [NONE, SOME ctrm] @{thm spec} - -fun inst_spec_tac ctrms = - EVERY' (map (dtac o inst_spec) ctrms) - -fun all_list xs trm = - fold (fn (x, T) => fn t' => HOLogic.mk_all (x, T, t')) xs trm - -fun apply_under_Trueprop f = - HOLogic.dest_Trueprop #> f #> HOLogic.mk_Trueprop - -fun gen_frees_tac ctxt = - SUBGOAL (fn (concl, i) => - let - val thy = ProofContext.theory_of ctxt - val vrs = Term.add_frees concl [] - val cvrs = map (cterm_of thy o Free) vrs - val concl' = apply_under_Trueprop (all_list vrs) concl - val goal = Logic.mk_implies (concl', concl) - val rule = Goal.prove ctxt [] [] goal - (K (EVERY1 [inst_spec_tac (rev cvrs), atac])) - in - rtac rule i - end) - - -(** The General Shape of the Lifting Procedure **) - -(* - A is the original raw theorem - - B is the regularized theorem - - C is the rep/abs injected version of B - - D is the lifted theorem - - - 1st prem is the regularization step - - 2nd prem is the rep/abs injection step - - 3rd prem is the cleaning part - - the Quot_True premise in 2nd records the lifted theorem -*) -val lifting_procedure_thm = - @{lemma "[|A; - A --> B; - Quot_True D ==> B = C; - C = D|] ==> D" - by (simp add: Quot_True_def)} - -fun lift_match_error ctxt msg rtrm qtrm = -let - val rtrm_str = Syntax.string_of_term ctxt rtrm - val qtrm_str = Syntax.string_of_term ctxt qtrm - val msg = cat_lines [enclose "[" "]" msg, "The quotient theorem", qtrm_str, - "", "does not match with original theorem", rtrm_str] -in - error msg -end - -fun procedure_inst ctxt rtrm qtrm = -let - val thy = ProofContext.theory_of ctxt - val rtrm' = HOLogic.dest_Trueprop rtrm - val qtrm' = HOLogic.dest_Trueprop qtrm - val reg_goal = regularize_trm_chk ctxt (rtrm', qtrm') - handle (ERROR msg) => lift_match_error ctxt msg rtrm qtrm - val inj_goal = inj_repabs_trm_chk ctxt (reg_goal, qtrm') - handle (ERROR msg) => lift_match_error ctxt msg rtrm qtrm -in - Drule.instantiate' [] - [SOME (cterm_of thy rtrm'), - SOME (cterm_of thy reg_goal), - NONE, - SOME (cterm_of thy inj_goal)] lifting_procedure_thm -end - -(* the tactic leaves three subgoals to be proved *) -fun procedure_tac ctxt rthm = - Object_Logic.full_atomize_tac - THEN' gen_frees_tac ctxt - THEN' SUBGOAL (fn (goal, i) => - let - val rthm' = atomize_thm rthm - val rule = procedure_inst ctxt (prop_of rthm') goal - in - (rtac rule THEN' rtac rthm') i - end) - - -(* Automatic Proofs *) - -val msg1 = "The regularize proof failed." -val msg2 = cat_lines ["The injection proof failed.", - "This is probably due to missing respects lemmas.", - "Try invoking the injection method manually to see", - "which lemmas are missing."] -val msg3 = "The cleaning proof failed." - -fun lift_tac ctxt rthms = -let - fun mk_tac rthm = - procedure_tac ctxt rthm - THEN' RANGE_WARN - [(regularize_tac ctxt, msg1), - (all_injection_tac ctxt, msg2), - (clean_tac ctxt, msg3)] -in - simp_tac (mk_minimal_ss ctxt) (* unfolding multiple &&& *) - THEN' RANGE (map mk_tac rthms) -end - -(* An Attribute which automatically constructs the qthm *) -fun lifted_attrib_aux context thm = -let - val ctxt = Context.proof_of context - val ((_, [thm']), ctxt') = Variable.import false [thm] ctxt - val goal = (quotient_lift_all ctxt' o prop_of) thm' -in - Goal.prove ctxt' [] [] goal (K (lift_tac ctxt' [thm] 1)) - |> singleton (ProofContext.export ctxt' ctxt) -end; - -val lifted_attrib = Thm.rule_attribute lifted_attrib_aux - -end; (* structure *) diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/quotient_term.ML --- a/Attic/Quot/quotient_term.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,780 +0,0 @@ -(* Title: HOL/Tools/Quotient/quotient_term.thy - Author: Cezary Kaliszyk and Christian Urban - -Constructs terms corresponding to goals from lifting theorems to -quotient types. -*) - -signature QUOTIENT_TERM = -sig - datatype flag = AbsF | RepF - - val absrep_fun: flag -> Proof.context -> typ * typ -> term - val absrep_fun_chk: flag -> Proof.context -> typ * typ -> term - - (* Allows Nitpick to represent quotient types as single elements from raw type *) - val absrep_const_chk: flag -> Proof.context -> string -> term - - val equiv_relation: Proof.context -> typ * typ -> term - val equiv_relation_chk: Proof.context -> typ * typ -> term - - val regularize_trm: Proof.context -> term * term -> term - val regularize_trm_chk: Proof.context -> term * term -> term - - val inj_repabs_trm: Proof.context -> term * term -> term - val inj_repabs_trm_chk: Proof.context -> term * term -> term - - val quotient_lift_const: string * term -> local_theory -> term - val quotient_lift_all: Proof.context -> term -> term -end; - -structure Quotient_Term: QUOTIENT_TERM = -struct - -open Quotient_Info; - -exception LIFT_MATCH of string - - - -(*** Aggregate Rep/Abs Function ***) - - -(* The flag RepF is for types in negative position; AbsF is for types - in positive position. Because of this, function types need to be - treated specially, since there the polarity changes. -*) - -datatype flag = AbsF | RepF - -fun negF AbsF = RepF - | negF RepF = AbsF - -fun is_identity (Const (@{const_name "id"}, _)) = true - | is_identity _ = false - -fun mk_identity ty = Const (@{const_name "id"}, ty --> ty) - -fun mk_fun_compose flag (trm1, trm2) = - case flag of - AbsF => Const (@{const_name "comp"}, dummyT) $ trm1 $ trm2 - | RepF => Const (@{const_name "comp"}, dummyT) $ trm2 $ trm1 - -fun get_mapfun ctxt s = -let - val thy = ProofContext.theory_of ctxt - val exn = error ("No map function for type " ^ quote s ^ " found.") - val mapfun = #mapfun (maps_lookup thy s) handle Quotient_Info.NotFound => raise exn -in - Const (mapfun, dummyT) -end - -(* makes a Free out of a TVar *) -fun mk_Free (TVar ((x, i), _)) = Free (unprefix "'" x ^ string_of_int i, dummyT) - -(* produces an aggregate map function for the - rty-part of a quotient definition; abstracts - over all variables listed in vs (these variables - correspond to the type variables in rty) - - for example for: (?'a list * ?'b) - it produces: %a b. prod_map (map a) b -*) -fun mk_mapfun ctxt vs rty = -let - val vs' = map (mk_Free) vs - - fun mk_mapfun_aux rty = - case rty of - TVar _ => mk_Free rty - | Type (_, []) => mk_identity rty - | Type (s, tys) => list_comb (get_mapfun ctxt s, map mk_mapfun_aux tys) - | _ => raise (error "mk_mapfun (default)") -in - fold_rev Term.lambda vs' (mk_mapfun_aux rty) -end - -(* looks up the (varified) rty and qty for - a quotient definition -*) -fun get_rty_qty ctxt s = -let - val thy = ProofContext.theory_of ctxt - val exn = error ("No quotient type " ^ quote s ^ " found.") - val qdata = (quotdata_lookup thy s) handle Quotient_Info.NotFound => raise exn -in - (#rtyp qdata, #qtyp qdata) -end - -(* takes two type-environments and looks - up in both of them the variable v, which - must be listed in the environment -*) -fun double_lookup rtyenv qtyenv v = -let - val v' = fst (dest_TVar v) -in - (snd (the (Vartab.lookup rtyenv v')), snd (the (Vartab.lookup qtyenv v'))) -end - -(* matches a type pattern with a type *) -fun match ctxt err ty_pat ty = -let - val thy = ProofContext.theory_of ctxt -in - Sign.typ_match thy (ty_pat, ty) Vartab.empty - handle MATCH_TYPE => err ctxt ty_pat ty -end - -(* produces the rep or abs constant for a qty *) -fun absrep_const flag ctxt qty_str = -let - val thy = ProofContext.theory_of ctxt - val qty_name = Long_Name.base_name qty_str -in - case flag of - AbsF => Const (Sign.full_bname thy ("abs_" ^ qty_name), dummyT) - | RepF => Const (Sign.full_bname thy ("rep_" ^ qty_name), dummyT) -end - -(* Lets Nitpick represent elements of quotient types as elements of the raw type *) -fun absrep_const_chk flag ctxt qty_str = - Syntax.check_term ctxt (absrep_const flag ctxt qty_str) - -fun absrep_match_err ctxt ty_pat ty = -let - val ty_pat_str = Syntax.string_of_typ ctxt ty_pat - val ty_str = Syntax.string_of_typ ctxt ty -in - raise error (cat_lines - ["absrep_fun (Types ", quote ty_pat_str, "and", quote ty_str, " do not match.)"]) -end - - -(** generation of an aggregate absrep function **) - -(* - In case of equal types we just return the identity. - - - In case of TFrees we also return the identity. - - - In case of function types we recurse taking - the polarity change into account. - - - If the type constructors are equal, we recurse for the - arguments and build the appropriate map function. - - - If the type constructors are unequal, there must be an - instance of quotient types: - - - we first look up the corresponding rty_pat and qty_pat - from the quotient definition; the arguments of qty_pat - must be some distinct TVars - - we then match the rty_pat with rty and qty_pat with qty; - if matching fails the types do not correspond -> error - - the matching produces two environments; we look up the - assignments for the qty_pat variables and recurse on the - assignments - - we prefix the aggregate map function for the rty_pat, - which is an abstraction over all type variables - - finally we compose the result with the appropriate - absrep function in case at least one argument produced - a non-identity function / - otherwise we just return the appropriate absrep - function - - The composition is necessary for types like - - ('a list) list / ('a foo) foo - - The matching is necessary for types like - - ('a * 'a) list / 'a bar - - The test is necessary in order to eliminate superfluous - identity maps. -*) - -fun absrep_fun flag ctxt (rty, qty) = - if rty = qty - then mk_identity rty - else - case (rty, qty) of - (Type ("fun", [ty1, ty2]), Type ("fun", [ty1', ty2'])) => - let - val arg1 = absrep_fun (negF flag) ctxt (ty1, ty1') - val arg2 = absrep_fun flag ctxt (ty2, ty2') - in - list_comb (get_mapfun ctxt "fun", [arg1, arg2]) - end - | (Type (s, tys), Type (s', tys')) => - if s = s' - then - let - val args = map (absrep_fun flag ctxt) (tys ~~ tys') - in - list_comb (get_mapfun ctxt s, args) - end - else - let - val (rty_pat, qty_pat as Type (_, vs)) = get_rty_qty ctxt s' - val rtyenv = match ctxt absrep_match_err rty_pat rty - val qtyenv = match ctxt absrep_match_err qty_pat qty - val args_aux = map (double_lookup rtyenv qtyenv) vs - val args = map (absrep_fun flag ctxt) args_aux - val map_fun = mk_mapfun ctxt vs rty_pat - val result = list_comb (map_fun, args) - in - (*if forall is_identity args - then absrep_const flag ctxt s' - else*) mk_fun_compose flag (absrep_const flag ctxt s', result) - end - | (TFree x, TFree x') => - if x = x' - then mk_identity rty - else raise (error "absrep_fun (frees)") - | (TVar _, TVar _) => raise (LIFT_MATCH "absrep_fun (vars)") - | _ => raise (error "absrep_fun (default)") - -fun absrep_fun_chk flag ctxt (rty, qty) = - absrep_fun flag ctxt (rty, qty) - |> Syntax.check_term ctxt - - - - -(*** Aggregate Equivalence Relation ***) - - -(* works very similar to the absrep generation, - except there is no need for polarities -*) - -(* instantiates TVars so that the term is of type ty *) -fun force_typ ctxt trm ty = -let - val thy = ProofContext.theory_of ctxt - val trm_ty = fastype_of trm - val ty_inst = Sign.typ_match thy (trm_ty, ty) Vartab.empty -in - map_types (Envir.subst_type ty_inst) trm -end - -fun is_eq (Const (@{const_name "op ="}, _)) = true - | is_eq _ = false - -fun mk_rel_compose (trm1, trm2) = - Const (@{const_abbrev "rel_conj"}, dummyT) $ trm1 $ trm2 - -fun get_relmap ctxt s = -let - val thy = ProofContext.theory_of ctxt - val exn = error ("get_relmap (no relation map function found for type " ^ s ^ ")") - val relmap = #relmap (maps_lookup thy s) handle Quotient_Info.NotFound => raise exn -in - Const (relmap, dummyT) -end - -fun mk_relmap ctxt vs rty = -let - val vs' = map (mk_Free) vs - - fun mk_relmap_aux rty = - case rty of - TVar _ => mk_Free rty - | Type (_, []) => HOLogic.eq_const rty - | Type (s, tys) => list_comb (get_relmap ctxt s, map mk_relmap_aux tys) - | _ => raise (error "mk_relmap (default)") -in - fold_rev Term.lambda vs' (mk_relmap_aux rty) -end - -fun get_equiv_rel ctxt s = -let - val thy = ProofContext.theory_of ctxt - val exn = error ("get_quotdata (no quotient found for type " ^ s ^ ")") -in - #equiv_rel (quotdata_lookup thy s) handle Quotient_Info.NotFound => raise exn -end - -fun equiv_match_err ctxt ty_pat ty = -let - val ty_pat_str = Syntax.string_of_typ ctxt ty_pat - val ty_str = Syntax.string_of_typ ctxt ty -in - raise error (space_implode " " - ["equiv_relation (Types ", quote ty_pat_str, "and", quote ty_str, " do not match.)"]) -end - -(* builds the aggregate equivalence relation - that will be the argument of Respects -*) -fun equiv_relation ctxt (rty, qty) = - if rty = qty - then HOLogic.eq_const rty - else - case (rty, qty) of - (Type (s, tys), Type (s', tys')) => - if s = s' - then - let - val args = map (equiv_relation ctxt) (tys ~~ tys') - in - list_comb (get_relmap ctxt s, args) - end - else - let - val (rty_pat, qty_pat as Type (_, vs)) = get_rty_qty ctxt s' - val rtyenv = match ctxt equiv_match_err rty_pat rty - val qtyenv = match ctxt equiv_match_err qty_pat qty - val args_aux = map (double_lookup rtyenv qtyenv) vs - val args = map (equiv_relation ctxt) args_aux - val rel_map = mk_relmap ctxt vs rty_pat - val result = list_comb (rel_map, args) - val eqv_rel = get_equiv_rel ctxt s' - val eqv_rel' = force_typ ctxt eqv_rel ([rty, rty] ---> @{typ bool}) - in - if forall is_eq args - then eqv_rel' - else mk_rel_compose (result, eqv_rel') - end - | _ => HOLogic.eq_const rty - -fun equiv_relation_chk ctxt (rty, qty) = - equiv_relation ctxt (rty, qty) - |> Syntax.check_term ctxt - - - -(*** Regularization ***) - -(* Regularizing an rtrm means: - - - Quantifiers over types that need lifting are replaced - by bounded quantifiers, for example: - - All P ----> All (Respects R) P - - where the aggregate relation R is given by the rty and qty; - - - Abstractions over types that need lifting are replaced - by bounded abstractions, for example: - - %x. P ----> Ball (Respects R) %x. P - - - Equalities over types that need lifting are replaced by - corresponding equivalence relations, for example: - - A = B ----> R A B - - or - - A = B ----> (R ===> R) A B - - for more complicated types of A and B - - - The regularize_trm accepts raw theorems in which equalities - and quantifiers match exactly the ones in the lifted theorem - but also accepts partially regularized terms. - - This means that the raw theorems can have: - Ball (Respects R), Bex (Respects R), Bex1_rel (Respects R), Babs, R - in the places where: - All, Ex, Ex1, %, (op =) - is required the lifted theorem. - -*) - -val mk_babs = Const (@{const_name Babs}, dummyT) -val mk_ball = Const (@{const_name Ball}, dummyT) -val mk_bex = Const (@{const_name Bex}, dummyT) -val mk_bex1_rel = Const (@{const_name Bex1_rel}, dummyT) -val mk_resp = Const (@{const_name Respects}, dummyT) - -(* - applies f to the subterm of an abstraction, - otherwise to the given term, - - used by regularize, therefore abstracted - variables do not have to be treated specially -*) -fun apply_subt f (trm1, trm2) = - case (trm1, trm2) of - (Abs (x, T, t), Abs (_ , _, t')) => Abs (x, T, f (t, t')) - | _ => f (trm1, trm2) - -fun term_mismatch str ctxt t1 t2 = -let - val t1_str = Syntax.string_of_term ctxt t1 - val t2_str = Syntax.string_of_term ctxt t2 - val t1_ty_str = Syntax.string_of_typ ctxt (fastype_of t1) - val t2_ty_str = Syntax.string_of_typ ctxt (fastype_of t2) -in - raise error (cat_lines [str, t1_str ^ "::" ^ t1_ty_str, t2_str ^ "::" ^ t2_ty_str]) -end - -(* the major type of All and Ex quantifiers *) -fun qnt_typ ty = domain_type (domain_type ty) - -(* Checks that two types match, for example: - rty -> rty matches qty -> qty *) -fun matches_typ thy rT qT = - if rT = qT then true else - case (rT, qT) of - (Type (rs, rtys), Type (qs, qtys)) => - if rs = qs then - if length rtys <> length qtys then false else - forall (fn x => x = true) (map2 (matches_typ thy) rtys qtys) - else - (case Quotient_Info.quotdata_lookup_raw thy qs of - SOME quotinfo => Sign.typ_instance thy (rT, #rtyp quotinfo) - | NONE => false) - | _ => false - - -(* produces a regularized version of rtrm - - - the result might contain dummyTs - - - for regularisation we do not need any - special treatment of bound variables -*) -fun regularize_trm ctxt (rtrm, qtrm) = - case (rtrm, qtrm) of - (Abs (x, ty, t), Abs (_, ty', t')) => - let - val subtrm = Abs(x, ty, regularize_trm ctxt (t, t')) - in - if ty = ty' then subtrm - else mk_babs $ (mk_resp $ equiv_relation ctxt (ty, ty')) $ subtrm - end - | (Const (@{const_name "Babs"}, T) $ resrel $ (t as (Abs (_, ty, _))), t' as (Abs (_, ty', _))) => - let - val subtrm = regularize_trm ctxt (t, t') - val needres = mk_resp $ equiv_relation_chk ctxt (ty, ty') - in - if resrel <> needres - then term_mismatch "regularize (Babs)" ctxt resrel needres - else mk_babs $ resrel $ subtrm - end - - | (Const (@{const_name "All"}, ty) $ t, Const (@{const_name "All"}, ty') $ t') => - let - val subtrm = apply_subt (regularize_trm ctxt) (t, t') - in - if ty = ty' then Const (@{const_name "All"}, ty) $ subtrm - else mk_ball $ (mk_resp $ equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm - end - - | (Const (@{const_name "Ex"}, ty) $ t, Const (@{const_name "Ex"}, ty') $ t') => - let - val subtrm = apply_subt (regularize_trm ctxt) (t, t') - in - if ty = ty' then Const (@{const_name "Ex"}, ty) $ subtrm - else mk_bex $ (mk_resp $ equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm - end - - | (Const (@{const_name "Ex1"}, ty) $ (Abs (_, _, - (Const (@{const_name "op &"}, _) $ (Const (@{const_name "op :"}, _) $ _ $ - (Const (@{const_name "Respects"}, _) $ resrel)) $ (t $ _)))), - Const (@{const_name "Ex1"}, ty') $ t') => - let - val t_ = incr_boundvars (~1) t - val subtrm = apply_subt (regularize_trm ctxt) (t_, t') - val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty') - in - if resrel <> needrel - then term_mismatch "regularize (Bex1)" ctxt resrel needrel - else mk_bex1_rel $ resrel $ subtrm - end - - | (Const (@{const_name "Ex1"}, ty) $ t, Const (@{const_name "Ex1"}, ty') $ t') => - let - val subtrm = apply_subt (regularize_trm ctxt) (t, t') - in - if ty = ty' then Const (@{const_name "Ex1"}, ty) $ subtrm - else mk_bex1_rel $ (equiv_relation ctxt (qnt_typ ty, qnt_typ ty')) $ subtrm - end - - | (Const (@{const_name "Ball"}, ty) $ (Const (@{const_name "Respects"}, _) $ resrel) $ t, - Const (@{const_name "All"}, ty') $ t') => - let - val subtrm = apply_subt (regularize_trm ctxt) (t, t') - val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty') - in - if resrel <> needrel - then term_mismatch "regularize (Ball)" ctxt resrel needrel - else mk_ball $ (mk_resp $ resrel) $ subtrm - end - - | (Const (@{const_name "Bex"}, ty) $ (Const (@{const_name "Respects"}, _) $ resrel) $ t, - Const (@{const_name "Ex"}, ty') $ t') => - let - val subtrm = apply_subt (regularize_trm ctxt) (t, t') - val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty') - in - if resrel <> needrel - then term_mismatch "regularize (Bex)" ctxt resrel needrel - else mk_bex $ (mk_resp $ resrel) $ subtrm - end - - | (Const (@{const_name "Bex1_rel"}, ty) $ resrel $ t, Const (@{const_name "Ex1"}, ty') $ t') => - let - val subtrm = apply_subt (regularize_trm ctxt) (t, t') - val needrel = equiv_relation_chk ctxt (qnt_typ ty, qnt_typ ty') - in - if resrel <> needrel - then term_mismatch "regularize (Bex1_res)" ctxt resrel needrel - else mk_bex1_rel $ resrel $ subtrm - end - - | (* equalities need to be replaced by appropriate equivalence relations *) - (Const (@{const_name "op ="}, ty), Const (@{const_name "op ="}, ty')) => - if ty = ty' then rtrm - else equiv_relation ctxt (domain_type ty, domain_type ty') - - | (* in this case we just check whether the given equivalence relation is correct *) - (rel, Const (@{const_name "op ="}, ty')) => - let - val rel_ty = fastype_of rel - val rel' = equiv_relation_chk ctxt (domain_type rel_ty, domain_type ty') - in - if rel' aconv rel then rtrm - else term_mismatch "regularise (relation mismatch)" ctxt rel rel' - end - - | (_, Const _) => - let - val thy = ProofContext.theory_of ctxt - fun same_const (Const (s, T)) (Const (s', T')) = (s = s') andalso matches_typ thy T T' - | same_const _ _ = false - in - if same_const rtrm qtrm then rtrm - else - let - val rtrm' = #rconst (qconsts_lookup thy qtrm) - handle Quotient_Info.NotFound => term_mismatch "regularize(constant notfound)" ctxt rtrm qtrm - in - if Pattern.matches thy (rtrm', rtrm) - then rtrm else term_mismatch "regularize(constant mismatch)" ctxt rtrm qtrm - end - end - - | (((t1 as Const (@{const_name "split"}, _)) $ Abs (v1, ty, Abs(v1', ty', s1))), - ((t2 as Const (@{const_name "split"}, _)) $ Abs (v2, _ , Abs(v2', _ , s2)))) => - regularize_trm ctxt (t1, t2) $ Abs (v1, ty, Abs (v1', ty', regularize_trm ctxt (s1, s2))) - - | (((t1 as Const (@{const_name "split"}, _)) $ Abs (v1, ty, s1)), - ((t2 as Const (@{const_name "split"}, _)) $ Abs (v2, _ , s2))) => - regularize_trm ctxt (t1, t2) $ Abs (v1, ty, regularize_trm ctxt (s1, s2)) - - | (t1 $ t2, t1' $ t2') => - regularize_trm ctxt (t1, t1') $ regularize_trm ctxt (t2, t2') - - | (Bound i, Bound i') => - if i = i' then rtrm - else raise (error "regularize (bounds mismatch)") - - | _ => - let - val rtrm_str = Syntax.string_of_term ctxt rtrm - val qtrm_str = Syntax.string_of_term ctxt qtrm - in - raise (error ("regularize failed (default: " ^ rtrm_str ^ "," ^ qtrm_str ^ ")")) - end - -fun regularize_trm_chk ctxt (rtrm, qtrm) = - regularize_trm ctxt (rtrm, qtrm) - |> Syntax.check_term ctxt - - - -(*** Rep/Abs Injection ***) - -(* -Injection of Rep/Abs means: - - For abstractions: - - * If the type of the abstraction needs lifting, then we add Rep/Abs - around the abstraction; otherwise we leave it unchanged. - - For applications: - - * If the application involves a bounded quantifier, we recurse on - the second argument. If the application is a bounded abstraction, - we always put an Rep/Abs around it (since bounded abstractions - are assumed to always need lifting). Otherwise we recurse on both - arguments. - - For constants: - - * If the constant is (op =), we leave it always unchanged. - Otherwise the type of the constant needs lifting, we put - and Rep/Abs around it. - - For free variables: - - * We put a Rep/Abs around it if the type needs lifting. - - Vars case cannot occur. -*) - -fun mk_repabs ctxt (T, T') trm = - absrep_fun RepF ctxt (T, T') $ (absrep_fun AbsF ctxt (T, T') $ trm) - -fun inj_repabs_err ctxt msg rtrm qtrm = -let - val rtrm_str = Syntax.string_of_term ctxt rtrm - val qtrm_str = Syntax.string_of_term ctxt qtrm -in - raise error (space_implode " " [msg, quote rtrm_str, "and", quote qtrm_str]) -end - - -(* bound variables need to be treated properly, - as the type of subterms needs to be calculated *) -fun inj_repabs_trm ctxt (rtrm, qtrm) = - case (rtrm, qtrm) of - (Const (@{const_name "Ball"}, T) $ r $ t, Const (@{const_name "All"}, _) $ t') => - Const (@{const_name "Ball"}, T) $ r $ (inj_repabs_trm ctxt (t, t')) - - | (Const (@{const_name "Bex"}, T) $ r $ t, Const (@{const_name "Ex"}, _) $ t') => - Const (@{const_name "Bex"}, T) $ r $ (inj_repabs_trm ctxt (t, t')) - - | (Const (@{const_name "Babs"}, T) $ r $ t, t' as (Abs _)) => - let - val rty = fastype_of rtrm - val qty = fastype_of qtrm - in - mk_repabs ctxt (rty, qty) (Const (@{const_name "Babs"}, T) $ r $ (inj_repabs_trm ctxt (t, t'))) - end - - | (Abs (x, T, t), Abs (x', T', t')) => - let - val rty = fastype_of rtrm - val qty = fastype_of qtrm - val (y, s) = Term.dest_abs (x, T, t) - val (_, s') = Term.dest_abs (x', T', t') - val yvar = Free (y, T) - val result = Term.lambda_name (y, yvar) (inj_repabs_trm ctxt (s, s')) - in - if rty = qty then result - else mk_repabs ctxt (rty, qty) result - end - - | (t $ s, t' $ s') => - (inj_repabs_trm ctxt (t, t')) $ (inj_repabs_trm ctxt (s, s')) - - | (Free (_, T), Free (_, T')) => - if T = T' then rtrm - else mk_repabs ctxt (T, T') rtrm - - | (_, Const (@{const_name "op ="}, _)) => rtrm - - | (_, Const (_, T')) => - let - val rty = fastype_of rtrm - in - if rty = T' then rtrm - else mk_repabs ctxt (rty, T') rtrm - end - - | _ => inj_repabs_err ctxt "injection (default):" rtrm qtrm - -fun inj_repabs_trm_chk ctxt (rtrm, qtrm) = - inj_repabs_trm ctxt (rtrm, qtrm) - |> Syntax.check_term ctxt - - - -(*** Wrapper for automatically transforming an rthm into a qthm ***) - -(* subst_tys takes a list of (rty, qty) substitution pairs - and replaces all occurences of rty in the given type - by appropriate qty, with substitution *) -fun subst_ty thy ty (rty, qty) r = - if r <> NONE then r else - case try (Sign.typ_match thy (rty, ty)) Vartab.empty of - SOME inst => SOME (Envir.subst_type inst qty) - | NONE => NONE -fun subst_tys thy substs ty = - case fold (subst_ty thy ty) substs NONE of - SOME ty => ty - | NONE => - (case ty of - Type (s, tys) => Type (s, map (subst_tys thy substs) tys) - | x => x) - -(* subst_trms takes a list of (rtrm, qtrm) substitution pairs - and if the given term matches any of the raw terms it - returns the appropriate qtrm instantiated. If none of - them matched it returns NONE. *) -fun subst_trm thy t (rtrm, qtrm) s = - if s <> NONE then s else - case try (Pattern.match thy (rtrm, t)) (Vartab.empty, Vartab.empty) of - SOME inst => SOME (Envir.subst_term inst qtrm) - | NONE => NONE; -fun subst_trms thy substs t = fold (subst_trm thy t) substs NONE - -(* prepares type and term substitution pairs to be used by above - functions that let replace all raw constructs by appropriate - lifted counterparts. *) -fun get_ty_trm_substs ctxt = -let - val thy = ProofContext.theory_of ctxt - val quot_infos = Quotient_Info.quotdata_dest ctxt - val const_infos = Quotient_Info.qconsts_dest ctxt - val ty_substs = map (fn ri => (#rtyp ri, #qtyp ri)) quot_infos - val const_substs = map (fn ci => (#rconst ci, #qconst ci)) const_infos - fun rel_eq rel = HOLogic.eq_const (subst_tys thy ty_substs (domain_type (fastype_of rel))) - val rel_substs = map (fn ri => (#equiv_rel ri, rel_eq (#equiv_rel ri))) quot_infos -in - (ty_substs, const_substs @ rel_substs) -end - -fun quotient_lift_const (b, t) ctxt = -let - val thy = ProofContext.theory_of ctxt - val (ty_substs, _) = get_ty_trm_substs ctxt; - val (_, ty) = dest_Const t; - val nty = subst_tys thy ty_substs ty; -in - Free(b, nty) -end - -(* -Takes a term and - -* replaces raw constants by the quotient constants - -* replaces equivalence relations by equalities - -* replaces raw types by the quotient types - -*) - -fun quotient_lift_all ctxt t = -let - val thy = ProofContext.theory_of ctxt - val (ty_substs, substs) = get_ty_trm_substs ctxt - fun lift_aux t = - case subst_trms thy substs t of - SOME x => x - | NONE => - (case t of - a $ b => lift_aux a $ lift_aux b - | Abs(a, ty, s) => - let - val (y, s') = Term.dest_abs (a, ty, s) - val nty = subst_tys thy ty_substs ty - in - Abs(y, nty, abstract_over (Free (y, nty), lift_aux s')) - end - | Free(n, ty) => Free(n, subst_tys thy ty_substs ty) - | Var(n, ty) => Var(n, subst_tys thy ty_substs ty) - | Bound i => Bound i - | Const(s, ty) => Const(s, subst_tys thy ty_substs ty)) -in - lift_aux t -end - -end; (* structure *) diff -r a6f3e1b08494 -r b6873d123f9b Attic/Quot/quotient_typ.ML --- a/Attic/Quot/quotient_typ.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,310 +0,0 @@ -(* Title: HOL/Tools/Quotient/quotient_typ.thy - Author: Cezary Kaliszyk and Christian Urban - -Definition of a quotient type. - -*) - -signature QUOTIENT_TYPE = -sig - val add_quotient_type: ((string list * binding * mixfix) * (typ * term)) * thm - -> Proof.context -> (thm * thm) * local_theory - - val quotient_type: ((string list * binding * mixfix) * (typ * term)) list - -> Proof.context -> Proof.state - - val quotient_type_cmd: ((((string list * binding) * mixfix) * string) * string) list - -> Proof.context -> Proof.state -end; - -structure Quotient_Type: QUOTIENT_TYPE = -struct - -open Quotient_Info; - -(* wrappers for define, note, Attrib.internal and theorem_i *) -fun define (name, mx, rhs) lthy = -let - val ((rhs, (_ , thm)), lthy') = - Local_Theory.define ((name, mx), (Attrib.empty_binding, rhs)) lthy -in - ((rhs, thm), lthy') -end - -fun note (name, thm, attrs) lthy = -let - val ((_,[thm']), lthy') = Local_Theory.note ((name, attrs), [thm]) lthy -in - (thm', lthy') -end - -fun intern_attr at = Attrib.internal (K at) - -fun theorem after_qed goals ctxt = -let - val goals' = map (rpair []) goals - fun after_qed' thms = after_qed (the_single thms) -in - Proof.theorem_i NONE after_qed' [goals'] ctxt -end - - - -(*** definition of quotient types ***) - -val mem_def1 = @{lemma "y : S ==> S y" by (simp add: mem_def)} -val mem_def2 = @{lemma "S y ==> y : S" by (simp add: mem_def)} - -(* constructs the term lambda (c::rty => bool). EX (x::rty). c = rel x *) -fun typedef_term rel rty lthy = -let - val [x, c] = - [("x", rty), ("c", HOLogic.mk_setT rty)] - |> Variable.variant_frees lthy [rel] - |> map Free -in - lambda c (HOLogic.exists_const rty $ - lambda x (HOLogic.mk_eq (c, (rel $ x)))) -end - - -(* makes the new type definitions and proves non-emptyness *) -fun typedef_make (vs, qty_name, mx, rel, rty) lthy = -let - val typedef_tac = - EVERY1 (map rtac [@{thm exI}, mem_def2, @{thm exI}, @{thm refl}]) -in - Typedef.add_typedef false NONE (qty_name, vs, mx) - (typedef_term rel rty lthy) NONE typedef_tac lthy -end - - -(* tactic to prove the quot_type theorem for the new type *) -fun typedef_quot_type_tac equiv_thm (typedef_info: Typedef.info) = -let - val rep_thm = #Rep typedef_info RS mem_def1 - val rep_inv = #Rep_inverse typedef_info - val abs_inv = mem_def2 RS #Abs_inverse typedef_info - val rep_inj = #Rep_inject typedef_info -in - (rtac @{thm quot_type.intro} THEN' RANGE [ - rtac equiv_thm, - rtac rep_thm, - rtac rep_inv, - EVERY' (map rtac [abs_inv, @{thm exI}, @{thm refl}]), - rtac rep_inj]) 1 -end - - -(* proves the quot_type theorem for the new type *) -fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy = -let - val quot_type_const = Const (@{const_name "quot_type"}, dummyT) - val goal = - HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep) - |> Syntax.check_term lthy -in - Goal.prove lthy [] [] goal - (K (typedef_quot_type_tac equiv_thm typedef_info)) -end - -(* proves the quotient theorem for the new type *) -fun typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_type_thm) lthy = -let - val quotient_const = Const (@{const_name "Quotient"}, dummyT) - val goal = - HOLogic.mk_Trueprop (quotient_const $ rel $ abs $ rep) - |> Syntax.check_term lthy - - val typedef_quotient_thm_tac = - EVERY1 [ - K (rewrite_goals_tac [abs_def, rep_def]), - rtac @{thm quot_type.Quotient}, - rtac quot_type_thm] -in - Goal.prove lthy [] [] goal - (K typedef_quotient_thm_tac) -end - - -(* main function for constructing a quotient type *) -fun add_quotient_type (((vs, qty_name, mx), (rty, rel)), equiv_thm) lthy = -let - (* generates the typedef *) - val ((qty_full_name, typedef_info), lthy1) = typedef_make (vs, qty_name, mx, rel, rty) lthy - - (* abs and rep functions from the typedef *) - val Abs_ty = #abs_type typedef_info - val Rep_ty = #rep_type typedef_info - val Abs_name = #Abs_name typedef_info - val Rep_name = #Rep_name typedef_info - val Abs_const = Const (Abs_name, Rep_ty --> Abs_ty) - val Rep_const = Const (Rep_name, Abs_ty --> Rep_ty) - - (* more useful abs and rep definitions *) - val abs_const = Const (@{const_name "quot_type.abs"}, dummyT ) - val rep_const = Const (@{const_name "quot_type.rep"}, dummyT ) - val abs_trm = Syntax.check_term lthy1 (abs_const $ rel $ Abs_const) - val rep_trm = Syntax.check_term lthy1 (rep_const $ Rep_const) - val abs_name = Binding.prefix_name "abs_" qty_name - val rep_name = Binding.prefix_name "rep_" qty_name - - val ((abs, abs_def), lthy2) = define (abs_name, NoSyn, abs_trm) lthy1 - val ((rep, rep_def), lthy3) = define (rep_name, NoSyn, rep_trm) lthy2 - - (* quot_type theorem *) - val quot_thm = typedef_quot_type_thm (rel, Abs_const, Rep_const, equiv_thm, typedef_info) lthy3 - - (* quotient theorem *) - val quotient_thm = typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_thm) lthy3 - val quotient_thm_name = Binding.prefix_name "Quotient_" qty_name - - (* name equivalence theorem *) - val equiv_thm_name = Binding.suffix_name "_equivp" qty_name - - (* storing the quot-info *) - fun qinfo phi = transform_quotdata phi - {qtyp = Abs_ty, rtyp = rty, equiv_rel = rel, equiv_thm = equiv_thm} - val lthy4 = Local_Theory.declaration true - (fn phi => quotdata_update_gen qty_full_name (qinfo phi)) lthy3 -in - lthy4 - |> note (quotient_thm_name, quotient_thm, [intern_attr quotient_rules_add]) - ||>> note (equiv_thm_name, equiv_thm, [intern_attr equiv_rules_add]) -end - - -(* sanity checks for the quotient type specifications *) -fun sanity_check ((vs, qty_name, _), (rty, rel)) = -let - val rty_tfreesT = map fst (Term.add_tfreesT rty []) - val rel_tfrees = map fst (Term.add_tfrees rel []) - val rel_frees = map fst (Term.add_frees rel []) - val rel_vars = Term.add_vars rel [] - val rel_tvars = Term.add_tvars rel [] - val qty_str = Binding.str_of qty_name ^ ": " - - val illegal_rel_vars = - if null rel_vars andalso null rel_tvars then [] - else [qty_str ^ "illegal schematic variable(s) in the relation."] - - val dup_vs = - (case duplicates (op =) vs of - [] => [] - | dups => [qty_str ^ "duplicate type variable(s) on the lhs: " ^ commas_quote dups]) - - val extra_rty_tfrees = - (case subtract (op =) vs rty_tfreesT of - [] => [] - | extras => [qty_str ^ "extra type variable(s) on the lhs: " ^ commas_quote extras]) - - val extra_rel_tfrees = - (case subtract (op =) vs rel_tfrees of - [] => [] - | extras => [qty_str ^ "extra type variable(s) in the relation: " ^ commas_quote extras]) - - val illegal_rel_frees = - (case rel_frees of - [] => [] - | xs => [qty_str ^ "illegal variable(s) in the relation: " ^ commas_quote xs]) - - val errs = illegal_rel_vars @ dup_vs @ extra_rty_tfrees @ extra_rel_tfrees @ illegal_rel_frees -in - if null errs then () else error (cat_lines errs) -end - -(* check for existence of map functions *) -fun map_check ctxt (_, (rty, _)) = -let - val thy = ProofContext.theory_of ctxt - - fun map_check_aux rty warns = - case rty of - Type (_, []) => warns - | Type (s, _) => if maps_defined thy s then warns else s::warns - | _ => warns - - val warns = map_check_aux rty [] -in - if null warns then () - else warning ("No map function defined for " ^ commas warns ^ - ". This will cause problems later on.") -end - - - -(*** interface and syntax setup ***) - - -(* the ML-interface takes a list of 5-tuples consisting of: - - - the name of the quotient type - - its free type variables (first argument) - - its mixfix annotation - - the type to be quotient - - the relation according to which the type is quotient - - it opens a proof-state in which one has to show that the - relations are equivalence relations -*) - -fun quotient_type quot_list lthy = -let - (* sanity check *) - val _ = List.app sanity_check quot_list - val _ = List.app (map_check lthy) quot_list - - fun mk_goal (rty, rel) = - let - val equivp_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool} - in - HOLogic.mk_Trueprop (Const (@{const_name equivp}, equivp_ty) $ rel) - end - - val goals = map (mk_goal o snd) quot_list - - fun after_qed thms lthy = - fold_map add_quotient_type (quot_list ~~ thms) lthy |> snd -in - theorem after_qed goals lthy -end - -fun quotient_type_cmd specs lthy = -let - fun parse_spec ((((vs, qty_name), mx), rty_str), rel_str) lthy = - let - val rty = Syntax.read_typ lthy rty_str - val lthy1 = Variable.declare_typ rty lthy - val rel = - Syntax.parse_term lthy1 rel_str - |> Syntax.type_constraint (rty --> rty --> @{typ bool}) - |> Syntax.check_term lthy1 - val (newT, lthy2) = lthy1 - |> Typedecl.typedecl_wrt [rel] (qty_name, vs, mx) - ||> Variable.declare_term rel - - (*val Type (full_qty_name, type_args) = newT - val vs' = map Term.dest_TFree type_args*) - in - (((vs, qty_name, mx), (rty, rel)), lthy2) - end - - val (spec', lthy') = fold_map parse_spec specs lthy -in - quotient_type spec' lthy' -end - -val quotspec_parser = - OuterParse.and_list1 - ((OuterParse.type_args -- OuterParse.binding) -- - OuterParse.opt_mixfix -- (OuterParse.$$$ "=" |-- OuterParse.typ) -- - (OuterParse.$$$ "/" |-- OuterParse.term)) - -val _ = OuterKeyword.keyword "/" - -val _ = - OuterSyntax.local_theory_to_proof "quotient_type" - "quotient type definitions (require equivalence proofs)" - OuterKeyword.thy_goal (quotspec_parser >> quotient_type_cmd) - -end; (* structure *) diff -r a6f3e1b08494 -r b6873d123f9b Attic/Unused.thy --- a/Attic/Unused.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -(*notation ( output) "prop" ("#_" [1000] 1000) *) -notation ( output) "Trueprop" ("#_" [1000] 1000) - -syntax - "Bex1_rel" :: "id \ ('a \ 'a \ bool) \ ('a \ bool) \ bool" ("(3\!!_\_./ _)" [0, 0, 10] 10) -translations - "\!!x\A. P" == "Bex1_rel A (%x. P)" - -(*interpretation code *) -(*val bindd = ((Binding.make ("", Position.none)), ([]: Attrib.src list)) - val ((_, [eqn1pre]), lthy5) = Variable.import true [ABS_def] lthy4; - val eqn1i = Thm.prop_of (symmetric eqn1pre) - val ((_, [eqn2pre]), lthy6) = Variable.import true [REP_def] lthy5; - val eqn2i = Thm.prop_of (symmetric eqn2pre) - - val exp_morphism = ProofContext.export_morphism lthy6 (ProofContext.init (ProofContext.theory_of lthy6)); - val exp_term = Morphism.term exp_morphism; - val exp = Morphism.thm exp_morphism; - - val mthd = Method.SIMPLE_METHOD ((rtac quot_thm 1) THEN - ALLGOALS (simp_tac (HOL_basic_ss addsimps [(symmetric (exp ABS_def)), (symmetric (exp REP_def))]))) - val mthdt = Method.Basic (fn _ => mthd) - val bymt = Proof.global_terminal_proof (mthdt, NONE) - val exp_i = [(@{const_name QUOT_TYPE}, ((("QUOT_TYPE_I_" ^ (Binding.name_of qty_name)), true), - Expression.Named [("R", rel), ("Abs", abs), ("Rep", rep) ]))]*) - -(*||> Local_Theory.theory (fn thy => - let - val global_eqns = map exp_term [eqn2i, eqn1i]; - (* Not sure if the following context should not be used *) - val (global_eqns2, lthy7) = Variable.import_terms true global_eqns lthy6; - val global_eqns3 = map (fn t => (bindd, t)) global_eqns2; - in ProofContext.theory_of (bymt (Expression.interpretation (exp_i, []) global_eqns3 thy)) end)*) diff -r a6f3e1b08494 -r b6873d123f9b Attic/UnusedQuotBase.thy --- a/Attic/UnusedQuotBase.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,90 +0,0 @@ -lemma in_fun: - shows "x \ ((f ---> g) s) = g (f x \ s)" - by (simp add: mem_def) - -lemma respects_thm: - shows "Respects (R1 ===> R2) f = (\x y. R1 x y \ R2 (f x) (f y))" - unfolding Respects_def - by (simp add: expand_fun_eq) - -lemma respects_rep_abs: - assumes a: "Quotient R1 Abs1 Rep1" - and b: "Respects (R1 ===> R2) f" - and c: "R1 x x" - shows "R2 (f (Rep1 (Abs1 x))) (f x)" - using a b[simplified respects_thm] c unfolding Quotient_def - by blast - -lemma respects_mp: - assumes a: "Respects (R1 ===> R2) f" - and b: "R1 x y" - shows "R2 (f x) (f y)" - using a b unfolding Respects_def - by simp - -lemma respects_o: - assumes a: "Respects (R2 ===> R3) f" - and b: "Respects (R1 ===> R2) g" - shows "Respects (R1 ===> R3) (f o g)" - using a b unfolding Respects_def - by simp - -lemma fun_rel_eq_rel: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - shows "(R1 ===> R2) f g = ((Respects (R1 ===> R2) f) \ (Respects (R1 ===> R2) g) - \ ((Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g))" - using fun_quotient[OF q1 q2] unfolding Respects_def Quotient_def expand_fun_eq - by blast - -lemma let_babs: - "v \ r \ Let v (Babs r lam) = Let v lam" - by (simp add: Babs_def) - -lemma fun_rel_equals: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - and r1: "Respects (R1 ===> R2) f" - and r2: "Respects (R1 ===> R2) g" - shows "((Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g) = (\x y. R1 x y \ R2 (f x) (g y))" - apply(rule_tac iffI) - apply(rule)+ - apply (rule apply_rsp'[of "R1" "R2"]) - apply(subst Quotient_rel[OF fun_quotient[OF q1 q2]]) - apply auto - using fun_quotient[OF q1 q2] r1 r2 unfolding Quotient_def Respects_def - apply (metis let_rsp q1) - apply (metis fun_rel_eq_rel let_rsp q1 q2 r2) - using r1 unfolding Respects_def expand_fun_eq - apply(simp (no_asm_use)) - apply(metis Quotient_rel[OF q2] Quotient_rel_rep[OF q1]) - done - -(* ask Peter: fun_rel_IMP used twice *) -lemma fun_rel_IMP2: - assumes q1: "Quotient R1 Abs1 Rep1" - and q2: "Quotient R2 Abs2 Rep2" - and r1: "Respects (R1 ===> R2) f" - and r2: "Respects (R1 ===> R2) g" - and a: "(Rep1 ---> Abs2) f = (Rep1 ---> Abs2) g" - shows "R1 x y \ R2 (f x) (g y)" - using q1 q2 r1 r2 a - by (simp add: fun_rel_equals) - -lemma lambda_rep_abs_rsp: - assumes r1: "\r r'. R1 r r' \R1 r (Rep1 (Abs1 r'))" - and r2: "\r r'. R2 r r' \R2 r (Rep2 (Abs2 r'))" - shows "(R1 ===> R2) f1 f2 \ (R1 ===> R2) f1 ((Abs1 ---> Rep2) ((Rep1 ---> Abs2) f2))" - using r1 r2 by auto - -(* We use id_simps which includes id_apply; so these 2 theorems can be removed *) -lemma id_prs: - assumes q: "Quotient R Abs Rep" - shows "Abs (id (Rep e)) = id e" - using Quotient_abs_rep[OF q] by auto - -lemma id_rsp: - assumes q: "Quotient R Abs Rep" - and a: "R e1 e2" - shows "R (id e1) (id e2)" - using a by auto diff -r a6f3e1b08494 -r b6873d123f9b Attic/UnusedQuotMain.thy --- a/Attic/UnusedQuotMain.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3 +0,0 @@ -(* Could go in the programming tutorial *) - -ML_prf {* val qtm = #concl (fst (Subgoal.focus @{context} 1 (#goal (Isar.goal ())))) *} diff -r a6f3e1b08494 -r b6873d123f9b Attic/isar-keywords-quot.el --- a/Attic/isar-keywords-quot.el Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,616 +0,0 @@ -;; -;; Keyword classification tables for Isabelle/Isar. -;; Generated from HOL-Nominal-Quot + HOL-Nominal + HOL + Pure-ProofGeneral + Pure. -;; *** DO NOT EDIT *** DO NOT EDIT *** DO NOT EDIT *** -;; - -(defconst isar-keywords-major - '("\\." - "\\.\\." - "Isabelle\\.command" - "Isar\\.begin_document" - "Isar\\.define_command" - "Isar\\.edit_document" - "Isar\\.end_document" - "ML" - "ML_command" - "ML_prf" - "ML_val" - "ProofGeneral\\.inform_file_processed" - "ProofGeneral\\.inform_file_retracted" - "ProofGeneral\\.kill_proof" - "ProofGeneral\\.pr" - "ProofGeneral\\.process_pgip" - "ProofGeneral\\.restart" - "ProofGeneral\\.undo" - "abbreviation" - "also" - "apply" - "apply_end" - "arities" - "assume" - "atom_decl" - "atp_info" - "atp_kill" - "atp_messages" - "atp_minimize" - "attribute_setup" - "ax_specification" - "axclass" - "axiomatization" - "axioms" - "back" - "by" - "cannot_undo" - "case" - "cd" - "chapter" - "class" - "class_deps" - "classes" - "classrel" - "code_abort" - "code_class" - "code_const" - "code_datatype" - "code_deps" - "code_include" - "code_instance" - "code_library" - "code_module" - "code_modulename" - "code_monad" - "code_pred" - "code_reflect" - "code_reserved" - "code_thms" - "code_type" - "coinductive" - "coinductive_set" - "commit" - "constdefs" - "consts" - "consts_code" - "context" - "corollary" - "datatype" - "declaration" - "declare" - "def" - "default_sort" - "defer" - "defer_recdef" - "definition" - "defs" - "disable_pr" - "display_drafts" - "done" - "enable_pr" - "end" - "equivariance" - "exit" - "export_code" - "extract" - "extract_type" - "finalconsts" - "finally" - "find_consts" - "find_theorems" - "fix" - "from" - "full_prf" - "fun" - "function" - "global" - "guess" - "have" - "header" - "help" - "hence" - "hide_class" - "hide_const" - "hide_fact" - "hide_type" - "inductive" - "inductive_cases" - "inductive_set" - "init_toplevel" - "instance" - "instantiation" - "interpret" - "interpretation" - "judgment" - "kill" - "kill_thy" - "lemma" - "lemmas" - "let" - "linear_undo" - "local" - "local_setup" - "locale" - "method_setup" - "moreover" - "next" - "nitpick" - "nitpick_params" - "no_notation" - "no_syntax" - "no_translations" - "nominal_datatype" - "nominal_inductive" - "nominal_inductive2" - "nominal_primrec" - "nonterminals" - "normal_form" - "notation" - "note" - "obtain" - "oops" - "oracle" - "overloading" - "parse_ast_translation" - "parse_translation" - "pr" - "prefer" - "presume" - "pretty_setmargin" - "prf" - "primrec" - "print_abbrevs" - "print_antiquotations" - "print_ast_translation" - "print_atps" - "print_attributes" - "print_binds" - "print_cases" - "print_claset" - "print_classes" - "print_codeproc" - "print_codesetup" - "print_commands" - "print_configs" - "print_context" - "print_drafts" - "print_facts" - "print_induct_rules" - "print_interps" - "print_locale" - "print_locales" - "print_maps" - "print_methods" - "print_orders" - "print_quotconsts" - "print_quotients" - "print_rules" - "print_simpset" - "print_statement" - "print_syntax" - "print_theorems" - "print_theory" - "print_trans_rules" - "print_translation" - "proof" - "prop" - "prove" - "pwd" - "qed" - "quickcheck" - "quickcheck_params" - "quit" - "quotient_definition" - "quotient_type" - "realizability" - "realizers" - "recdef" - "recdef_tc" - "record" - "refute" - "refute_params" - "remove_thy" - "rep_datatype" - "repdef" - "schematic_corollary" - "schematic_lemma" - "schematic_theorem" - "sect" - "section" - "setup" - "show" - "simproc_setup" - "sledgehammer" - "sledgehammer_params" - "smt_status" - "sorry" - "specification" - "subclass" - "sublocale" - "subsect" - "subsection" - "subsubsect" - "subsubsection" - "syntax" - "term" - "termination" - "text" - "text_raw" - "then" - "theorem" - "theorems" - "theory" - "thm" - "thm_deps" - "thus" - "thy_deps" - "touch_thy" - "translations" - "txt" - "txt_raw" - "typ" - "typed_print_translation" - "typedecl" - "typedef" - "types" - "types_code" - "ultimately" - "undo" - "undos_proof" - "unfolding" - "unused_thms" - "use" - "use_thy" - "using" - "value" - "values" - "welcome" - "with" - "{" - "}")) - -(defconst isar-keywords-minor - '("advanced" - "and" - "as" - "assumes" - "attach" - "avoids" - "begin" - "binder" - "congs" - "constrains" - "contains" - "defines" - "file" - "fixes" - "for" - "hints" - "identifier" - "if" - "imports" - "in" - "infix" - "infixl" - "infixr" - "is" - "module_name" - "monos" - "morphisms" - "notes" - "obtains" - "open" - "output" - "overloaded" - "permissive" - "pervasive" - "shows" - "structure" - "unchecked" - "uses" - "where")) - -(defconst isar-keywords-control - '("Isabelle\\.command" - "Isar\\.begin_document" - "Isar\\.define_command" - "Isar\\.edit_document" - "Isar\\.end_document" - "ProofGeneral\\.inform_file_processed" - "ProofGeneral\\.inform_file_retracted" - "ProofGeneral\\.kill_proof" - "ProofGeneral\\.process_pgip" - "ProofGeneral\\.restart" - "ProofGeneral\\.undo" - "cannot_undo" - "exit" - "init_toplevel" - "kill" - "linear_undo" - "quit" - "undo" - "undos_proof")) - -(defconst isar-keywords-diag - '("ML_command" - "ML_val" - "ProofGeneral\\.pr" - "atp_info" - "atp_kill" - "atp_messages" - "atp_minimize" - "cd" - "class_deps" - "code_deps" - "code_thms" - "commit" - "disable_pr" - "display_drafts" - "enable_pr" - "export_code" - "find_consts" - "find_theorems" - "full_prf" - "header" - "help" - "kill_thy" - "nitpick" - "normal_form" - "pr" - "pretty_setmargin" - "prf" - "print_abbrevs" - "print_antiquotations" - "print_atps" - "print_attributes" - "print_binds" - "print_cases" - "print_claset" - "print_classes" - "print_codeproc" - "print_codesetup" - "print_commands" - "print_configs" - "print_context" - "print_drafts" - "print_facts" - "print_induct_rules" - "print_interps" - "print_locale" - "print_locales" - "print_maps" - "print_methods" - "print_orders" - "print_quotconsts" - "print_quotients" - "print_rules" - "print_simpset" - "print_statement" - "print_syntax" - "print_theorems" - "print_theory" - "print_trans_rules" - "prop" - "pwd" - "quickcheck" - "refute" - "remove_thy" - "sledgehammer" - "term" - "thm" - "thm_deps" - "thy_deps" - "touch_thy" - "typ" - "unused_thms" - "use_thy" - "value" - "values" - "welcome")) - -(defconst isar-keywords-theory-begin - '("theory")) - -(defconst isar-keywords-theory-switch - '()) - -(defconst isar-keywords-theory-end - '("end")) - -(defconst isar-keywords-theory-heading - '("chapter" - "section" - "subsection" - "subsubsection")) - -(defconst isar-keywords-theory-decl - '("ML" - "abbreviation" - "arities" - "atom_decl" - "attribute_setup" - "axclass" - "axiomatization" - "axioms" - "class" - "classes" - "classrel" - "code_abort" - "code_class" - "code_const" - "code_datatype" - "code_include" - "code_instance" - "code_library" - "code_module" - "code_modulename" - "code_monad" - "code_reflect" - "code_reserved" - "code_type" - "coinductive" - "coinductive_set" - "constdefs" - "consts" - "consts_code" - "context" - "datatype" - "declaration" - "declare" - "defaultsort" - "defer_recdef" - "definition" - "defs" - "equivariance" - "extract" - "extract_type" - "finalconsts" - "fun" - "global" - "hide_class" - "hide_const" - "hide_fact" - "hide_type" - "inductive" - "inductive_set" - "instantiation" - "judgment" - "lemmas" - "local" - "local_setup" - "locale" - "method_setup" - "nitpick_params" - "no_notation" - "no_syntax" - "no_translations" - "nominal_datatype" - "nonterminals" - "notation" - "oracle" - "overloading" - "parse_ast_translation" - "parse_translation" - "primrec" - "print_ast_translation" - "print_translation" - "quickcheck_params" - "quotient_definition" - "realizability" - "realizers" - "recdef" - "record" - "refute_params" - "setup" - "simproc_setup" - "sledgehammer_params" - "statespace" - "syntax" - "text" - "text_raw" - "theorems" - "translations" - "typed_print_translation" - "typedecl" - "types" - "types_code" - "use")) - -(defconst isar-keywords-theory-script - '("inductive_cases")) - -(defconst isar-keywords-theory-goal - '("ax_specification" - "code_pred" - "corollary" - "function" - "instance" - "interpretation" - "lemma" - "nominal_inductive" - "nominal_inductive2" - "nominal_primrec" - "prove" - "quotient_type" - "recdef_tc" - "rep_datatype" - "schematic_corollary" - "schematic_lemma" - "schematic_theorem" - "specification" - "subclass" - "sublocale" - "termination" - "theorem" - "typedef")) - -(defconst isar-keywords-qed - '("\\." - "\\.\\." - "by" - "done" - "sorry")) - -(defconst isar-keywords-qed-block - '("qed")) - -(defconst isar-keywords-qed-global - '("oops")) - -(defconst isar-keywords-proof-heading - '("sect" - "subsect" - "subsubsect")) - -(defconst isar-keywords-proof-goal - '("have" - "hence" - "interpret")) - -(defconst isar-keywords-proof-block - '("next" - "proof")) - -(defconst isar-keywords-proof-open - '("{")) - -(defconst isar-keywords-proof-close - '("}")) - -(defconst isar-keywords-proof-chain - '("finally" - "from" - "then" - "ultimately" - "with")) - -(defconst isar-keywords-proof-decl - '("ML_prf" - "also" - "let" - "moreover" - "note" - "txt" - "txt_raw" - "unfolding" - "using")) - -(defconst isar-keywords-proof-asm - '("assume" - "case" - "def" - "fix" - "presume")) - -(defconst isar-keywords-proof-asm-goal - '("guess" - "obtain" - "show" - "thus")) - -(defconst isar-keywords-proof-script - '("apply" - "apply_end" - "back" - "defer" - "prefer")) - -(provide 'isar-keywords) diff -r a6f3e1b08494 -r b6873d123f9b ESOP-Paper/Appendix.thy --- a/ESOP-Paper/Appendix.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,135 +0,0 @@ -(*<*) -theory Appendix -imports "../Nominal/Nominal2" "~~/src/HOL/Library/LaTeXsugar" -begin - -consts - fv :: "'a \ 'b" - abs_set :: "'a \ 'b \ 'c" - alpha_bn :: "'a \ 'a \ bool" - abs_set2 :: "'a \ perm \ 'b \ 'c" - Abs_dist :: "'a \ 'b \ 'c" - Abs_print :: "'a \ 'b \ 'c" - -definition - "equal \ (op =)" - -notation (latex output) - swap ("'(_ _')" [1000, 1000] 1000) and - fresh ("_ # _" [51, 51] 50) and - fresh_star ("_ #\<^sup>* _" [51, 51] 50) and - supp ("supp _" [78] 73) and - uminus ("-_" [78] 73) and - If ("if _ then _ else _" 10) and - alpha_set ("_ \\<^raw:\,\raisebox{-1pt}{\makebox[0mm][l]{$_{\textit{set}}$}}>\<^bsup>_, _, _\<^esup> _") and - alpha_lst ("_ \\<^raw:\,\raisebox{-1pt}{\makebox[0mm][l]{$_{\textit{list}}$}}>\<^bsup>_, _, _\<^esup> _") and - alpha_res ("_ \\<^raw:\,\raisebox{-1pt}{\makebox[0mm][l]{$_{\textit{res}}$}}>\<^bsup>_, _, _\<^esup> _") and - abs_set ("_ \\<^raw:{$\,_{\textit{abs\_set}}$}> _") and - abs_set2 ("_ \\<^raw:\raisebox{-1pt}{\makebox[0mm][l]{$\,_{\textit{list}}$}}>\<^bsup>_\<^esup> _") and - fv ("fa'(_')" [100] 100) and - equal ("=") and - alpha_abs_set ("_ \\<^raw:{$\,_{\textit{abs\_set}}$}> _") and - Abs_set ("[_]\<^bsub>set\<^esub>._" [20, 101] 999) and - Abs_lst ("[_]\<^bsub>list\<^esub>._") and - Abs_dist ("[_]\<^bsub>#list\<^esub>._") and - Abs_res ("[_]\<^bsub>res\<^esub>._") and - Abs_print ("_\<^bsub>set\<^esub>._") and - Cons ("_::_" [78,77] 73) and - supp_set ("aux _" [1000] 10) and - alpha_bn ("_ \bn _") - -consts alpha_trm ::'a -consts fa_trm :: 'a -consts alpha_trm2 ::'a -consts fa_trm2 :: 'a -consts ast :: 'a -consts ast' :: 'a -notation (latex output) - alpha_trm ("\\<^bsub>trm\<^esub>") and - fa_trm ("fa\<^bsub>trm\<^esub>") and - alpha_trm2 ("'(\\<^bsub>assn\<^esub>, \\<^bsub>trm\<^esub>')") and - fa_trm2 ("'(fa\<^bsub>assn\<^esub>, fa\<^bsub>trm\<^esub>')") and - ast ("'(as, t')") and - ast' ("'(as', t\ ')") - -(*>*) - -text {* -\appendix -\section*{Appendix} - - Details for one case in Theorem \ref{suppabs}, which the reader might like to ignore. - By definition of the abstraction type @{text "abs_set"} - we have - % - \begin{equation}\label{abseqiff} - @{thm (lhs) Abs_eq_iff(1)[where bs="as" and cs="bs", no_vars]} \;\;\text{if and only if}\;\; - @{thm (rhs) Abs_eq_iff(1)[where bs="as" and cs="bs", no_vars]} - \end{equation} - - \noindent - and also - - \begin{equation}\label{absperm} - @{thm permute_Abs(1)[no_vars]}% - \end{equation} - - \noindent - The second fact derives from the definition of permutations acting on pairs - and $\alpha$-equivalence being equivariant. With these two facts at our disposal, we can show - the following lemma about swapping two atoms in an abstraction. - - \begin{lemma} - @{thm[mode=IfThen] Abs_swap1(1)[where bs="as", no_vars]} - \end{lemma} - - \begin{proof} - This lemma is straightforward using \eqref{abseqiff} and observing that - the assumptions give us @{term "(a \ b) \ (supp x - as) = (supp x - as)"}. - Moreover @{text supp} and set difference are equivariant (see \cite{HuffmanUrban10}). - \end{proof} - - \noindent - Assuming that @{text "x"} has finite support, this lemma together - with \eqref{absperm} allows us to show - - \begin{equation}\label{halfone} - @{thm Abs_supports(1)[no_vars]} - \end{equation} - - \noindent - which gives us ``one half'' of - Theorem~\ref{suppabs} (the notion of supports is defined in \cite{HuffmanUrban10}). - The ``other half'' is a bit more involved. To establish - it, we use a trick from \cite{Pitts04} and first define an auxiliary - function @{text aux}, taking an abstraction as argument: - @{thm supp_set.simps[THEN eq_reflection, no_vars]}. - - We can show that - @{text "aux"} is equivariant (since @{term "p \ (supp x - as) = (supp (p \ x)) - (p \ as)"}) - and therefore has empty support. - This in turn means - - \begin{center} - @{text "supp (aux ([as]\<^bsub>set\<^esub>. x)) \ supp ([as]\<^bsub>set\<^esub> x)"} - \end{center} - - \noindent - Assuming @{term "supp x - as"} is a finite set, - we further obtain - - \begin{equation}\label{halftwo} - @{thm (concl) Abs_supp_subset1(1)[no_vars]} - \end{equation} - - \noindent - since for finite sets of atoms, @{text "bs"}, we have - @{thm (concl) supp_finite_atom_set[where S="bs", no_vars]}. - Finally, taking \eqref{halfone} and \eqref{halftwo} together establishes - Theorem~\ref{suppabs}. - -*} - -(*<*) -end -(*>*) diff -r a6f3e1b08494 -r b6873d123f9b ESOP-Paper/Paper.thy --- a/ESOP-Paper/Paper.thy Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2394 +0,0 @@ - -(*<*) -theory Paper -imports "../Nominal/Nominal2" - "~~/src/HOL/Library/LaTeXsugar" -begin - -consts - fv :: "'a \ 'b" - abs_set :: "'a \ 'b \ 'c" - alpha_bn :: "'a \ 'a \ bool" - abs_set2 :: "'a \ perm \ 'b \ 'c" - Abs_dist :: "'a \ 'b \ 'c" - Abs_print :: "'a \ 'b \ 'c" - -definition - "equal \ (op =)" - -notation (latex output) - swap ("'(_ _')" [1000, 1000] 1000) and - fresh ("_ # _" [51, 51] 50) and - fresh_star ("_ #\<^sup>* _" [51, 51] 50) and - supp ("supp _" [78] 73) and - uminus ("-_" [78] 73) and - If ("if _ then _ else _" 10) and - alpha_set ("_ \\<^raw:\,\raisebox{-1pt}{\makebox[0mm][l]{$_{\textit{set}}$}}>\<^bsup>_, _, _\<^esup> _") and - alpha_lst ("_ \\<^raw:\,\raisebox{-1pt}{\makebox[0mm][l]{$_{\textit{list}}$}}>\<^bsup>_, _, _\<^esup> _") and - alpha_res ("_ \\<^raw:\,\raisebox{-1pt}{\makebox[0mm][l]{$_{\textit{set+}}$}}>\<^bsup>_, _, _\<^esup> _") and - abs_set ("_ \\<^raw:{$\,_{\textit{abs\_set}}$}> _") and - abs_set2 ("_ \\<^raw:\raisebox{-1pt}{\makebox[0mm][l]{$\,_{\textit{list}}$}}>\<^bsup>_\<^esup> _") and - fv ("fa'(_')" [100] 100) and - equal ("=") and - alpha_abs_set ("_ \\<^raw:{$\,_{\textit{abs\_set}}$}> _") and - Abs_set ("[_]\<^bsub>set\<^esub>._" [20, 101] 999) and - Abs_lst ("[_]\<^bsub>list\<^esub>._") and - Abs_dist ("[_]\<^bsub>#list\<^esub>._") and - Abs_res ("[_]\<^bsub>set+\<^esub>._") and - Abs_print ("_\<^bsub>set\<^esub>._") and - Cons ("_::_" [78,77] 73) and - supp_set ("aux _" [1000] 10) and - alpha_bn ("_ \bn _") - -consts alpha_trm ::'a -consts fa_trm :: 'a -consts alpha_trm2 ::'a -consts fa_trm2 :: 'a -consts ast :: 'a -consts ast' :: 'a -notation (latex output) - alpha_trm ("\\<^bsub>trm\<^esub>") and - fa_trm ("fa\<^bsub>trm\<^esub>") and - alpha_trm2 ("'(\\<^bsub>assn\<^esub>, \\<^bsub>trm\<^esub>')") and - fa_trm2 ("'(fa\<^bsub>assn\<^esub>, fa\<^bsub>trm\<^esub>')") and - ast ("'(as, t')") and - ast' ("'(as', t\ ')") - -(*>*) - - -section {* Introduction *} - -text {* - - So far, Nominal Isabelle provided a mechanism for constructing - $\alpha$-equated terms, for example lambda-terms, - @{text "t ::= x | t t | \x. t"}, - where free and bound variables have names. For such $\alpha$-equated terms, - Nominal Isabelle derives automatically a reasoning infrastructure that has - been used successfully in formalisations of an equivalence checking - algorithm for LF \cite{UrbanCheneyBerghofer08}, Typed - Scheme~\cite{TobinHochstadtFelleisen08}, several calculi for concurrency - \cite{BengtsonParow09} and a strong normalisation result for cut-elimination - in classical logic \cite{UrbanZhu08}. It has also been used by Pollack for - formalisations in the locally-nameless approach to binding - \cite{SatoPollack10}. - - However, Nominal Isabelle has fared less well in a formalisation of - the algorithm W \cite{UrbanNipkow09}, where types and type-schemes are, - respectively, of the form - % - \begin{equation}\label{tysch} - \begin{array}{l} - @{text "T ::= x | T \ T"}\hspace{9mm} - @{text "S ::= \{x\<^isub>1,\, x\<^isub>n}. T"} - \end{array} - \end{equation} - % - \noindent - and the @{text "\"}-quantification binds a finite (possibly empty) set of - type-variables. While it is possible to implement this kind of more general - binders by iterating single binders, this leads to a rather clumsy - formalisation of W. - %The need of iterating single binders is also one reason - %why Nominal Isabelle - % and similar theorem provers that only provide - %mechanisms for binding single variables - %has not fared extremely well with the - %more advanced tasks in the POPLmark challenge \cite{challenge05}, because - %also there one would like to bind multiple variables at once. - - Binding multiple variables has interesting properties that cannot be captured - easily by iterating single binders. For example in the case of type-schemes we do not - want to make a distinction about the order of the bound variables. Therefore - we would like to regard the first pair of type-schemes as $\alpha$-equivalent, - but assuming that @{text x}, @{text y} and @{text z} are distinct variables, - the second pair should \emph{not} be $\alpha$-equivalent: - % - \begin{equation}\label{ex1} - @{text "\{x, y}. x \ y \\<^isub>\ \{y, x}. y \ x"}\hspace{10mm} - @{text "\{x, y}. x \ y \\<^isub>\ \{z}. z \ z"} - \end{equation} - % - \noindent - Moreover, we like to regard type-schemes as $\alpha$-equivalent, if they differ - only on \emph{vacuous} binders, such as - % - \begin{equation}\label{ex3} - @{text "\{x}. x \ y \\<^isub>\ \{x, z}. x \ y"} - \end{equation} - % - \noindent - where @{text z} does not occur freely in the type. In this paper we will - give a general binding mechanism and associated notion of $\alpha$-equivalence - that can be used to faithfully represent this kind of binding in Nominal - Isabelle. - %The difficulty of finding the right notion for $\alpha$-equivalence - %can be appreciated in this case by considering that the definition given by - %Leroy in \cite{Leroy92} is incorrect (it omits a side-condition). - - However, the notion of $\alpha$-equivalence that is preserved by vacuous - binders is not always wanted. For example in terms like - % - \begin{equation}\label{one} - @{text "\ x = 3 \ y = 2 \ x - y \"} - \end{equation} - - \noindent - we might not care in which order the assignments @{text "x = 3"} and - \mbox{@{text "y = 2"}} are given, but it would be often unusual to regard - \eqref{one} as $\alpha$-equivalent with - % - \begin{center} - @{text "\ x = 3 \ y = 2 \ z = foo \ x - y \"} - \end{center} - % - \noindent - Therefore we will also provide a separate binding mechanism for cases in - which the order of binders does not matter, but the ``cardinality'' of the - binders has to agree. - - However, we found that this is still not sufficient for dealing with - language constructs frequently occurring in programming language - research. For example in @{text "\"}s containing patterns like - % - \begin{equation}\label{two} - @{text "\ (x, y) = (3, 2) \ x - y \"} - \end{equation} - % - \noindent - we want to bind all variables from the pattern inside the body of the - $\mathtt{let}$, but we also care about the order of these variables, since - we do not want to regard \eqref{two} as $\alpha$-equivalent with - % - \begin{center} - @{text "\ (y, x) = (3, 2) \ x - y \"} - \end{center} - % - \noindent - As a result, we provide three general binding mechanisms each of which binds - multiple variables at once, and let the user chose which one is intended - in a formalisation. - %%when formalising a term-calculus. - - By providing these general binding mechanisms, however, we have to work - around a problem that has been pointed out by Pottier \cite{Pottier06} and - Cheney \cite{Cheney05}: in @{text "\"}-constructs of the form - % - \begin{center} - @{text "\ x\<^isub>1 = t\<^isub>1 \ \ \ x\<^isub>n = t\<^isub>n \ s \"} - \end{center} - % - \noindent - we care about the - information that there are as many bound variables @{text - "x\<^isub>i"} as there are @{text "t\<^isub>i"}. We lose this information if - we represent the @{text "\"}-constructor by something like - % - \begin{center} - @{text "\ (\x\<^isub>1\x\<^isub>n . s) [t\<^isub>1,\,t\<^isub>n]"} - \end{center} - % - \noindent - where the notation @{text "\_ . _"} indicates that the list of @{text - "x\<^isub>i"} becomes bound in @{text s}. In this representation the term - \mbox{@{text "\ (\x . s) [t\<^isub>1, t\<^isub>2]"}} is a perfectly legal - instance, but the lengths of the two lists do not agree. To exclude such - terms, additional predicates about well-formed terms are needed in order to - ensure that the two lists are of equal length. This can result in very messy - reasoning (see for example~\cite{BengtsonParow09}). To avoid this, we will - allow type specifications for @{text "\"}s as follows - % - \begin{center} - \begin{tabular}{r@ {\hspace{2mm}}r@ {\hspace{2mm}}cl} - @{text trm} & @{text "::="} & @{text "\"} - & @{text "|"} @{text "\ as::assn s::trm"}\hspace{2mm} - \isacommand{bind} @{text "bn(as)"} \isacommand{in} @{text "s"}\\%%%[1mm] - @{text assn} & @{text "::="} & @{text "\"} - & @{text "|"} @{text "\ name trm assn"} - \end{tabular} - \end{center} - % - \noindent - where @{text assn} is an auxiliary type representing a list of assignments - and @{text bn} an auxiliary function identifying the variables to be bound - by the @{text "\"}. This function can be defined by recursion over @{text - assn} as follows - % - \begin{center} - @{text "bn(\) ="} @{term "{}"} \hspace{5mm} - @{text "bn(\ x t as) = {x} \ bn(as)"} - \end{center} - % - \noindent - The scope of the binding is indicated by labels given to the types, for - example @{text "s::trm"}, and a binding clause, in this case - \isacommand{bind} @{text "bn(as)"} \isacommand{in} @{text "s"}. This binding - clause states that all the names the function @{text - "bn(as)"} returns should be bound in @{text s}. This style of specifying terms and bindings is heavily - inspired by the syntax of the Ott-tool \cite{ott-jfp}. - - %Though, Ott - %has only one binding mode, namely the one where the order of - %binders matters. Consequently, type-schemes with binding sets - %of names cannot be modelled in Ott. - - However, we will not be able to cope with all specifications that are - allowed by Ott. One reason is that Ott lets the user specify ``empty'' - types like @{text "t ::= t t | \x. t"} - where no clause for variables is given. Arguably, such specifications make - some sense in the context of Coq's type theory (which Ott supports), but not - at all in a HOL-based environment where every datatype must have a non-empty - set-theoretic model. % \cite{Berghofer99}. - - Another reason is that we establish the reasoning infrastructure - for $\alpha$-\emph{equated} terms. In contrast, Ott produces a reasoning - infrastructure in Isabelle/HOL for - \emph{non}-$\alpha$-equated, or ``raw'', terms. While our $\alpha$-equated terms - and the raw terms produced by Ott use names for bound variables, - there is a key difference: working with $\alpha$-equated terms means, for example, - that the two type-schemes - - \begin{center} - @{text "\{x}. x \ y = \{x, z}. x \ y"} - \end{center} - - \noindent - are not just $\alpha$-equal, but actually \emph{equal}! As a result, we can - only support specifications that make sense on the level of $\alpha$-equated - terms (offending specifications, which for example bind a variable according - to a variable bound somewhere else, are not excluded by Ott, but we have - to). - - %Our insistence on reasoning with $\alpha$-equated terms comes from the - %wealth of experience we gained with the older version of Nominal Isabelle: - %for non-trivial properties, reasoning with $\alpha$-equated terms is much - %easier than reasoning with raw terms. The fundamental reason for this is - %that the HOL-logic underlying Nominal Isabelle allows us to replace - %``equals-by-equals''. In contrast, replacing - %``$\alpha$-equals-by-$\alpha$-equals'' in a representation based on raw terms - %requires a lot of extra reasoning work. - - Although in informal settings a reasoning infrastructure for $\alpha$-equated - terms is nearly always taken for granted, establishing it automatically in - Isabelle/HOL is a rather non-trivial task. For every - specification we will need to construct type(s) containing as elements the - $\alpha$-equated terms. To do so, we use the standard HOL-technique of defining - a new type by identifying a non-empty subset of an existing type. The - construction we perform in Isabelle/HOL can be illustrated by the following picture: - % - \begin{center} - \begin{tikzpicture}[scale=0.89] - %\draw[step=2mm] (-4,-1) grid (4,1); - - \draw[very thick] (0.7,0.4) circle (4.25mm); - \draw[rounded corners=1mm, very thick] ( 0.0,-0.8) rectangle ( 1.8, 0.9); - \draw[rounded corners=1mm, very thick] (-1.95,0.85) rectangle (-2.85,-0.05); - - \draw (-2.0, 0.845) -- (0.7,0.845); - \draw (-2.0,-0.045) -- (0.7,-0.045); - - \draw ( 0.7, 0.4) node {\footnotesize\begin{tabular}{@ {}c@ {}}$\alpha$-\\[-1mm]clas.\end{tabular}}; - \draw (-2.4, 0.4) node {\footnotesize\begin{tabular}{@ {}c@ {}}$\alpha$-eq.\\[-1mm]terms\end{tabular}}; - \draw (1.8, 0.48) node[right=-0.1mm] - {\footnotesize\begin{tabular}{@ {}l@ {}}existing\\[-1mm] type\\ (sets of raw terms)\end{tabular}}; - \draw (0.9, -0.35) node {\footnotesize\begin{tabular}{@ {}l@ {}}non-empty\\[-1mm]subset\end{tabular}}; - \draw (-3.25, 0.55) node {\footnotesize\begin{tabular}{@ {}l@ {}}new\\[-1mm]type\end{tabular}}; - - \draw[<->, very thick] (-1.8, 0.3) -- (-0.1,0.3); - \draw (-0.95, 0.3) node[above=0mm] {\footnotesize{}isomorphism}; - - \end{tikzpicture} - \end{center} - % - \noindent - We take as the starting point a definition of raw terms (defined as a - datatype in Isabelle/HOL); then identify the $\alpha$-equivalence classes in - the type of sets of raw terms according to our $\alpha$-equivalence relation, - and finally define the new type as these $\alpha$-equivalence classes - (non-emptiness is satisfied whenever the raw terms are definable as datatype - in Isabelle/HOL and our relation for $\alpha$-equivalence is - an equivalence relation). - - %The fact that we obtain an isomorphism between the new type and the - %non-empty subset shows that the new type is a faithful representation of - %$\alpha$-equated terms. That is not the case for example for terms using the - %locally nameless representation of binders \cite{McKinnaPollack99}: in this - %representation there are ``junk'' terms that need to be excluded by - %reasoning about a well-formedness predicate. - - The problem with introducing a new type in Isabelle/HOL is that in order to - be useful, a reasoning infrastructure needs to be ``lifted'' from the - underlying subset to the new type. This is usually a tricky and arduous - task. To ease it, we re-implemented in Isabelle/HOL \cite{KaliszykUrban11} the quotient package - described by Homeier \cite{Homeier05} for the HOL4 system. This package - allows us to lift definitions and theorems involving raw terms to - definitions and theorems involving $\alpha$-equated terms. For example if we - define the free-variable function over raw lambda-terms - - \begin{center} - @{text "fv(x) = {x}"}\hspace{8mm} - @{text "fv(t\<^isub>1 t\<^isub>2) = fv(t\<^isub>1) \ fv(t\<^isub>2)"}\hspace{8mm} - @{text "fv(\x.t) = fv(t) - {x}"} - \end{center} - - \noindent - then with the help of the quotient package we can obtain a function @{text "fv\<^sup>\"} - operating on quotients, or $\alpha$-equivalence classes of lambda-terms. This - lifted function is characterised by the equations - - \begin{center} - @{text "fv\<^sup>\(x) = {x}"}\hspace{8mm} - @{text "fv\<^sup>\(t\<^isub>1 t\<^isub>2) = fv\<^sup>\(t\<^isub>1) \ fv\<^sup>\(t\<^isub>2)"}\hspace{8mm} - @{text "fv\<^sup>\(\x.t) = fv\<^sup>\(t) - {x}"} - \end{center} - - \noindent - (Note that this means also the term-constructors for variables, applications - and lambda are lifted to the quotient level.) This construction, of course, - only works if $\alpha$-equivalence is indeed an equivalence relation, and the - ``raw'' definitions and theorems are respectful w.r.t.~$\alpha$-equivalence. - %For example, we will not be able to lift a bound-variable function. Although - %this function can be defined for raw terms, it does not respect - %$\alpha$-equivalence and therefore cannot be lifted. - To sum up, every lifting - of theorems to the quotient level needs proofs of some respectfulness - properties (see \cite{Homeier05}). In the paper we show that we are able to - automate these proofs and as a result can automatically establish a reasoning - infrastructure for $\alpha$-equated terms.\smallskip - - %The examples we have in mind where our reasoning infrastructure will be - %helpful includes the term language of Core-Haskell. This term language - %involves patterns that have lists of type-, coercion- and term-variables, - %all of which are bound in @{text "\"}-expressions. In these - %patterns we do not know in advance how many variables need to - %be bound. Another example is the specification of SML, which includes - %includes bindings as in type-schemes.\medskip - - \noindent - {\bf Contributions:} We provide three new definitions for when terms - involving general binders are $\alpha$-equivalent. These definitions are - inspired by earlier work of Pitts \cite{Pitts04}. By means of automatic - proofs, we establish a reasoning infrastructure for $\alpha$-equated - terms, including properties about support, freshness and equality - conditions for $\alpha$-equated terms. We are also able to derive strong - induction principles that have the variable convention already built in. - The method behind our specification of general binders is taken - from the Ott-tool, but we introduce crucial restrictions, and also extensions, so - that our specifications make sense for reasoning about $\alpha$-equated terms. - The main improvement over Ott is that we introduce three binding modes - (only one is present in Ott), provide formalised definitions for $\alpha$-equivalence and - for free variables of our terms, and also derive a reasoning infrastructure - for our specifications from ``first principles''. - - - %\begin{figure} - %\begin{boxedminipage}{\linewidth} - %%\begin{center} - %\begin{tabular}{r@ {\hspace{1mm}}r@ {\hspace{2mm}}l} - %\multicolumn{3}{@ {}l}{Type Kinds}\\ - %@{text "\"} & @{text "::="} & @{text "\ | \\<^isub>1 \ \\<^isub>2"}\smallskip\\ - %\multicolumn{3}{@ {}l}{Coercion Kinds}\\ - %@{text "\"} & @{text "::="} & @{text "\\<^isub>1 \ \\<^isub>2"}\smallskip\\ - %\multicolumn{3}{@ {}l}{Types}\\ - %@{text "\"} & @{text "::="} & @{text "a | T | \\<^isub>1 \\<^isub>2 | S\<^isub>n"}$\;\overline{@{text "\"}}$@{text "\<^sup>n"} - %@{text "| \a:\. \ | \ \ \"}\smallskip\\ - %\multicolumn{3}{@ {}l}{Coercion Types}\\ - %@{text "\"} & @{text "::="} & @{text "c | C | \\<^isub>1 \\<^isub>2 | S\<^isub>n"}$\;\overline{@{text "\"}}$@{text "\<^sup>n"} - %@{text "| \c:\. \ | \ \ \ "}\\ - %& @{text "|"} & @{text "refl \ | sym \ | \\<^isub>1 \ \\<^isub>2 | \ @ \ | left \ | right \"}\\ - %& @{text "|"} & @{text "\\<^isub>1 \ \\<^isub>2 | rightc \ | leftc \ | \\<^isub>1 \ \\<^isub>2"}\smallskip\\ - %\multicolumn{3}{@ {}l}{Terms}\\ - %@{text "e"} & @{text "::="} & @{text "x | K | \a:\. e | \c:\. e | e \ | e \"}\\ - %& @{text "|"} & @{text "\x:\. e | e\<^isub>1 e\<^isub>2 | \ x:\ = e\<^isub>1 \ e\<^isub>2"}\\ - %& @{text "|"} & @{text "\ e\<^isub>1 \"}$\;\overline{@{text "p \ e\<^isub>2"}}$ @{text "| e \ \"}\smallskip\\ - %\multicolumn{3}{@ {}l}{Patterns}\\ - %@{text "p"} & @{text "::="} & @{text "K"}$\;\overline{@{text "a:\"}}\;\overline{@{text "c:\"}}\;\overline{@{text "x:\"}}$\smallskip\\ - %\multicolumn{3}{@ {}l}{Constants}\\ - %& @{text C} & coercion constants\\ - %& @{text T} & value type constructors\\ - %& @{text "S\<^isub>n"} & n-ary type functions (which need to be fully applied)\\ - %& @{text K} & data constructors\smallskip\\ - %\multicolumn{3}{@ {}l}{Variables}\\ - %& @{text a} & type variables\\ - %& @{text c} & coercion variables\\ - %& @{text x} & term variables\\ - %\end{tabular} - %\end{center} - %\end{boxedminipage} - %\caption{The System @{text "F\<^isub>C"} - %\cite{CoreHaskell}, also often referred to as \emph{Core-Haskell}. In this - %version of @{text "F\<^isub>C"} we made a modification by separating the - %grammars for type kinds and coercion kinds, as well as for types and coercion - %types. For this paper the interesting term-constructor is @{text "\"}, - %which binds multiple type-, coercion- and term-variables.\label{corehas}} - %\end{figure} -*} - -section {* A Short Review of the Nominal Logic Work *} - -text {* - At its core, Nominal Isabelle is an adaption of the nominal logic work by - Pitts \cite{Pitts03}. This adaptation for Isabelle/HOL is described in - \cite{HuffmanUrban10} (including proofs). We shall briefly review this work - to aid the description of what follows. - - Two central notions in the nominal logic work are sorted atoms and - sort-respecting permutations of atoms. We will use the letters @{text "a, - b, c, \"} to stand for atoms and @{text "p, q, \"} to stand for - permutations. The purpose of atoms is to represent variables, be they bound or free. - %The sorts of atoms can be used to represent different kinds of - %variables, such as the term-, coercion- and type-variables in Core-Haskell. - It is assumed that there is an infinite supply of atoms for each - sort. In the interest of brevity, we shall restrict ourselves - in what follows to only one sort of atoms. - - Permutations are bijective functions from atoms to atoms that are - the identity everywhere except on a finite number of atoms. There is a - two-place permutation operation written - @{text "_ \ _ :: perm \ \ \ \"} - where the generic type @{text "\"} is the type of the object - over which the permutation - acts. In Nominal Isabelle, the identity permutation is written as @{term "0::perm"}, - the composition of two permutations @{term p} and @{term q} as \mbox{@{term "p + q"}}, - and the inverse permutation of @{term p} as @{text "- p"}. The permutation - operation is defined over the type-hierarchy \cite{HuffmanUrban10}; - for example permutations acting on products, lists, sets, functions and booleans are - given by: - % - %\begin{equation}\label{permute} - %\mbox{\begin{tabular}{@ {}c@ {\hspace{10mm}}c@ {}} - %\begin{tabular}{@ {}l@ {}} - %@{thm permute_prod.simps[no_vars, THEN eq_reflection]}\\[2mm] - %@{thm permute_list.simps(1)[no_vars, THEN eq_reflection]}\\ - %@{thm permute_list.simps(2)[no_vars, THEN eq_reflection]}\\ - %\end{tabular} & - %\begin{tabular}{@ {}l@ {}} - %@{thm permute_set_eq[no_vars, THEN eq_reflection]}\\ - %@{text "p \ f \ \x. p \ (f (- p \ x))"}\\ - %@{thm permute_bool_def[no_vars, THEN eq_reflection]} - %\end{tabular} - %\end{tabular}} - %\end{equation} - % - \begin{center} - \mbox{\begin{tabular}{@ {}c@ {\hspace{4mm}}c@ {\hspace{4mm}}c@ {}} - \begin{tabular}{@ {}l@ {}} - @{thm permute_prod.simps[no_vars, THEN eq_reflection]}\\ - @{thm permute_bool_def[no_vars, THEN eq_reflection]} - \end{tabular} & - \begin{tabular}{@ {}l@ {}} - @{thm permute_list.simps(1)[no_vars, THEN eq_reflection]}\\ - @{thm permute_list.simps(2)[no_vars, THEN eq_reflection]}\\ - \end{tabular} & - \begin{tabular}{@ {}l@ {}} - @{thm permute_set_eq[no_vars, THEN eq_reflection]}\\ - @{text "p \ f \ \x. p \ (f (- p \ x))"}\\ - \end{tabular} - \end{tabular}} - \end{center} - - \noindent - Concrete permutations in Nominal Isabelle are built up from swappings, - written as \mbox{@{text "(a b)"}}, which are permutations that behave - as follows: - % - \begin{center} - @{text "(a b) = \c. if a = c then b else if b = c then a else c"} - \end{center} - - The most original aspect of the nominal logic work of Pitts is a general - definition for the notion of the ``set of free variables of an object @{text - "x"}''. This notion, written @{term "supp x"}, is general in the sense that - it applies not only to lambda-terms ($\alpha$-equated or not), but also to lists, - products, sets and even functions. The definition depends only on the - permutation operation and on the notion of equality defined for the type of - @{text x}, namely: - % - \begin{equation}\label{suppdef} - @{thm supp_def[no_vars, THEN eq_reflection]} - \end{equation} - - \noindent - There is also the derived notion for when an atom @{text a} is \emph{fresh} - for an @{text x}, defined as @{thm fresh_def[no_vars]}. - We use for sets of atoms the abbreviation - @{thm (lhs) fresh_star_def[no_vars]}, defined as - @{thm (rhs) fresh_star_def[no_vars]}. - A striking consequence of these definitions is that we can prove - without knowing anything about the structure of @{term x} that - swapping two fresh atoms, say @{text a} and @{text b}, leaves - @{text x} unchanged, namely if @{text "a \ x"} and @{text "b \ x"} - then @{term "(a \ b) \ x = x"}. - % - %\begin{myproperty}\label{swapfreshfresh} - %@{thm[mode=IfThen] swap_fresh_fresh[no_vars]} - %\end{myproperty} - % - %While often the support of an object can be relatively easily - %described, for example for atoms, products, lists, function applications, - %booleans and permutations as follows - %% - %\begin{center} - %\begin{tabular}{c@ {\hspace{10mm}}c} - %\begin{tabular}{rcl} - %@{term "supp a"} & $=$ & @{term "{a}"}\\ - %@{term "supp (x, y)"} & $=$ & @{term "supp x \ supp y"}\\ - %@{term "supp []"} & $=$ & @{term "{}"}\\ - %@{term "supp (x#xs)"} & $=$ & @{term "supp x \ supp xs"}\\ - %\end{tabular} - %& - %\begin{tabular}{rcl} - %@{text "supp (f x)"} & @{text "\"} & @{term "supp f \ supp x"}\\ - %@{term "supp b"} & $=$ & @{term "{}"}\\ - %@{term "supp p"} & $=$ & @{term "{a. p \ a \ a}"} - %\end{tabular} - %\end{tabular} - %\end{center} - % - %\noindent - %in some cases it can be difficult to characterise the support precisely, and - %only an approximation can be established (as for functions above). - % - %Reasoning about - %such approximations can be simplified with the notion \emph{supports}, defined - %as follows: - % - %\begin{definition} - %A set @{text S} \emph{supports} @{text x} if for all atoms @{text a} and @{text b} - %not in @{text S} we have @{term "(a \ b) \ x = x"}. - %\end{definition} - % - %\noindent - %The main point of @{text supports} is that we can establish the following - %two properties. - % - %\begin{myproperty}\label{supportsprop} - %Given a set @{text "as"} of atoms. - %{\it (i)} @{thm[mode=IfThen] supp_is_subset[where S="as", no_vars]} - %{\it (ii)} @{thm supp_supports[no_vars]}. - %\end{myproperty} - % - %Another important notion in the nominal logic work is \emph{equivariance}. - %For a function @{text f}, say of type @{text "\ \ \"}, to be equivariant - %it is required that every permutation leaves @{text f} unchanged, that is - %% - %\begin{equation}\label{equivariancedef} - %@{term "\p. p \ f = f"} - %\end{equation} - % - %\noindent or equivalently that a permutation applied to the application - %@{text "f x"} can be moved to the argument @{text x}. That means for equivariant - %functions @{text f}, we have for all permutations @{text p}: - %% - %\begin{equation}\label{equivariance} - %@{text "p \ f = f"} \;\;\;\textit{if and only if}\;\;\; - %@{text "p \ (f x) = f (p \ x)"} - %\end{equation} - % - %\noindent - %From property \eqref{equivariancedef} and the definition of @{text supp}, we - %can easily deduce that equivariant functions have empty support. There is - %also a similar notion for equivariant relations, say @{text R}, namely the property - %that - %% - %\begin{center} - %@{text "x R y"} \;\;\textit{implies}\;\; @{text "(p \ x) R (p \ y)"} - %\end{center} - % - %Using freshness, the nominal logic work provides us with general means for renaming - %binders. - % - %\noindent - While in the older version of Nominal Isabelle, we used extensively - %Property~\ref{swapfreshfresh} - this property to rename single binders, it %%this property - proved too unwieldy for dealing with multiple binders. For such binders the - following generalisations turned out to be easier to use. - - \begin{myproperty}\label{supppermeq} - @{thm[mode=IfThen] supp_perm_eq[no_vars]} - \end{myproperty} - - \begin{myproperty}\label{avoiding} - For a finite set @{text as} and a finitely supported @{text x} with - @{term "as \* x"} and also a finitely supported @{text c}, there - exists a permutation @{text p} such that @{term "(p \ as) \* c"} and - @{term "supp x \* p"}. - \end{myproperty} - - \noindent - The idea behind the second property is that given a finite set @{text as} - of binders (being bound, or fresh, in @{text x} is ensured by the - assumption @{term "as \* x"}), then there exists a permutation @{text p} such that - the renamed binders @{term "p \ as"} avoid @{text c} (which can be arbitrarily chosen - as long as it is finitely supported) and also @{text "p"} does not affect anything - in the support of @{text x} (that is @{term "supp x \* p"}). The last - fact and Property~\ref{supppermeq} allow us to ``rename'' just the binders - @{text as} in @{text x}, because @{term "p \ x = x"}. - - Most properties given in this section are described in detail in \cite{HuffmanUrban10} - and all are formalised in Isabelle/HOL. In the next sections we will make - extensive use of these properties in order to define $\alpha$-equivalence in - the presence of multiple binders. -*} - - -section {* General Bindings\label{sec:binders} *} - -text {* - In Nominal Isabelle, the user is expected to write down a specification of a - term-calculus and then a reasoning infrastructure is automatically derived - from this specification (remember that Nominal Isabelle is a definitional - extension of Isabelle/HOL, which does not introduce any new axioms). - - In order to keep our work with deriving the reasoning infrastructure - manageable, we will wherever possible state definitions and perform proofs - on the ``user-level'' of Isabelle/HOL, as opposed to write custom ML-code. % that - %generates them anew for each specification. - To that end, we will consider - first pairs @{text "(as, x)"} of type @{text "(atom set) \ \"}. These pairs - are intended to represent the abstraction, or binding, of the set of atoms @{text - "as"} in the body @{text "x"}. - - The first question we have to answer is when two pairs @{text "(as, x)"} and - @{text "(bs, y)"} are $\alpha$-equivalent? (For the moment we are interested in - the notion of $\alpha$-equivalence that is \emph{not} preserved by adding - vacuous binders.) To answer this question, we identify four conditions: {\it (i)} - given a free-atom function @{text "fa"} of type \mbox{@{text "\ \ atom - set"}}, then @{text x} and @{text y} need to have the same set of free - atoms; moreover there must be a permutation @{text p} such that {\it - (ii)} @{text p} leaves the free atoms of @{text x} and @{text y} unchanged, but - {\it (iii)} ``moves'' their bound names so that we obtain modulo a relation, - say \mbox{@{text "_ R _"}}, two equivalent terms. We also require that {\it (iv)} - @{text p} makes the sets of abstracted atoms @{text as} and @{text bs} equal. The - requirements {\it (i)} to {\it (iv)} can be stated formally as the conjunction of: - % - \begin{equation}\label{alphaset} - \begin{array}{@ {\hspace{10mm}}l@ {\hspace{5mm}}l@ {\hspace{10mm}}l@ {\hspace{5mm}}l} - \multicolumn{4}{l}{@{term "(as, x) \set R fa p (bs, y)"}\hspace{2mm}@{text "\"}}\\[1mm] - \mbox{\it (i)} & @{term "fa(x) - as = fa(y) - bs"} & - \mbox{\it (iii)} & @{text "(p \ x) R y"} \\ - \mbox{\it (ii)} & @{term "(fa(x) - as) \* p"} & - \mbox{\it (iv)} & @{term "(p \ as) = bs"} \\ - \end{array} - \end{equation} - % - \noindent - Note that this relation depends on the permutation @{text - "p"}; $\alpha$-equivalence between two pairs is then the relation where we - existentially quantify over this @{text "p"}. Also note that the relation is - dependent on a free-atom function @{text "fa"} and a relation @{text - "R"}. The reason for this extra generality is that we will use - $\approx_{\,\textit{set}}$ for both ``raw'' terms and $\alpha$-equated terms. In - the latter case, @{text R} will be replaced by equality @{text "="} and we - will prove that @{text "fa"} is equal to @{text "supp"}. - - The definition in \eqref{alphaset} does not make any distinction between the - order of abstracted atoms. If we want this, then we can define $\alpha$-equivalence - for pairs of the form \mbox{@{text "(as, x)"}} with type @{text "(atom list) \ \"} - as follows - % - \begin{equation}\label{alphalist} - \begin{array}{@ {\hspace{10mm}}l@ {\hspace{5mm}}l@ {\hspace{10mm}}l@ {\hspace{5mm}}l} - \multicolumn{4}{l}{@{term "(as, x) \lst R fa p (bs, y)"}\hspace{2mm}@{text "\"}}\\[1mm] - \mbox{\it (i)} & @{term "fa(x) - (set as) = fa(y) - (set bs)"} & - \mbox{\it (iii)} & @{text "(p \ x) R y"}\\ - \mbox{\it (ii)} & @{term "(fa(x) - set as) \* p"} & - \mbox{\it (iv)} & @{term "(p \ as) = bs"}\\ - \end{array} - \end{equation} - % - \noindent - where @{term set} is the function that coerces a list of atoms into a set of atoms. - Now the last clause ensures that the order of the binders matters (since @{text as} - and @{text bs} are lists of atoms). - - If we do not want to make any difference between the order of binders \emph{and} - also allow vacuous binders, that means \emph{restrict} names, then we keep sets of binders, but drop - condition {\it (iv)} in \eqref{alphaset}: - % - \begin{equation}\label{alphares} - \begin{array}{@ {\hspace{10mm}}l@ {\hspace{5mm}}l@ {\hspace{10mm}}l@ {\hspace{5mm}}l} - \multicolumn{2}{l}{@{term "(as, x) \res R fa p (bs, y)"}\hspace{2mm}@{text "\"}}\\[1mm] - \mbox{\it (i)} & @{term "fa(x) - as = fa(y) - bs"} & - \mbox{\it (iii)} & @{text "(p \ x) R y"}\\ - \mbox{\it (ii)} & @{term "(fa(x) - as) \* p"}\\ - \end{array} - \end{equation} - - It might be useful to consider first some examples how these definitions - of $\alpha$-equivalence pan out in practice. For this consider the case of - abstracting a set of atoms over types (as in type-schemes). We set - @{text R} to be the usual equality @{text "="} and for @{text "fa(T)"} we - define - % - \begin{center} - @{text "fa(x) = {x}"} \hspace{5mm} @{text "fa(T\<^isub>1 \ T\<^isub>2) = fa(T\<^isub>1) \ fa(T\<^isub>2)"} - \end{center} - - \noindent - Now recall the examples shown in \eqref{ex1} and - \eqref{ex3}. It can be easily checked that @{text "({x, y}, x \ y)"} and - @{text "({y, x}, y \ x)"} are $\alpha$-equivalent according to - $\approx_{\,\textit{set}}$ and $\approx_{\,\textit{set+}}$ by taking @{text p} to - be the swapping @{term "(x \ y)"}. In case of @{text "x \ y"}, then @{text - "([x, y], x \ y)"} $\not\approx_{\,\textit{list}}$ @{text "([y, x], x \ y)"} - since there is no permutation that makes the lists @{text "[x, y]"} and - @{text "[y, x]"} equal, and also leaves the type \mbox{@{text "x \ y"}} - unchanged. Another example is @{text "({x}, x)"} $\approx_{\,\textit{set+}}$ - @{text "({x, y}, x)"} which holds by taking @{text p} to be the identity - permutation. However, if @{text "x \ y"}, then @{text "({x}, x)"} - $\not\approx_{\,\textit{set}}$ @{text "({x, y}, x)"} since there is no - permutation that makes the sets @{text "{x}"} and @{text "{x, y}"} equal - (similarly for $\approx_{\,\textit{list}}$). It can also relatively easily be - shown that all three notions of $\alpha$-equivalence coincide, if we only - abstract a single atom. - - In the rest of this section we are going to introduce three abstraction - types. For this we define - % - \begin{equation} - @{term "abs_set (as, x) (bs, x) \ \p. alpha_set (as, x) equal supp p (bs, x)"} - \end{equation} - - \noindent - (similarly for $\approx_{\,\textit{abs\_set+}}$ - and $\approx_{\,\textit{abs\_list}}$). We can show that these relations are equivalence - relations. %% and equivariant. - - \begin{lemma}\label{alphaeq} - The relations $\approx_{\,\textit{abs\_set}}$, $\approx_{\,\textit{abs\_list}}$ - and $\approx_{\,\textit{abs\_set+}}$ are equivalence relations. %, and if - %@{term "abs_set (as, x) (bs, y)"} then also - %@{term "abs_set (p \ as, p \ x) (p \ bs, p \ y)"} (similarly for the other two relations). - \end{lemma} - - \begin{proof} - Reflexivity is by taking @{text "p"} to be @{text "0"}. For symmetry we have - a permutation @{text p} and for the proof obligation take @{term "-p"}. In case - of transitivity, we have two permutations @{text p} and @{text q}, and for the - proof obligation use @{text "q + p"}. All conditions are then by simple - calculations. - \end{proof} - - \noindent - This lemma allows us to use our quotient package for introducing - new types @{text "\ abs_set"}, @{text "\ abs_set+"} and @{text "\ abs_list"} - representing $\alpha$-equivalence classes of pairs of type - @{text "(atom set) \ \"} (in the first two cases) and of type @{text "(atom list) \ \"} - (in the third case). - The elements in these types will be, respectively, written as - % - %\begin{center} - @{term "Abs_set as x"}, %\hspace{5mm} - @{term "Abs_res as x"} and %\hspace{5mm} - @{term "Abs_lst as x"}, - %\end{center} - % - %\noindent - indicating that a set (or list) of atoms @{text as} is abstracted in @{text x}. We will - call the types \emph{abstraction types} and their elements - \emph{abstractions}. The important property we need to derive is the support of - abstractions, namely: - - \begin{theorem}[Support of Abstractions]\label{suppabs} - Assuming @{text x} has finite support, then - - \begin{center} - \begin{tabular}{l} - @{thm (lhs) supp_Abs(1)[no_vars]} $\;\;=\;\;$ - @{thm (lhs) supp_Abs(2)[no_vars]} $\;\;=\;\;$ @{thm (rhs) supp_Abs(2)[no_vars]}, and\\ - @{thm (lhs) supp_Abs(3)[where bs="bs", no_vars]} $\;\;=\;\;$ - @{thm (rhs) supp_Abs(3)[where bs="bs", no_vars]} - \end{tabular} - \end{center} - \end{theorem} - - \noindent - This theorem states that the bound names do not appear in the support. - For brevity we omit the proof and again refer the reader to - our formalisation in Isabelle/HOL. - - %\noindent - %Below we will show the first equation. The others - %follow by similar arguments. By definition of the abstraction type @{text "abs_set"} - %we have - %% - %\begin{equation}\label{abseqiff} - %@{thm (lhs) Abs_eq_iff(1)[where bs="as" and bs'="bs", no_vars]} \;\;\text{if and only if}\;\; - %@{thm (rhs) Abs_eq_iff(1)[where bs="as" and bs'="bs", no_vars]} - %\end{equation} - % - %\noindent - %and also - % - %\begin{equation}\label{absperm} - %%@%{%thm %permute_Abs[no_vars]}% - %\end{equation} - - %\noindent - %The second fact derives from the definition of permutations acting on pairs - %\eqref{permute} and $\alpha$-equivalence being equivariant - %(see Lemma~\ref{alphaeq}). With these two facts at our disposal, we can show - %the following lemma about swapping two atoms in an abstraction. - % - %\begin{lemma} - %@{thm[mode=IfThen] Abs_swap1(1)[where bs="as", no_vars]} - %\end{lemma} - % - %\begin{proof} - %This lemma is straightforward using \eqref{abseqiff} and observing that - %the assumptions give us @{term "(a \ b) \ (supp x - as) = (supp x - as)"}. - %Moreover @{text supp} and set difference are equivariant (see \cite{HuffmanUrban10}). - %\end{proof} - % - %\noindent - %Assuming that @{text "x"} has finite support, this lemma together - %with \eqref{absperm} allows us to show - % - %\begin{equation}\label{halfone} - %@{thm Abs_supports(1)[no_vars]} - %\end{equation} - % - %\noindent - %which by Property~\ref{supportsprop} gives us ``one half'' of - %Theorem~\ref{suppabs}. The ``other half'' is a bit more involved. To establish - %it, we use a trick from \cite{Pitts04} and first define an auxiliary - %function @{text aux}, taking an abstraction as argument: - %@{thm supp_set.simps[THEN eq_reflection, no_vars]}. - % - %Using the second equation in \eqref{equivariance}, we can show that - %@{text "aux"} is equivariant (since @{term "p \ (supp x - as) = (supp (p \ x)) - (p \ as)"}) - %and therefore has empty support. - %This in turn means - % - %\begin{center} - %@{term "supp (supp_gen (Abs_set as x)) \ supp (Abs_set as x)"} - %\end{center} - % - %\noindent - %using \eqref{suppfun}. Assuming @{term "supp x - as"} is a finite set, - %we further obtain - % - %\begin{equation}\label{halftwo} - %@{thm (concl) Abs_supp_subset1(1)[no_vars]} - %\end{equation} - % - %\noindent - %since for finite sets of atoms, @{text "bs"}, we have - %@{thm (concl) supp_finite_atom_set[where S="bs", no_vars]}. - %Finally, taking \eqref{halfone} and \eqref{halftwo} together establishes - %Theorem~\ref{suppabs}. - - The method of first considering abstractions of the - form @{term "Abs_set as x"} etc is motivated by the fact that - we can conveniently establish at the Isabelle/HOL level - properties about them. It would be - laborious to write custom ML-code that derives automatically such properties - for every term-constructor that binds some atoms. Also the generality of - the definitions for $\alpha$-equivalence will help us in the next sections. -*} - -section {* Specifying General Bindings\label{sec:spec} *} - -text {* - Our choice of syntax for specifications is influenced by the existing - datatype package of Isabelle/HOL %\cite{Berghofer99} - and by the syntax of the - Ott-tool \cite{ott-jfp}. For us a specification of a term-calculus is a - collection of (possibly mutual recursive) type declarations, say @{text - "ty\\<^isub>1, \, ty\\<^isub>n"}, and an associated collection of - binding functions, say @{text "bn\\<^isub>1, \, bn\\<^isub>m"}. The - syntax in Nominal Isabelle for such specifications is roughly as follows: - % - \begin{equation}\label{scheme} - \mbox{\begin{tabular}{@ {}p{2.5cm}l} - type \mbox{declaration part} & - $\begin{cases} - \mbox{\small\begin{tabular}{l} - \isacommand{nominal\_datatype} @{text "ty\\<^isub>1 = \"}\\ - \isacommand{and} @{text "ty\\<^isub>2 = \"}\\ - \raisebox{2mm}{$\ldots$}\\[-2mm] - \isacommand{and} @{text "ty\\<^isub>n = \"}\\ - \end{tabular}} - \end{cases}$\\ - binding \mbox{function part} & - $\begin{cases} - \mbox{\small\begin{tabular}{l} - \isacommand{binder} @{text "bn\\<^isub>1"} \isacommand{and} \ldots \isacommand{and} @{text "bn\\<^isub>m"}\\ - \isacommand{where}\\ - \raisebox{2mm}{$\ldots$}\\[-2mm] - \end{tabular}} - \end{cases}$\\ - \end{tabular}} - \end{equation} - - \noindent - Every type declaration @{text ty}$^\alpha_{1..n}$ consists of a collection of - term-constructors, each of which comes with a list of labelled - types that stand for the types of the arguments of the term-constructor. - For example a term-constructor @{text "C\<^sup>\"} might be specified with - - \begin{center} - @{text "C\<^sup>\ label\<^isub>1::ty"}$'_1$ @{text "\ label\<^isub>l::ty"}$'_l\;\;$ @{text "binding_clauses"} - \end{center} - - \noindent - whereby some of the @{text ty}$'_{1..l}$ %%(or their components) - can be contained - in the collection of @{text ty}$^\alpha_{1..n}$ declared in - \eqref{scheme}. - In this case we will call the corresponding argument a - \emph{recursive argument} of @{text "C\<^sup>\"}. - %The types of such recursive - %arguments need to satisfy a ``positivity'' - %restriction, which ensures that the type has a set-theoretic semantics - %\cite{Berghofer99}. - The labels - annotated on the types are optional. Their purpose is to be used in the - (possibly empty) list of \emph{binding clauses}, which indicate the binders - and their scope in a term-constructor. They come in three \emph{modes}: - % - \begin{center} - \begin{tabular}{@ {}l@ {}} - \isacommand{bind} {\it binders} \isacommand{in} {\it bodies}\;\;\;\, - \isacommand{bind (set)} {\it binders} \isacommand{in} {\it bodies}\;\;\;\, - \isacommand{bind (set+)} {\it binders} \isacommand{in} {\it bodies} - \end{tabular} - \end{center} - % - \noindent - The first mode is for binding lists of atoms (the order of binders matters); - the second is for sets of binders (the order does not matter, but the - cardinality does) and the last is for sets of binders (with vacuous binders - preserving $\alpha$-equivalence). As indicated, the labels in the ``\isacommand{in}-part'' of a binding - clause will be called \emph{bodies}; the - ``\isacommand{bind}-part'' will be called \emph{binders}. In contrast to - Ott, we allow multiple labels in binders and bodies. - - %For example we allow - %binding clauses of the form: - % - %\begin{center} - %\begin{tabular}{@ {}ll@ {}} - %@{text "Foo\<^isub>1 x::name y::name t::trm s::trm"} & - % \isacommand{bind} @{text "x y"} \isacommand{in} @{text "t s"}\\ - %@{text "Foo\<^isub>2 x::name y::name t::trm s::trm"} & - % \isacommand{bind} @{text "x y"} \isacommand{in} @{text "t"}, - % \isacommand{bind} @{text "x y"} \isacommand{in} @{text "s"}\\ - %\end{tabular} - %\end{center} - - \noindent - %Similarly for the other binding modes. - %Interestingly, in case of \isacommand{bind (set)} - %and \isacommand{bind (set+)} the binding clauses above will make a difference to the semantics - %of the specifications (the corresponding $\alpha$-equivalence will differ). We will - %show this later with an example. - - There are also some restrictions we need to impose on our binding clauses in comparison to - the ones of Ott. The - main idea behind these restrictions is that we obtain a sensible notion of - $\alpha$-equivalence where it is ensured that within a given scope an - atom occurrence cannot be both bound and free at the same time. The first - restriction is that a body can only occur in - \emph{one} binding clause of a term constructor (this ensures that the bound - atoms of a body cannot be free at the same time by specifying an - alternative binder for the same body). - - For binders we distinguish between - \emph{shallow} and \emph{deep} binders. Shallow binders are just - labels. The restriction we need to impose on them is that in case of - \isacommand{bind (set)} and \isacommand{bind (set+)} the labels must either - refer to atom types or to sets of atom types; in case of \isacommand{bind} - the labels must refer to atom types or lists of atom types. Two examples for - the use of shallow binders are the specification of lambda-terms, where a - single name is bound, and type-schemes, where a finite set of names is - bound: - - \begin{center}\small - \begin{tabular}{@ {}c@ {\hspace{7mm}}c@ {}} - \begin{tabular}{@ {}l} - \isacommand{nominal\_datatype} @{text lam} $=$\\ - \hspace{2mm}\phantom{$\mid$}~@{text "Var name"}\\ - \hspace{2mm}$\mid$~@{text "App lam lam"}\\ - \hspace{2mm}$\mid$~@{text "Lam x::name t::lam"}~~\isacommand{bind} @{text x} \isacommand{in} @{text t}\\ - \end{tabular} & - \begin{tabular}{@ {}l@ {}} - \isacommand{nominal\_datatype}~@{text ty} $=$\\ - \hspace{5mm}\phantom{$\mid$}~@{text "TVar name"}\\ - \hspace{5mm}$\mid$~@{text "TFun ty ty"}\\ - \isacommand{and}~@{text "tsc = All xs::(name fset) T::ty"}~~% - \isacommand{bind (set+)} @{text xs} \isacommand{in} @{text T}\\ - \end{tabular} - \end{tabular} - \end{center} - - \noindent - In these specifications @{text "name"} refers to an atom type, and @{text - "fset"} to the type of finite sets. - Note that for @{text lam} it does not matter which binding mode we use. The - reason is that we bind only a single @{text name}. However, having - \isacommand{bind (set)} or \isacommand{bind} in the second case makes a - difference to the semantics of the specification (which we will define in the next section). - - - A \emph{deep} binder uses an auxiliary binding function that ``picks'' out - the atoms in one argument of the term-constructor, which can be bound in - other arguments and also in the same argument (we will call such binders - \emph{recursive}, see below). The binding functions are - expected to return either a set of atoms (for \isacommand{bind (set)} and - \isacommand{bind (set+)}) or a list of atoms (for \isacommand{bind}). They can - be defined by recursion over the corresponding type; the equations - must be given in the binding function part of the scheme shown in - \eqref{scheme}. For example a term-calculus containing @{text "Let"}s with - tuple patterns might be specified as: - % - \begin{equation}\label{letpat} - \mbox{\small% - \begin{tabular}{l} - \isacommand{nominal\_datatype} @{text trm} $=$\\ - \hspace{5mm}\phantom{$\mid$}~@{term "Var name"}\\ - \hspace{5mm}$\mid$~@{term "App trm trm"}\\ - \hspace{5mm}$\mid$~@{text "Lam x::name t::trm"} - \;\;\isacommand{bind} @{text x} \isacommand{in} @{text t}\\ - \hspace{5mm}$\mid$~@{text "Let p::pat trm t::trm"} - \;\;\isacommand{bind} @{text "bn(p)"} \isacommand{in} @{text t}\\ - \isacommand{and} @{text pat} $=$ - @{text PNil} - $\mid$~@{text "PVar name"} - $\mid$~@{text "PTup pat pat"}\\ - \isacommand{binder}~@{text "bn::pat \ atom list"}\\ - \isacommand{where}~@{text "bn(PNil) = []"}\\ - \hspace{5mm}$\mid$~@{text "bn(PVar x) = [atom x]"}\\ - \hspace{5mm}$\mid$~@{text "bn(PTup p\<^isub>1 p\<^isub>2) = bn(p\<^isub>1) @ bn(p\<^isub>2)"}\smallskip\\ - \end{tabular}} - \end{equation} - % - \noindent - In this specification the function @{text "bn"} determines which atoms of - the pattern @{text p} are bound in the argument @{text "t"}. Note that in the - second-last @{text bn}-clause the function @{text "atom"} coerces a name - into the generic atom type of Nominal Isabelle \cite{HuffmanUrban10}. This - allows us to treat binders of different atom type uniformly. - - As said above, for deep binders we allow binding clauses such as - % - %\begin{center} - %\begin{tabular}{ll} - @{text "Bar p::pat t::trm"} %%%& - \isacommand{bind} @{text "bn(p)"} \isacommand{in} @{text "p t"} %%\\ - %\end{tabular} - %\end{center} - % - %\noindent - where the argument of the deep binder also occurs in the body. We call such - binders \emph{recursive}. To see the purpose of such recursive binders, - compare ``plain'' @{text "Let"}s and @{text "Let_rec"}s in the following - specification: - % - \begin{equation}\label{letrecs} - \mbox{\small% - \begin{tabular}{@ {}l@ {}} - \isacommand{nominal\_datatype}~@{text "trm ="}~\ldots\\ - \hspace{5mm}$\mid$~@{text "Let as::assn t::trm"} - \;\;\isacommand{bind} @{text "bn(as)"} \isacommand{in} @{text t}\\ - \hspace{5mm}$\mid$~@{text "Let_rec as::assn t::trm"} - \;\;\isacommand{bind} @{text "bn(as)"} \isacommand{in} @{text "as t"}\\ - \isacommand{and} @{text "assn"} $=$ - @{text "ANil"} - $\mid$~@{text "ACons name trm assn"}\\ - \isacommand{binder} @{text "bn::assn \ atom list"}\\ - \isacommand{where}~@{text "bn(ANil) = []"}\\ - \hspace{5mm}$\mid$~@{text "bn(ACons a t as) = [atom a] @ bn(as)"}\\ - \end{tabular}} - \end{equation} - % - \noindent - The difference is that with @{text Let} we only want to bind the atoms @{text - "bn(as)"} in the term @{text t}, but with @{text "Let_rec"} we also want to bind the atoms - inside the assignment. This difference has consequences for the associated - notions of free-atoms and $\alpha$-equivalence. - - To make sure that atoms bound by deep binders cannot be free at the - same time, we cannot have more than one binding function for a deep binder. - Consequently we exclude specifications such as - % - \begin{center}\small - \begin{tabular}{@ {}l@ {\hspace{2mm}}l@ {}} - @{text "Baz\<^isub>1 p::pat t::trm"} & - \isacommand{bind} @{text "bn\<^isub>1(p) bn\<^isub>2(p)"} \isacommand{in} @{text t}\\ - @{text "Baz\<^isub>2 p::pat t\<^isub>1::trm t\<^isub>2::trm"} & - \isacommand{bind} @{text "bn\<^isub>1(p)"} \isacommand{in} @{text "t\<^isub>1"}, - \isacommand{bind} @{text "bn\<^isub>2(p)"} \isacommand{in} @{text "t\<^isub>2"}\\ - \end{tabular} - \end{center} - - \noindent - Otherwise it is possible that @{text "bn\<^isub>1"} and @{text "bn\<^isub>2"} pick - out different atoms to become bound, respectively be free, in @{text "p"}. - (Since the Ott-tool does not derive a reasoning infrastructure for - $\alpha$-equated terms with deep binders, it can permit such specifications.) - - We also need to restrict the form of the binding functions in order - to ensure the @{text "bn"}-functions can be defined for $\alpha$-equated - terms. The main restriction is that we cannot return an atom in a binding function that is also - bound in the corresponding term-constructor. That means in \eqref{letpat} - that the term-constructors @{text PVar} and @{text PTup} may - not have a binding clause (all arguments are used to define @{text "bn"}). - In contrast, in case of \eqref{letrecs} the term-constructor @{text ACons} - may have a binding clause involving the argument @{text trm} (the only one that - is \emph{not} used in the definition of the binding function). This restriction - is sufficient for lifting the binding function to $\alpha$-equated terms. - - In the version of - Nominal Isabelle described here, we also adopted the restriction from the - Ott-tool that binding functions can only return: the empty set or empty list - (as in case @{text PNil}), a singleton set or singleton list containing an - atom (case @{text PVar}), or unions of atom sets or appended atom lists - (case @{text PTup}). This restriction will simplify some automatic definitions and proofs - later on. - - In order to simplify our definitions of free atoms and $\alpha$-equivalence, - we shall assume specifications - of term-calculi are implicitly \emph{completed}. By this we mean that - for every argument of a term-constructor that is \emph{not} - already part of a binding clause given by the user, we add implicitly a special \emph{empty} binding - clause, written \isacommand{bind}~@{term "{}"}~\isacommand{in}~@{text "labels"}. In case - of the lambda-terms, the completion produces - - \begin{center}\small - \begin{tabular}{@ {}l@ {\hspace{-1mm}}} - \isacommand{nominal\_datatype} @{text lam} =\\ - \hspace{5mm}\phantom{$\mid$}~@{text "Var x::name"} - \;\;\isacommand{bind}~@{term "{}"}~\isacommand{in}~@{text "x"}\\ - \hspace{5mm}$\mid$~@{text "App t\<^isub>1::lam t\<^isub>2::lam"} - \;\;\isacommand{bind}~@{term "{}"}~\isacommand{in}~@{text "t\<^isub>1 t\<^isub>2"}\\ - \hspace{5mm}$\mid$~@{text "Lam x::name t::lam"} - \;\;\isacommand{bind}~@{text x} \isacommand{in} @{text t}\\ - \end{tabular} - \end{center} - - \noindent - The point of completion is that we can make definitions over the binding - clauses and be sure to have captured all arguments of a term constructor. -*} - -section {* Alpha-Equivalence and Free Atoms\label{sec:alpha} *} - -text {* - Having dealt with all syntax matters, the problem now is how we can turn - specifications into actual type definitions in Isabelle/HOL and then - establish a reasoning infrastructure for them. As - Pottier and Cheney pointed out \cite{Pottier06,Cheney05}, just - re-arranging the arguments of - term-constructors so that binders and their bodies are next to each other will - result in inadequate representations in cases like @{text "Let x\<^isub>1 = t\<^isub>1\x\<^isub>n = t\<^isub>n in s"}. - Therefore we will first - extract ``raw'' datatype definitions from the specification and then define - explicitly an $\alpha$-equivalence relation over them. We subsequently - construct the quotient of the datatypes according to our $\alpha$-equivalence. - - The ``raw'' datatype definition can be obtained by stripping off the - binding clauses and the labels from the types. We also have to invent - new names for the types @{text "ty\<^sup>\"} and term-constructors @{text "C\<^sup>\"} - given by the user. In our implementation we just use the affix ``@{text "_raw"}''. - But for the purpose of this paper, we use the superscript @{text "_\<^sup>\"} to indicate - that a notion is given for $\alpha$-equivalence classes and leave it out - for the corresponding notion given on the ``raw'' level. So for example - we have @{text "ty\<^sup>\ \ ty"} and @{text "C\<^sup>\ \ C"} - where @{term ty} is the type used in the quotient construction for - @{text "ty\<^sup>\"} and @{text "C"} is the term-constructor on the ``raw'' type @{text "ty"}. - - %The resulting datatype definition is legal in Isabelle/HOL provided the datatypes are - %non-empty and the types in the constructors only occur in positive - %position (see \cite{Berghofer99} for an in-depth description of the datatype package - %in Isabelle/HOL). - We subsequently define each of the user-specified binding - functions @{term "bn"}$_{1..m}$ by recursion over the corresponding - raw datatype. We can also easily define permutation operations by - recursion so that for each term constructor @{text "C"} we have that - % - \begin{equation}\label{ceqvt} - @{text "p \ (C z\<^isub>1 \ z\<^isub>n) = C (p \ z\<^isub>1) \ (p \ z\<^isub>n)"} - \end{equation} - - The first non-trivial step we have to perform is the generation of - free-atom functions from the specification. For the - \emph{raw} types @{text "ty"}$_{1..n}$ we define the free-atom functions - % - %\begin{equation}\label{fvars} - @{text "fa_ty\<^isub>"}$_{1..n}$ - %\end{equation} - % - %\noindent - by recursion. - We define these functions together with auxiliary free-atom functions for - the binding functions. Given raw binding functions @{text "bn"}$_{1..m}$ - we define - % - %\begin{center} - @{text "fa_bn\<^isub>"}$_{1..m}$. - %\end{center} - % - %\noindent - The reason for this setup is that in a deep binder not all atoms have to be - bound, as we saw in the example with ``plain'' @{text Let}s. We need therefore a function - that calculates those free atoms in a deep binder. - - While the idea behind these free-atom functions is clear (they just - collect all atoms that are not bound), because of our rather complicated - binding mechanisms their definitions are somewhat involved. Given - a term-constructor @{text "C"} of type @{text ty} and some associated - binding clauses @{text "bc\<^isub>1\bc\<^isub>k"}, the result of @{text - "fa_ty (C z\<^isub>1 \ z\<^isub>n)"} will be the union @{text - "fa(bc\<^isub>1) \ \ \ fa(bc\<^isub>k)"} where we will define below what @{text "fa"} for a binding - clause means. We only show the details for the mode \isacommand{bind (set)} (the other modes are similar). - Suppose the binding clause @{text bc\<^isub>i} is of the form - % - %\begin{center} - \mbox{\isacommand{bind (set)} @{text "b\<^isub>1\b\<^isub>p"} \isacommand{in} @{text "d\<^isub>1\d\<^isub>q"}} - %\end{center} - % - %\noindent - in which the body-labels @{text "d"}$_{1..q}$ refer to types @{text ty}$_{1..q}$, - and the binders @{text b}$_{1..p}$ - either refer to labels of atom types (in case of shallow binders) or to binding - functions taking a single label as argument (in case of deep binders). Assuming - @{text "D"} stands for the set of free atoms of the bodies, @{text B} for the - set of binding atoms in the binders and @{text "B'"} for the set of free atoms in - non-recursive deep binders, - then the free atoms of the binding clause @{text bc\<^isub>i} are\\[-2mm] - % - \begin{equation}\label{fadef} - \mbox{@{text "fa(bc\<^isub>i) \ (D - B) \ B'"}}. - \end{equation} - % - \noindent - The set @{text D} is formally defined as - % - %\begin{center} - @{text "D \ fa_ty\<^isub>1 d\<^isub>1 \ ... \ fa_ty\<^isub>q d\<^isub>q"} - %\end{center} - % - %\noindent - where in case @{text "d\<^isub>i"} refers to one of the raw types @{text "ty"}$_{1..n}$ from the - specification, the function @{text "fa_ty\<^isub>i"} is the corresponding free-atom function - we are defining by recursion; - %(see \eqref{fvars}); - otherwise we set @{text "fa_ty\<^isub>i d\<^isub>i = supp d\<^isub>i"}. - - In order to formally define the set @{text B} we use the following auxiliary @{text "bn"}-functions - for atom types to which shallow binders may refer\\[-4mm] - % - %\begin{center} - %\begin{tabular}{r@ {\hspace{2mm}}c@ {\hspace{2mm}}l} - %@{text "bn_atom a"} & @{text "\"} & @{text "{atom a}"}\\ - %@{text "bn_atom_set as"} & @{text "\"} & @{text "atoms as"}\\ - %@{text "bn_atom_list as"} & @{text "\"} & @{text "atoms (set as)"} - %\end{tabular} - %\end{center} - % - \begin{center} - @{text "bn\<^bsub>atom\<^esub> a \ {atom a}"}\hfill - @{text "bn\<^bsub>atom_set\<^esub> as \ atoms as"}\hfill - @{text "bn\<^bsub>atom_list\<^esub> as \ atoms (set as)"} - \end{center} - % - \noindent - Like the function @{text atom}, the function @{text "atoms"} coerces - a set of atoms to a set of the generic atom type. - %It is defined as @{text "atoms as \ {atom a | a \ as}"}. - The set @{text B} is then formally defined as\\[-4mm] - % - \begin{center} - @{text "B \ bn_ty\<^isub>1 b\<^isub>1 \ ... \ bn_ty\<^isub>p b\<^isub>p"} - \end{center} - % - \noindent - where we use the auxiliary binding functions for shallow binders. - The set @{text "B'"} collects all free atoms in non-recursive deep - binders. Let us assume these binders in @{text "bc\<^isub>i"} are - % - %\begin{center} - \mbox{@{text "bn\<^isub>1 l\<^isub>1, \, bn\<^isub>r l\<^isub>r"}} - %\end{center} - % - %\noindent - with @{text "l"}$_{1..r}$ $\subseteq$ @{text "b"}$_{1..p}$ and none of the - @{text "l"}$_{1..r}$ being among the bodies @{text - "d"}$_{1..q}$. The set @{text "B'"} is defined as\\[-5mm] - % - \begin{center} - @{text "B' \ fa_bn\<^isub>1 l\<^isub>1 \ ... \ fa_bn\<^isub>r l\<^isub>r"}\\[-9mm] - \end{center} - % - \noindent - This completes the definition of the free-atom functions @{text "fa_ty"}$_{1..n}$. - - Note that for non-recursive deep binders, we have to add in \eqref{fadef} - the set of atoms that are left unbound by the binding functions @{text - "bn"}$_{1..m}$. We used for the definition of - this set the functions @{text "fa_bn"}$_{1..m}$, which are also defined by mutual - recursion. Assume the user specified a @{text bn}-clause of the form - % - %\begin{center} - @{text "bn (C z\<^isub>1 \ z\<^isub>s) = rhs"} - %\end{center} - % - %\noindent - where the @{text "z"}$_{1..s}$ are of types @{text "ty"}$_{1..s}$. For each of - the arguments we calculate the free atoms as follows: - % - \begin{center} - \begin{tabular}{c@ {\hspace{2mm}}p{0.9\textwidth}} - $\bullet$ & @{term "fa_ty\<^isub>i z\<^isub>i"} provided @{text "z\<^isub>i"} does not occur in @{text "rhs"} - (that means nothing is bound in @{text "z\<^isub>i"} by the binding function),\\ - $\bullet$ & @{term "fa_bn\<^isub>i z\<^isub>i"} provided @{text "z\<^isub>i"} occurs in @{text "rhs"} - with the recursive call @{text "bn\<^isub>i z\<^isub>i"}, and\\ - $\bullet$ & @{term "{}"} provided @{text "z\<^isub>i"} occurs in @{text "rhs"}, - but without a recursive call. - \end{tabular} - \end{center} - % - \noindent - For defining @{text "fa_bn (C z\<^isub>1 \ z\<^isub>n)"} we just union up all these sets. - - To see how these definitions work in practice, let us reconsider the - term-constructors @{text "Let"} and @{text "Let_rec"} shown in - \eqref{letrecs} together with the term-constructors for assignments @{text - "ANil"} and @{text "ACons"}. Since there is a binding function defined for - assignments, we have three free-atom functions, namely @{text - "fa\<^bsub>trm\<^esub>"}, @{text "fa\<^bsub>assn\<^esub>"} and @{text - "fa\<^bsub>bn\<^esub>"} as follows: - % - \begin{center}\small - \begin{tabular}{@ {}l@ {\hspace{1mm}}c@ {\hspace{1mm}}l@ {}} - @{text "fa\<^bsub>trm\<^esub> (Let as t)"} & @{text "="} & @{text "(fa\<^bsub>trm\<^esub> t - set (bn as)) \ fa\<^bsub>bn\<^esub> as"}\\ - @{text "fa\<^bsub>trm\<^esub> (Let_rec as t)"} & @{text "="} & @{text "(fa\<^bsub>assn\<^esub> as \ fa\<^bsub>trm\<^esub> t) - set (bn as)"}\\[1mm] - - @{text "fa\<^bsub>assn\<^esub> (ANil)"} & @{text "="} & @{term "{}"}\\ - @{text "fa\<^bsub>assn\<^esub> (ACons a t as)"} & @{text "="} & @{text "(supp a) \ (fa\<^bsub>trm\<^esub> t) \ (fa\<^bsub>assn\<^esub> as)"}\\[1mm] - - @{text "fa\<^bsub>bn\<^esub> (ANil)"} & @{text "="} & @{term "{}"}\\ - @{text "fa\<^bsub>bn\<^esub> (ACons a t as)"} & @{text "="} & @{text "(fa\<^bsub>trm\<^esub> t) \ (fa\<^bsub>bn\<^esub> as)"} - \end{tabular} - \end{center} - - \noindent - Recall that @{text ANil} and @{text "ACons"} have no - binding clause in the specification. The corresponding free-atom - function @{text "fa\<^bsub>assn\<^esub>"} therefore returns all free atoms - of an assignment (in case of @{text "ACons"}, they are given in - terms of @{text supp}, @{text "fa\<^bsub>trm\<^esub>"} and @{text "fa\<^bsub>assn\<^esub>"}). - The binding only takes place in @{text Let} and - @{text "Let_rec"}. In case of @{text "Let"}, the binding clause specifies - that all atoms given by @{text "set (bn as)"} have to be bound in @{text - t}. Therefore we have to subtract @{text "set (bn as)"} from @{text - "fa\<^bsub>trm\<^esub> t"}. However, we also need to add all atoms that are - free in @{text "as"}. This is - in contrast with @{text "Let_rec"} where we have a recursive - binder to bind all occurrences of the atoms in @{text - "set (bn as)"} also inside @{text "as"}. Therefore we have to subtract - @{text "set (bn as)"} from both @{text "fa\<^bsub>trm\<^esub> t"} and @{text "fa\<^bsub>assn\<^esub> as"}. - %Like the function @{text "bn"}, the function @{text "fa\<^bsub>bn\<^esub>"} traverses the - %list of assignments, but instead returns the free atoms, which means in this - %example the free atoms in the argument @{text "t"}. - - An interesting point in this - example is that a ``naked'' assignment (@{text "ANil"} or @{text "ACons"}) does not bind any - atoms, even if the binding function is specified over assignments. - Only in the context of a @{text Let} or @{text "Let_rec"}, where the binding clauses are given, will - some atoms actually become bound. This is a phenomenon that has also been pointed - out in \cite{ott-jfp}. For us this observation is crucial, because we would - not be able to lift the @{text "bn"}-functions to $\alpha$-equated terms if they act on - atoms that are bound. In that case, these functions would \emph{not} respect - $\alpha$-equivalence. - - Next we define the $\alpha$-equivalence relations for the raw types @{text - "ty"}$_{1..n}$ from the specification. We write them as - % - %\begin{center} - @{text "\ty"}$_{1..n}$. - %\end{center} - % - %\noindent - Like with the free-atom functions, we also need to - define auxiliary $\alpha$-equivalence relations - % - %\begin{center} - @{text "\bn\<^isub>"}$_{1..m}$ - %\end{center} - % - %\noindent - for the binding functions @{text "bn"}$_{1..m}$, - To simplify our definitions we will use the following abbreviations for - \emph{compound equivalence relations} and \emph{compound free-atom functions} acting on tuples. - % - \begin{center} - \begin{tabular}{r@ {\hspace{2mm}}c@ {\hspace{2mm}}l} - @{text "(x\<^isub>1,\, x\<^isub>n) (R\<^isub>1,\, R\<^isub>n) (x\\<^isub>1,\, x\\<^isub>n)"} & @{text "\"} & - @{text "x\<^isub>1 R\<^isub>1 x\\<^isub>1 \ \ \ x\<^isub>n R\<^isub>n x\\<^isub>n"}\\ - @{text "(fa\<^isub>1,\, fa\<^isub>n) (x\<^isub>1,\, x\<^isub>n)"} & @{text "\"} & @{text "fa\<^isub>1 x\<^isub>1 \ \ \ fa\<^isub>n x\<^isub>n"}\\ - \end{tabular} - \end{center} - - - The $\alpha$-equivalence relations are defined as inductive predicates - having a single clause for each term-constructor. Assuming a - term-constructor @{text C} is of type @{text ty} and has the binding clauses - @{term "bc"}$_{1..k}$, then the $\alpha$-equivalence clause has the form - % - \begin{center} - \mbox{\infer{@{text "C z\<^isub>1 \ z\<^isub>n \ty C z\\<^isub>1 \ z\\<^isub>n"}} - {@{text "prems(bc\<^isub>1) \ prems(bc\<^isub>k)"}}} - \end{center} - - \noindent - The task below is to specify what the premises of a binding clause are. As a - special instance, we first treat the case where @{text "bc\<^isub>i"} is the - empty binding clause of the form - % - \begin{center} - \mbox{\isacommand{bind (set)} @{term "{}"} \isacommand{in} @{text "d\<^isub>1\d\<^isub>q"}.} - \end{center} - - \noindent - In this binding clause no atom is bound and we only have to $\alpha$-relate the bodies. For this - we build first the tuples @{text "D \ (d\<^isub>1,\, d\<^isub>q)"} and @{text "D' \ (d\\<^isub>1,\, d\\<^isub>q)"} - whereby the labels @{text "d"}$_{1..q}$ refer to arguments @{text "z"}$_{1..n}$ and - respectively @{text "d\"}$_{1..q}$ to @{text "z\"}$_{1..n}$. In order to relate - two such tuples we define the compound $\alpha$-equivalence relation @{text "R"} as follows - % - \begin{equation}\label{rempty} - \mbox{@{text "R \ (R\<^isub>1,\, R\<^isub>q)"}} - \end{equation} - - \noindent - with @{text "R\<^isub>i"} being @{text "\ty\<^isub>i"} if the corresponding labels @{text "d\<^isub>i"} and - @{text "d\\<^isub>i"} refer - to a recursive argument of @{text C} with type @{text "ty\<^isub>i"}; otherwise - we take @{text "R\<^isub>i"} to be the equality @{text "="}. This lets us define - the premise for an empty binding clause succinctly as @{text "prems(bc\<^isub>i) \ D R D'"}, - which can be unfolded to the series of premises - % - %\begin{center} - @{text "d\<^isub>1 R\<^isub>1 d\\<^isub>1 \ d\<^isub>q R\<^isub>q d\\<^isub>q"}. - %\end{center} - % - %\noindent - We will use the unfolded version in the examples below. - - Now suppose the binding clause @{text "bc\<^isub>i"} is of the general form - % - \begin{equation}\label{nonempty} - \mbox{\isacommand{bind (set)} @{text "b\<^isub>1\b\<^isub>p"} \isacommand{in} @{text "d\<^isub>1\d\<^isub>q"}.} - \end{equation} - - \noindent - In this case we define a premise @{text P} using the relation - $\approx_{\,\textit{set}}$ given in Section~\ref{sec:binders} (similarly - $\approx_{\,\textit{set+}}$ and $\approx_{\,\textit{list}}$ for the other - binding modes). This premise defines $\alpha$-equivalence of two abstractions - involving multiple binders. As above, we first build the tuples @{text "D"} and - @{text "D'"} for the bodies @{text "d"}$_{1..q}$, and the corresponding - compound $\alpha$-relation @{text "R"} (shown in \eqref{rempty}). - For $\approx_{\,\textit{set}}$ we also need - a compound free-atom function for the bodies defined as - % - \begin{center} - \mbox{@{text "fa \ (fa_ty\<^isub>1,\, fa_ty\<^isub>q)"}} - \end{center} - - \noindent - with the assumption that the @{text "d"}$_{1..q}$ refer to arguments of types @{text "ty"}$_{1..q}$. - The last ingredient we need are the sets of atoms bound in the bodies. - For this we take - - \begin{center} - @{text "B \ bn_ty\<^isub>1 b\<^isub>1 \ \ \ bn_ty\<^isub>p b\<^isub>p"}\;.\\ - \end{center} - - \noindent - Similarly for @{text "B'"} using the labels @{text "b\"}$_{1..p}$. This - lets us formally define the premise @{text P} for a non-empty binding clause as: - % - \begin{center} - \mbox{@{term "P \ \p. (B, D) \set R fa p (B', D')"}}\;. - \end{center} - - \noindent - This premise accounts for $\alpha$-equivalence of the bodies of the binding - clause. - However, in case the binders have non-recursive deep binders, this premise - is not enough: - we also have to ``propagate'' $\alpha$-equivalence inside the structure of - these binders. An example is @{text "Let"} where we have to make sure the - right-hand sides of assignments are $\alpha$-equivalent. For this we use - relations @{text "\bn"}$_{1..m}$ (which we will formally define shortly). - Let us assume the non-recursive deep binders in @{text "bc\<^isub>i"} are - % - %\begin{center} - @{text "bn\<^isub>1 l\<^isub>1, \, bn\<^isub>r l\<^isub>r"}. - %\end{center} - % - %\noindent - The tuple @{text L} is then @{text "(l\<^isub>1,\,l\<^isub>r)"} (similarly @{text "L'"}) - and the compound equivalence relation @{text "R'"} is @{text "(\bn\<^isub>1,\,\bn\<^isub>r)"}. - All premises for @{text "bc\<^isub>i"} are then given by - % - \begin{center} - @{text "prems(bc\<^isub>i) \ P \ L R' L'"} - \end{center} - - \noindent - The auxiliary $\alpha$-equivalence relations @{text "\bn"}$_{1..m}$ - in @{text "R'"} are defined as follows: assuming a @{text bn}-clause is of the form - % - %\begin{center} - @{text "bn (C z\<^isub>1 \ z\<^isub>s) = rhs"} - %\end{center} - % - %\noindent - where the @{text "z"}$_{1..s}$ are of types @{text "ty"}$_{1..s}$, - then the corresponding $\alpha$-equivalence clause for @{text "\bn"} has the form - % - \begin{center} - \mbox{\infer{@{text "C z\<^isub>1 \ z\<^isub>s \bn C z\\<^isub>1 \ z\\<^isub>s"}} - {@{text "z\<^isub>1 R\<^isub>1 z\\<^isub>1 \ z\<^isub>s R\<^isub>s z\\<^isub>s"}}} - \end{center} - - \noindent - In this clause the relations @{text "R"}$_{1..s}$ are given by - - \begin{center} - \begin{tabular}{c@ {\hspace{2mm}}p{0.9\textwidth}} - $\bullet$ & @{text "z\<^isub>i \ty z\\<^isub>i"} provided @{text "z\<^isub>i"} does not occur in @{text rhs} and - is a recursive argument of @{text C},\\ - $\bullet$ & @{text "z\<^isub>i = z\\<^isub>i"} provided @{text "z\<^isub>i"} does not occur in @{text rhs} - and is a non-recursive argument of @{text C},\\ - $\bullet$ & @{text "z\<^isub>i \bn\<^isub>i z\\<^isub>i"} provided @{text "z\<^isub>i"} occurs in @{text rhs} - with the recursive call @{text "bn\<^isub>i x\<^isub>i"} and\\ - $\bullet$ & @{text True} provided @{text "z\<^isub>i"} occurs in @{text rhs} but without a - recursive call. - \end{tabular} - \end{center} - - \noindent - This completes the definition of $\alpha$-equivalence. As a sanity check, we can show - that the premises of empty binding clauses are a special case of the clauses for - non-empty ones (we just have to unfold the definition of $\approx_{\,\textit{set}}$ and take @{text "0"} - for the existentially quantified permutation). - - Again let us take a look at a concrete example for these definitions. For \eqref{letrecs} - we have three relations $\approx_{\textit{trm}}$, $\approx_{\textit{assn}}$ and - $\approx_{\textit{bn}}$ with the following clauses: - - \begin{center}\small - \begin{tabular}{@ {}c @ {}} - \infer{@{text "Let as t \\<^bsub>trm\<^esub> Let as' t'"}} - {@{term "\p. (bn as, t) \lst alpha_trm fa_trm p (bn as', t')"} & @{text "as \\<^bsub>bn\<^esub> as'"}}\smallskip\\ - \makebox[0mm]{\infer{@{text "Let_rec as t \\<^bsub>trm\<^esub> Let_rec as' t'"}} - {@{term "\p. (bn as, ast) \lst alpha_trm2 fa_trm2 p (bn as', ast')"}}} - \end{tabular} - \end{center} - - \begin{center}\small - \begin{tabular}{@ {}c @ {}} - \infer{@{text "ANil \\<^bsub>assn\<^esub> ANil"}}{}\hspace{9mm} - \infer{@{text "ACons a t as \\<^bsub>assn\<^esub> ACons a' t' as"}} - {@{text "a = a'"} & @{text "t \\<^bsub>trm\<^esub> t'"} & @{text "as \\<^bsub>assn\<^esub> as'"}} - \end{tabular} - \end{center} - - \begin{center}\small - \begin{tabular}{@ {}c @ {}} - \infer{@{text "ANil \\<^bsub>bn\<^esub> ANil"}}{}\hspace{9mm} - \infer{@{text "ACons a t as \\<^bsub>bn\<^esub> ACons a' t' as"}} - {@{text "t \\<^bsub>trm\<^esub> t'"} & @{text "as \\<^bsub>bn\<^esub> as'"}} - \end{tabular} - \end{center} - - \noindent - Note the difference between $\approx_{\textit{assn}}$ and - $\approx_{\textit{bn}}$: the latter only ``tracks'' $\alpha$-equivalence of - the components in an assignment that are \emph{not} bound. This is needed in the - clause for @{text "Let"} (which has - a non-recursive binder). - %The underlying reason is that the terms inside an assignment are not meant - %to be ``under'' the binder. Such a premise is \emph{not} needed in @{text "Let_rec"}, - %because there all components of an assignment are ``under'' the binder. -*} - -section {* Establishing the Reasoning Infrastructure *} - -text {* - Having made all necessary definitions for raw terms, we can start - with establishing the reasoning infrastructure for the $\alpha$-equated types - @{text "ty\"}$_{1..n}$, that is the types the user originally specified. We sketch - in this section the proofs we need for establishing this infrastructure. One - main point of our work is that we have completely automated these proofs in Isabelle/HOL. - - First we establish that the - $\alpha$-equivalence relations defined in the previous section are - equivalence relations. - - \begin{lemma}\label{equiv} - Given the raw types @{text "ty"}$_{1..n}$ and binding functions - @{text "bn"}$_{1..m}$, the relations @{text "\ty"}$_{1..n}$ and - @{text "\bn"}$_{1..m}$ are equivalence relations.%% and equivariant. - \end{lemma} - - \begin{proof} - The proof is by mutual induction over the definitions. The non-trivial - cases involve premises built up by $\approx_{\textit{set}}$, - $\approx_{\textit{set+}}$ and $\approx_{\textit{list}}$. They - can be dealt with as in Lemma~\ref{alphaeq}. - \end{proof} - - \noindent - We can feed this lemma into our quotient package and obtain new types @{text - "ty"}$^\alpha_{1..n}$ representing $\alpha$-equated terms of types @{text "ty"}$_{1..n}$. - We also obtain definitions for the term-constructors @{text - "C"}$^\alpha_{1..k}$ from the raw term-constructors @{text - "C"}$_{1..k}$, and similar definitions for the free-atom functions @{text - "fa_ty"}$^\alpha_{1..n}$ and @{text "fa_bn"}$^\alpha_{1..m}$ as well as the binding functions @{text - "bn"}$^\alpha_{1..m}$. However, these definitions are not really useful to the - user, since they are given in terms of the isomorphisms we obtained by - creating new types in Isabelle/HOL (recall the picture shown in the - Introduction). - - The first useful property for the user is the fact that distinct - term-constructors are not - equal, that is - % - \begin{equation}\label{distinctalpha} - \mbox{@{text "C"}$^\alpha$~@{text "x\<^isub>1 \ x\<^isub>r"}~@{text "\"}~% - @{text "D"}$^\alpha$~@{text "y\<^isub>1 \ y\<^isub>s"}} - \end{equation} - - \noindent - whenever @{text "C"}$^\alpha$~@{text "\"}~@{text "D"}$^\alpha$. - In order to derive this fact, we use the definition of $\alpha$-equivalence - and establish that - % - \begin{equation}\label{distinctraw} - \mbox{@{text "C x\<^isub>1 \ x\<^isub>r"}\;$\not\approx$@{text ty}\;@{text "D y\<^isub>1 \ y\<^isub>s"}} - \end{equation} - - \noindent - holds for the corresponding raw term-constructors. - In order to deduce \eqref{distinctalpha} from \eqref{distinctraw}, our quotient - package needs to know that the raw term-constructors @{text "C"} and @{text "D"} - are \emph{respectful} w.r.t.~the $\alpha$-equivalence relations (see \cite{Homeier05}). - Assuming, for example, @{text "C"} is of type @{text "ty"} with argument types - @{text "ty"}$_{1..r}$, respectfulness amounts to showing that - % - \begin{center} - @{text "C x\<^isub>1 \ x\<^isub>r \ty C x\\<^isub>1 \ x\\<^isub>r"} - \end{center} - - \noindent - holds under the assumptions that we have \mbox{@{text - "x\<^isub>i \ty\<^isub>i x\\<^isub>i"}} whenever @{text "x\<^isub>i"} - and @{text "x\\<^isub>i"} are recursive arguments of @{text C} and - @{text "x\<^isub>i = x\\<^isub>i"} whenever they are non-recursive arguments. We can prove this - implication by applying the corresponding rule in our $\alpha$-equivalence - definition and by establishing the following auxiliary implications %facts - % - \begin{equation}\label{fnresp} - \mbox{% - \begin{tabular}{ll@ {\hspace{7mm}}ll} - \mbox{\it (i)} & @{text "x \ty\<^isub>i x\"}~~@{text "\"}~~@{text "fa_ty\<^isub>i x = fa_ty\<^isub>i x\"} & - \mbox{\it (iii)} & @{text "x \ty\<^isub>j x\"}~~@{text "\"}~~@{text "bn\<^isub>j x = bn\<^isub>j x\"}\\ - - \mbox{\it (ii)} & @{text "x \ty\<^isub>j x\"}~~@{text "\"}~~@{text "fa_bn\<^isub>j x = fa_bn\<^isub>j x\"} & - \mbox{\it (iv)} & @{text "x \ty\<^isub>j x\"}~~@{text "\"}~~@{text "x \bn\<^isub>j x\"}\\ - \end{tabular}} - \end{equation} - - \noindent - They can be established by induction on @{text "\ty"}$_{1..n}$. Whereas the first, - second and last implication are true by how we stated our definitions, the - third \emph{only} holds because of our restriction - imposed on the form of the binding functions---namely \emph{not} returning - any bound atoms. In Ott, in contrast, the user may - define @{text "bn"}$_{1..m}$ so that they return bound - atoms and in this case the third implication is \emph{not} true. A - result is that the lifting of the corresponding binding functions in Ott to $\alpha$-equated - terms is impossible. - - Having established respectfulness for the raw term-constructors, the - quotient package is able to automatically deduce \eqref{distinctalpha} from - \eqref{distinctraw}. Having the facts \eqref{fnresp} at our disposal, we can - also lift properties that characterise when two raw terms of the form - % - \begin{center} - @{text "C x\<^isub>1 \ x\<^isub>r \ty C x\\<^isub>1 \ x\\<^isub>r"} - \end{center} - - \noindent - are $\alpha$-equivalent. This gives us conditions when the corresponding - $\alpha$-equated terms are \emph{equal}, namely - % - %\begin{center} - @{text "C\<^sup>\ x\<^isub>1 \ x\<^isub>r = C\<^sup>\ x\\<^isub>1 \ x\\<^isub>r"}. - %\end{center} - % - %\noindent - We call these conditions as \emph{quasi-injectivity}. They correspond to - the premises in our $\alpha$-equivalence relations. - - Next we can lift the permutation - operations defined in \eqref{ceqvt}. In order to make this - lifting to go through, we have to show that the permutation operations are respectful. - This amounts to showing that the - $\alpha$-equivalence relations are equivariant \cite{HuffmanUrban10}. - %, which we already established - %in Lemma~\ref{equiv}. - As a result we can add the equations - % - \begin{equation}\label{calphaeqvt} - @{text "p \ (C\<^sup>\ x\<^isub>1 \ x\<^isub>r) = C\<^sup>\ (p \ x\<^isub>1) \ (p \ x\<^isub>r)"} - \end{equation} - - \noindent - to our infrastructure. In a similar fashion we can lift the defining equations - of the free-atom functions @{text "fn_ty\"}$_{1..n}$ and - @{text "fa_bn\"}$_{1..m}$ as well as of the binding functions @{text - "bn\"}$_{1..m}$ and the size functions @{text "size_ty\"}$_{1..n}$. - The latter are defined automatically for the raw types @{text "ty"}$_{1..n}$ - by the datatype package of Isabelle/HOL. - - Finally we can add to our infrastructure a cases lemma (explained in the next section) - and a structural induction principle - for the types @{text "ty\"}$_{1..n}$. The conclusion of the induction principle is - of the form - % - %\begin{equation}\label{weakinduct} - \mbox{@{text "P\<^isub>1 x\<^isub>1 \ \ \ P\<^isub>n x\<^isub>n "}} - %\end{equation} - % - %\noindent - whereby the @{text P}$_{1..n}$ are predicates and the @{text x}$_{1..n}$ - have types @{text "ty\"}$_{1..n}$. This induction principle has for each - term constructor @{text "C"}$^\alpha$ a premise of the form - % - \begin{equation}\label{weakprem} - \mbox{@{text "\x\<^isub>1\x\<^isub>r. P\<^isub>i x\<^isub>i \ \ \ P\<^isub>j x\<^isub>j \ P (C\<^sup>\ x\<^isub>1 \ x\<^isub>r)"}} - \end{equation} - - \noindent - in which the @{text "x"}$_{i..j}$ @{text "\"} @{text "x"}$_{1..r}$ are - the recursive arguments of @{text "C\"}. - - By working now completely on the $\alpha$-equated level, we - can first show that the free-atom functions and binding functions are - equivariant, namely - % - \begin{center} - \begin{tabular}{rcl@ {\hspace{10mm}}rcl} - @{text "p \ (fa_ty\\<^isub>i x)"} & $=$ & @{text "fa_ty\\<^isub>i (p \ x)"} & - @{text "p \ (bn\\<^isub>j x)"} & $=$ & @{text "bn\\<^isub>j (p \ x)"}\\ - @{text "p \ (fa_bn\\<^isub>j x)"} & $=$ & @{text "fa_bn\\<^isub>j (p \ x)"}\\ - \end{tabular} - \end{center} - % - \noindent - These properties can be established using the induction principle for the types @{text "ty\"}$_{1..n}$. - %%in \eqref{weakinduct}. - Having these equivariant properties established, we can - show that the support of term-constructors @{text "C\<^sup>\"} is included in - the support of its arguments, that means - - \begin{center} - @{text "supp (C\<^sup>\ x\<^isub>1 \ x\<^isub>r) \ (supp x\<^isub>1 \ \ \ supp x\<^isub>r)"} - \end{center} - - \noindent - holds. This allows us to prove by induction that - every @{text x} of type @{text "ty\"}$_{1..n}$ is finitely supported. - %This can be again shown by induction - %over @{text "ty\"}$_{1..n}$. - Lastly, we can show that the support of - elements in @{text "ty\"}$_{1..n}$ is the same as @{text "fa_ty\"}$_{1..n}$. - This fact is important in a nominal setting, but also provides evidence - that our notions of free-atoms and $\alpha$-equivalence are correct. - - \begin{theorem} - For @{text "x"}$_{1..n}$ with type @{text "ty\"}$_{1..n}$, we have - @{text "supp x\<^isub>i = fa_ty\\<^isub>i x\<^isub>i"}. - \end{theorem} - - \begin{proof} - The proof is by induction. In each case - we unfold the definition of @{text "supp"}, move the swapping inside the - term-constructors and then use the quasi-injectivity lemmas in order to complete the - proof. For the abstraction cases we use the facts derived in Theorem~\ref{suppabs}. - \end{proof} - - \noindent - To sum up this section, we can establish automatically a reasoning infrastructure - for the types @{text "ty\"}$_{1..n}$ - by first lifting definitions from the raw level to the quotient level and - then by establishing facts about these lifted definitions. All necessary proofs - are generated automatically by custom ML-code. - - %This code can deal with - %specifications such as the one shown in Figure~\ref{nominalcorehas} for Core-Haskell. - - %\begin{figure}[t!] - %\begin{boxedminipage}{\linewidth} - %\small - %\begin{tabular}{l} - %\isacommand{atom\_decl}~@{text "var cvar tvar"}\\[1mm] - %\isacommand{nominal\_datatype}~@{text "tkind ="}\\ - %\phantom{$|$}~@{text "KStar"}~$|$~@{text "KFun tkind tkind"}\\ - %\isacommand{and}~@{text "ckind ="}\\ - %\phantom{$|$}~@{text "CKSim ty ty"}\\ - %\isacommand{and}~@{text "ty ="}\\ - %\phantom{$|$}~@{text "TVar tvar"}~$|$~@{text "T string"}~$|$~@{text "TApp ty ty"}\\ - %$|$~@{text "TFun string ty_list"}~% - %$|$~@{text "TAll tv::tvar tkind ty::ty"} \isacommand{bind}~@{text "tv"}~\isacommand{in}~@{text ty}\\ - %$|$~@{text "TArr ckind ty"}\\ - %\isacommand{and}~@{text "ty_lst ="}\\ - %\phantom{$|$}~@{text "TNil"}~$|$~@{text "TCons ty ty_lst"}\\ - %\isacommand{and}~@{text "cty ="}\\ - %\phantom{$|$}~@{text "CVar cvar"}~% - %$|$~@{text "C string"}~$|$~@{text "CApp cty cty"}~$|$~@{text "CFun string co_lst"}\\ - %$|$~@{text "CAll cv::cvar ckind cty::cty"} \isacommand{bind}~@{text "cv"}~\isacommand{in}~@{text cty}\\ - %$|$~@{text "CArr ckind cty"}~$|$~@{text "CRefl ty"}~$|$~@{text "CSym cty"}~$|$~@{text "CCirc cty cty"}\\ - %$|$~@{text "CAt cty ty"}~$|$~@{text "CLeft cty"}~$|$~@{text "CRight cty"}~$|$~@{text "CSim cty cty"}\\ - %$|$~@{text "CRightc cty"}~$|$~@{text "CLeftc cty"}~$|$~@{text "Coerce cty cty"}\\ - %\isacommand{and}~@{text "co_lst ="}\\ - %\phantom{$|$}@{text "CNil"}~$|$~@{text "CCons cty co_lst"}\\ - %\isacommand{and}~@{text "trm ="}\\ - %\phantom{$|$}~@{text "Var var"}~$|$~@{text "K string"}\\ - %$|$~@{text "LAM_ty tv::tvar tkind t::trm"} \isacommand{bind}~@{text "tv"}~\isacommand{in}~@{text t}\\ - %$|$~@{text "LAM_cty cv::cvar ckind t::trm"} \isacommand{bind}~@{text "cv"}~\isacommand{in}~@{text t}\\ - %$|$~@{text "App_ty trm ty"}~$|$~@{text "App_cty trm cty"}~$|$~@{text "App trm trm"}\\ - %$|$~@{text "Lam v::var ty t::trm"} \isacommand{bind}~@{text "v"}~\isacommand{in}~@{text t}\\ - %$|$~@{text "Let x::var ty trm t::trm"} \isacommand{bind}~@{text x}~\isacommand{in}~@{text t}\\ - %$|$~@{text "Case trm assoc_lst"}~$|$~@{text "Cast trm co"}\\ - %\isacommand{and}~@{text "assoc_lst ="}\\ - %\phantom{$|$}~@{text ANil}~% - %$|$~@{text "ACons p::pat t::trm assoc_lst"} \isacommand{bind}~@{text "bv p"}~\isacommand{in}~@{text t}\\ - %\isacommand{and}~@{text "pat ="}\\ - %\phantom{$|$}~@{text "Kpat string tvtk_lst tvck_lst vt_lst"}\\ - %\isacommand{and}~@{text "vt_lst ="}\\ - %\phantom{$|$}~@{text VTNil}~$|$~@{text "VTCons var ty vt_lst"}\\ - %\isacommand{and}~@{text "tvtk_lst ="}\\ - %\phantom{$|$}~@{text TVTKNil}~$|$~@{text "TVTKCons tvar tkind tvtk_lst"}\\ - %\isacommand{and}~@{text "tvck_lst ="}\\ - %\phantom{$|$}~@{text TVCKNil}~$|$ @{text "TVCKCons cvar ckind tvck_lst"}\\ - %\isacommand{binder}\\ - %@{text "bv :: pat \ atom list"}~\isacommand{and}~% - %@{text "bv1 :: vt_lst \ atom list"}~\isacommand{and}\\ - %@{text "bv2 :: tvtk_lst \ atom list"}~\isacommand{and}~% - %@{text "bv3 :: tvck_lst \ atom list"}\\ - %\isacommand{where}\\ - %\phantom{$|$}~@{text "bv (K s tvts tvcs vs) = (bv3 tvts) @ (bv2 tvcs) @ (bv1 vs)"}\\ - %$|$~@{text "bv1 VTNil = []"}\\ - %$|$~@{text "bv1 (VTCons x ty tl) = (atom x)::(bv1 tl)"}\\ - %$|$~@{text "bv2 TVTKNil = []"}\\ - %$|$~@{text "bv2 (TVTKCons a ty tl) = (atom a)::(bv2 tl)"}\\ - %$|$~@{text "bv3 TVCKNil = []"}\\ - %$|$~@{text "bv3 (TVCKCons c cty tl) = (atom c)::(bv3 tl)"}\\ - %\end{tabular} - %\end{boxedminipage} - %\caption{The nominal datatype declaration for Core-Haskell. For the moment we - %do not support nested types; therefore we explicitly have to unfold the - %lists @{text "co_lst"}, @{text "assoc_lst"} and so on. This will be improved - %in a future version of Nominal Isabelle. Apart from that, the - %declaration follows closely the original in Figure~\ref{corehas}. The - %point of our work is that having made such a declaration in Nominal Isabelle, - %one obtains automatically a reasoning infrastructure for Core-Haskell. - %\label{nominalcorehas}} - %\end{figure} -*} - - -section {* Strong Induction Principles *} - -text {* - In the previous section we derived induction principles for $\alpha$-equated terms. - We call such induction principles \emph{weak}, because for a - term-constructor \mbox{@{text "C\<^sup>\ x\<^isub>1\x\<^isub>r"}} - the induction hypothesis requires us to establish the implications \eqref{weakprem}. - The problem with these implications is that in general they are difficult to establish. - The reason is that we cannot make any assumption about the bound atoms that might be in @{text "C\<^sup>\"}. - %%(for example we cannot assume the variable convention for them). - - In \cite{UrbanTasson05} we introduced a method for automatically - strengthening weak induction principles for terms containing single - binders. These stronger induction principles allow the user to make additional - assumptions about bound atoms. - %These additional assumptions amount to a formal - %version of the informal variable convention for binders. - To sketch how this strengthening extends to the case of multiple binders, we use as - running example the term-constructors @{text "Lam"} and @{text "Let"} - from example \eqref{letpat}. Instead of establishing @{text " P\<^bsub>trm\<^esub> t \ P\<^bsub>pat\<^esub> p"}, - the stronger induction principle for \eqref{letpat} establishes properties @{text " P\<^bsub>trm\<^esub> c t \ P\<^bsub>pat\<^esub> c p"} - where the additional parameter @{text c} controls - which freshness assumptions the binders should satisfy. For the two term constructors - this means that the user has to establish in inductions the implications - % - \begin{center} - \begin{tabular}{l} - @{text "\a t c. {atom a} \\<^sup>* c \ (\d. P\<^bsub>trm\<^esub> d t) \ P\<^bsub>trm\<^esub> c (Lam a t)"}\\ - @{text "\p t c. (set (bn p)) \\<^sup>* c \ (\d. P\<^bsub>pat\<^esub> d p) \ (\d. P\<^bsub>trm\<^esub> d t) \ \ P\<^bsub>trm\<^esub> c (Let p t)"}\\%[-0mm] - \end{tabular} - \end{center} - - In \cite{UrbanTasson05} we showed how the weaker induction principles imply - the stronger ones. This was done by some quite complicated, nevertheless automated, - induction proof. In this paper we simplify this work by leveraging the automated proof - methods from the function package of Isabelle/HOL. - The reasoning principle these methods employ is well-founded induction. - To use them in our setting, we have to discharge - two proof obligations: one is that we have - well-founded measures (for each type @{text "ty"}$^\alpha_{1..n}$) that decrease in - every induction step and the other is that we have covered all cases. - As measures we use the size functions - @{text "size_ty"}$^\alpha_{1..n}$, which we lifted in the previous section and which are - all well-founded. %It is straightforward to establish that these measures decrease - %in every induction step. - - What is left to show is that we covered all cases. To do so, we use - a \emph{cases lemma} derived for each type. For the terms in \eqref{letpat} - this lemma is of the form - % - \begin{equation}\label{weakcases} - \infer{@{text "P\<^bsub>trm\<^esub>"}} - {\begin{array}{l@ {\hspace{9mm}}l} - @{text "\x. t = Var x \ P\<^bsub>trm\<^esub>"} & @{text "\a t'. t = Lam a t' \ P\<^bsub>trm\<^esub>"}\\ - @{text "\t\<^isub>1 t\<^isub>2. t = App t\<^isub>1 t\<^isub>2 \ P\<^bsub>trm\<^esub>"} & @{text "\p t'. t = Let p t' \ P\<^bsub>trm\<^esub>"}\\ - \end{array}}\\[-1mm] - \end{equation} - % - where we have a premise for each term-constructor. - The idea behind such cases lemmas is that we can conclude with a property @{text "P\<^bsub>trm\<^esub>"}, - provided we can show that this property holds if we substitute for @{text "t"} all - possible term-constructors. - - The only remaining difficulty is that in order to derive the stronger induction - principles conveniently, the cases lemma in \eqref{weakcases} is too weak. For this note that - in order to apply this lemma, we have to establish @{text "P\<^bsub>trm\<^esub>"} for \emph{all} @{text Lam}- and - \emph{all} @{text Let}-terms. - What we need instead is a cases lemma where we only have to consider terms that have - binders that are fresh w.r.t.~a context @{text "c"}. This gives the implications - % - \begin{center} - \begin{tabular}{l} - @{text "\a t'. t = Lam a t' \ {atom a} \\<^sup>* c \ P\<^bsub>trm\<^esub>"}\\ - @{text "\p t'. t = Let p t' \ (set (bn p)) \\<^sup>* c \ P\<^bsub>trm\<^esub>"}\\%[-2mm] - \end{tabular} - \end{center} - % - \noindent - which however can be relatively easily be derived from the implications in \eqref{weakcases} - by a renaming using Properties \ref{supppermeq} and \ref{avoiding}. In the first case we know - that @{text "{atom a} \\<^sup>* Lam a t"}. Property \eqref{avoiding} provides us therefore with - a permutation @{text q}, such that @{text "{atom (q \ a)} \\<^sup>* c"} and - @{text "supp (Lam a t) \\<^sup>* q"} hold. - By using Property \ref{supppermeq}, we can infer from the latter - that @{text "Lam (q \ a) (q \ t) = Lam a t"} - and we are done with this case. - - The @{text Let}-case involving a (non-recursive) deep binder is a bit more complicated. - The reason is that the we cannot apply Property \ref{avoiding} to the whole term @{text "Let p t"}, - because @{text p} might contain names bound by @{text bn}, but also some that are - free. To solve this problem we have to introduce a permutation function that only - permutes names bound by @{text bn} and leaves the other names unchanged. We do this again - by lifting. For a - clause @{text "bn (C x\<^isub>1 \ x\<^isub>r) = rhs"}, we define - % - \begin{center} - @{text "p \\<^bsub>bn\<^esub> (C x\<^isub>1 \ x\<^isub>r) \ C y\<^isub>1 \ y\<^isub>r"} with - $\begin{cases} - \text{@{text "y\<^isub>i \ x\<^isub>i"} provided @{text "x\<^isub>i"} does not occur in @{text "rhs"}}\\ - \text{@{text "y\<^isub>i \ p \\<^bsub>bn'\<^esub> x\<^isub>i"} provided @{text "bn' x\<^isub>i"} is in @{text "rhs"}}\\ - \text{@{text "y\<^isub>i \ p \ x\<^isub>i"} otherwise} - \end{cases}$ - \end{center} - % - %\noindent - %with @{text "y\<^isub>i"} determined as follows: - % - %\begin{center} - %\begin{tabular}{c@ {\hspace{2mm}}p{0.9\textwidth}} - %$\bullet$ & @{text "y\<^isub>i \ x\<^isub>i"} provided @{text "x\<^isub>i"} does not occur in @{text "rhs"}\\ - %$\bullet$ & @{text "y\<^isub>i \ p \\<^bsub>bn'\<^esub> x\<^isub>i"} provided @{text "bn' x\<^isub>i"} is in @{text "rhs"}\\ - %$\bullet$ & @{text "y\<^isub>i \ p \ x\<^isub>i"} otherwise - %\end{tabular} - %\end{center} - % - \noindent - Now Properties \ref{supppermeq} and \ref{avoiding} give us a permutation @{text q} such that - @{text "(set (bn (q \\<^bsub>bn\<^esub> p)) \\<^sup>* c"} holds and such that @{text "[q \\<^bsub>bn\<^esub> p]\<^bsub>list\<^esub>.(q \ t)"} - is equal to @{text "[p]\<^bsub>list\<^esub>. t"}. We can also show that @{text "(q \\<^bsub>bn\<^esub> p) \\<^bsub>bn\<^esub> p"}. - These facts establish that @{text "Let (q \\<^bsub>bn\<^esub> p) (p \ t) = Let p t"}, as we need. This - completes the non-trivial cases in \eqref{letpat} for strengthening the corresponding induction - principle. - - - - %A natural question is - %whether we can also strengthen the weak induction principles involving - %the general binders presented here. We will indeed be able to so, but for this we need an - %additional notion for permuting deep binders. - - %Given a binding function @{text "bn"} we define an auxiliary permutation - %operation @{text "_ \\<^bsub>bn\<^esub> _"} which permutes only bound arguments in a deep binder. - %Assuming a clause of @{text bn} is given as - % - %\begin{center} - %@{text "bn (C x\<^isub>1 \ x\<^isub>r) = rhs"}, - %\end{center} - - %\noindent - %then we define - % - %\begin{center} - %@{text "p \\<^bsub>bn\<^esub> (C x\<^isub>1 \ x\<^isub>r) \ C y\<^isub>1 \ y\<^isub>r"} - %\end{center} - - %\noindent - %with @{text "y\<^isub>i"} determined as follows: - % - %\begin{center} - %\begin{tabular}{c@ {\hspace{2mm}}p{7cm}} - %$\bullet$ & @{text "y\<^isub>i \ x\<^isub>i"} provided @{text "x\<^isub>i"} does not occur in @{text "rhs"}\\ - %$\bullet$ & @{text "y\<^isub>i \ p \\<^bsub>bn'\<^esub> x\<^isub>i"} provided @{text "bn' x\<^isub>i"} is in @{text "rhs"}\\ - %$\bullet$ & @{text "y\<^isub>i \ p \ x\<^isub>i"} otherwise - %\end{tabular} - %\end{center} - - %\noindent - %Using again the quotient package we can lift the @{text "_ \\<^bsub>bn\<^esub> _"} function to - %$\alpha$-equated terms. We can then prove the following two facts - - %\begin{lemma}\label{permutebn} - %Given a binding function @{text "bn\<^sup>\"} then for all @{text p} - %{\it (i)} @{text "p \ (bn\<^sup>\ x) = bn\<^sup>\ (p \\\<^bsub>bn\<^esub> x)"} and {\it (ii)} - % @{text "fa_bn\<^isup>\ x = fa_bn\<^isup>\ (p \\\<^bsub>bn\<^esub> x)"}. - %\end{lemma} - - %\begin{proof} - %By induction on @{text x}. The equations follow by simple unfolding - %of the definitions. - %\end{proof} - - %\noindent - %The first property states that a permutation applied to a binding function is - %equivalent to first permuting the binders and then calculating the bound - %atoms. The second amounts to the fact that permuting the binders has no - %effect on the free-atom function. The main point of this permutation - %function, however, is that if we have a permutation that is fresh - %for the support of an object @{text x}, then we can use this permutation - %to rename the binders in @{text x}, without ``changing'' @{text x}. In case of the - %@{text "Let"} term-constructor from the example shown - %in \eqref{letpat} this means for a permutation @{text "r"} - %% - %\begin{equation}\label{renaming} - %\begin{array}{l} - %\mbox{if @{term "supp (Abs_lst (bn p) t\<^isub>2) \* r"}}\\ - %\qquad\mbox{then @{text "Let p t\<^isub>1 t\<^isub>2 = Let (r \\\<^bsub>bn_pat\<^esub> p) t\<^isub>1 (r \ t\<^isub>2)"}} - %\end{array} - %\end{equation} - - %\noindent - %This fact will be crucial when establishing the strong induction principles below. - - - %In our running example about @{text "Let"}, the strong induction - %principle means that instead - %of establishing the implication - % - %\begin{center} - %@{text "\p t\<^isub>1 t\<^isub>2. P\<^bsub>pat\<^esub> p \ P\<^bsub>trm\<^esub> t\<^isub>1 \ P\<^bsub>trm\<^esub> t\<^isub>2 \ P\<^bsub>trm\<^esub> (Let p t\<^isub>1 t\<^isub>2)"} - %\end{center} - % - %\noindent - %it is sufficient to establish the following implication - % - %\begin{equation}\label{strong} - %\mbox{\begin{tabular}{l} - %@{text "\p t\<^isub>1 t\<^isub>2 c."}\\ - %\hspace{5mm}@{text "set (bn p) #\<^sup>* c \"}\\ - %\hspace{5mm}@{text "(\d. P\<^bsub>pat\<^esub> d p) \ (\d. P\<^bsub>trm\<^esub> d t\<^isub>1) \ (\d. P\<^bsub>trm\<^esub> d t\<^isub>2)"}\\ - %\hspace{15mm}@{text "\ P\<^bsub>trm\<^esub> c (Let p t\<^isub>1 t\<^isub>2)"} - %\end{tabular}} - %\end{equation} - % - %\noindent - %While this implication contains an additional argument, namely @{text c}, and - %also additional universal quantifications, it is usually easier to establish. - %The reason is that we have the freshness - %assumption @{text "set (bn\<^sup>\ p) #\<^sup>* c"}, whereby @{text c} can be arbitrarily - %chosen by the user as long as it has finite support. - % - %Let us now show how we derive the strong induction principles from the - %weak ones. In case of the @{text "Let"}-example we derive by the weak - %induction the following two properties - % - %\begin{equation}\label{hyps} - %@{text "\q c. P\<^bsub>trm\<^esub> c (q \ t)"} \hspace{4mm} - %@{text "\q\<^isub>1 q\<^isub>2 c. P\<^bsub>pat\<^esub> (q\<^isub>1 \\\<^bsub>bn\<^esub> (q\<^isub>2 \ p))"} - %\end{equation} - % - %\noindent - %For the @{text Let} term-constructor we therefore have to establish @{text "P\<^bsub>trm\<^esub> c (q \ Let p t\<^isub>1 t\<^isub>2)"} - %assuming \eqref{hyps} as induction hypotheses (the first for @{text t\<^isub>1} and @{text t\<^isub>2}). - %By Property~\ref{avoiding} we - %obtain a permutation @{text "r"} such that - % - %\begin{equation}\label{rprops} - %@{term "(r \ set (bn (q \ p))) \* c "}\hspace{4mm} - %@{term "supp (Abs_lst (bn (q \ p)) (q \ t\<^isub>2)) \* r"} - %\end{equation} - % - %\noindent - %hold. The latter fact and \eqref{renaming} give us - %% - %\begin{center} - %\begin{tabular}{l} - %@{text "Let (q \ p) (q \ t\<^isub>1) (q \ t\<^isub>2) ="} \\ - %\hspace{15mm}@{text "Let (r \\\<^bsub>bn\<^esub> (q \ p)) (q \ t\<^isub>1) (r \ (q \ t\<^isub>2))"} - %\end{tabular} - %\end{center} - % - %\noindent - %So instead of proving @{text "P\<^bsub>trm\<^esub> c (q \ Let p t\<^isub>1 t\<^isub>2)"}, we can equally - %establish @{text "P\<^bsub>trm\<^esub> c (Let (r \\\<^bsub>bn\<^esub> (q \ p)) (q \ t\<^isub>1) (r \ (q \ t\<^isub>2)))"}. - %To do so, we will use the implication \eqref{strong} of the strong induction - %principle, which requires us to discharge - %the following four proof obligations: - %% - %\begin{center} - %\begin{tabular}{rl} - %{\it (i)} & @{text "set (bn (r \\\<^bsub>bn\<^esub> (q \ p))) #\<^sup>* c"}\\ - %{\it (ii)} & @{text "\d. P\<^bsub>pat\<^esub> d (r \\\<^bsub>bn\<^esub> (q \ p))"}\\ - %{\it (iii)} & @{text "\d. P\<^bsub>trm\<^esub> d (q \ t\<^isub>1)"}\\ - %{\it (iv)} & @{text "\d. P\<^bsub>trm\<^esub> d (r \ (q \ t\<^isub>2))"}\\ - %\end{tabular} - %\end{center} - % - %\noindent - %The first follows from \eqref{rprops} and Lemma~\ref{permutebn}.{\it (i)}; the - %others from the induction hypotheses in \eqref{hyps} (in the fourth case - %we have to use the fact that @{term "(r \ (q \ t\<^isub>2)) = (r + q) \ t\<^isub>2"}). - % - %Taking now the identity permutation @{text 0} for the permutations in \eqref{hyps}, - %we can establish our original goals, namely @{text "P\<^bsub>trm\<^esub> c t"} and \mbox{@{text "P\<^bsub>pat\<^esub> c p"}}. - %This completes the proof showing that the weak induction principles imply - %the strong induction principles. -*} - - -section {* Related Work\label{related} *} - -text {* - To our knowledge the earliest usage of general binders in a theorem prover - is described in \cite{NaraschewskiNipkow99} about a formalisation of the - algorithm W. This formalisation implements binding in type-schemes using a - de-Bruijn indices representation. Since type-schemes in W contain only a single - place where variables are bound, different indices do not refer to different binders (as in the usual - de-Bruijn representation), but to different bound variables. A similar idea - has been recently explored for general binders in the locally nameless - approach to binding \cite{chargueraud09}. There, de-Bruijn indices consist - of two numbers, one referring to the place where a variable is bound, and the - other to which variable is bound. The reasoning infrastructure for both - representations of bindings comes for free in theorem provers like Isabelle/HOL or - Coq, since the corresponding term-calculi can be implemented as ``normal'' - datatypes. However, in both approaches it seems difficult to achieve our - fine-grained control over the ``semantics'' of bindings (i.e.~whether the - order of binders should matter, or vacuous binders should be taken into - account). %To do so, one would require additional predicates that filter out - %unwanted terms. Our guess is that such predicates result in rather - %intricate formal reasoning. - - Another technique for representing binding is higher-order abstract syntax - (HOAS). %, which for example is implemented in the Twelf system. - This %%representation - technique supports very elegantly many aspects of \emph{single} binding, and - impressive work has been done that uses HOAS for mechanising the metatheory - of SML~\cite{LeeCraryHarper07}. We are, however, not aware how multiple - binders of SML are represented in this work. Judging from the submitted - Twelf-solution for the POPLmark challenge, HOAS cannot easily deal with - binding constructs where the number of bound variables is not fixed. %For example - In the second part of this challenge, @{text "Let"}s involve - patterns that bind multiple variables at once. In such situations, HOAS - seems to have to resort to the iterated-single-binders-approach with - all the unwanted consequences when reasoning about the resulting terms. - - %Two formalisations involving general binders have been - %performed in older - %versions of Nominal Isabelle (one about Psi-calculi and one about algorithm W - %\cite{BengtsonParow09,UrbanNipkow09}). Both - %use the approach based on iterated single binders. Our experience with - %the latter formalisation has been disappointing. The major pain arose from - %the need to ``unbind'' variables. This can be done in one step with our - %general binders described in this paper, but needs a cumbersome - %iteration with single binders. The resulting formal reasoning turned out to - %be rather unpleasant. The hope is that the extension presented in this paper - %is a substantial improvement. - - The most closely related work to the one presented here is the Ott-tool - \cite{ott-jfp} and the C$\alpha$ml language \cite{Pottier06}. Ott is a nifty - front-end for creating \LaTeX{} documents from specifications of - term-calculi involving general binders. For a subset of the specifications - Ott can also generate theorem prover code using a raw representation of - terms, and in Coq also a locally nameless representation. The developers of - this tool have also put forward (on paper) a definition for - $\alpha$-equivalence of terms that can be specified in Ott. This definition is - rather different from ours, not using any nominal techniques. To our - knowledge there is no concrete mathematical result concerning this - notion of $\alpha$-equivalence. Also the definition for the - notion of free variables - is work in progress. - - Although we were heavily inspired by the syntax of Ott, - its definition of $\alpha$-equi\-valence is unsuitable for our extension of - Nominal Isabelle. First, it is far too complicated to be a basis for - automated proofs implemented on the ML-level of Isabelle/HOL. Second, it - covers cases of binders depending on other binders, which just do not make - sense for our $\alpha$-equated terms. Third, it allows empty types that have no - meaning in a HOL-based theorem prover. We also had to generalise slightly Ott's - binding clauses. In Ott you specify binding clauses with a single body; we - allow more than one. We have to do this, because this makes a difference - for our notion of $\alpha$-equivalence in case of \isacommand{bind (set)} and - \isacommand{bind (set+)}. - % - %Consider the examples - % - %\begin{center} - %\begin{tabular}{@ {}l@ {\hspace{2mm}}l@ {}} - %@{text "Foo\<^isub>1 xs::name fset t::trm s::trm"} & - % \isacommand{bind (set)} @{text "xs"} \isacommand{in} @{text "t s"}\\ - %@{text "Foo\<^isub>2 xs::name fset t::trm s::trm"} & - % \isacommand{bind (set)} @{text "xs"} \isacommand{in} @{text "t"}, - % \isacommand{bind (set)} @{text "xs"} \isacommand{in} @{text "s"}\\ - %\end{tabular} - %\end{center} - % - %\noindent - %In the first term-constructor we have a single - %body that happens to be ``spread'' over two arguments; in the second term-constructor we have - %two independent bodies in which the same variables are bound. As a result we - %have - % - %\begin{center} - %\begin{tabular}{r@ {\hspace{1.5mm}}c@ {\hspace{1.5mm}}l} - %@{text "Foo\<^isub>1 {a, b} (a, b) (a, b)"} & $\not=$ & - %@{text "Foo\<^isub>1 {a, b} (a, b) (b, a)"}\\ - %@{text "Foo\<^isub>2 {a, b} (a, b) (a, b)"} & $=$ & - %@{text "Foo\<^isub>2 {a, b} (a, b) (b, a)"}\\ - %\end{tabular} - %\end{center} - % - %\noindent - %and therefore need the extra generality to be able to distinguish between - %both specifications. - Because of how we set up our definitions, we also had to impose some restrictions - (like a single binding function for a deep binder) that are not present in Ott. - %Our - %expectation is that we can still cover many interesting term-calculi from - %programming language research, for example Core-Haskell. - - Pottier presents in \cite{Pottier06} a language, called C$\alpha$ml, for - representing terms with general binders inside OCaml. This language is - implemented as a front-end that can be translated to OCaml with the help of - a library. He presents a type-system in which the scope of general binders - can be specified using special markers, written @{text "inner"} and - @{text "outer"}. It seems our and his specifications can be - inter-translated as long as ours use the binding mode - \isacommand{bind} only. - However, we have not proved this. Pottier gives a definition for - $\alpha$-equivalence, which also uses a permutation operation (like ours). - Still, this definition is rather different from ours and he only proves that - it defines an equivalence relation. A complete - reasoning infrastructure is well beyond the purposes of his language. - Similar work for Haskell with similar results was reported by Cheney \cite{Cheney05a}. - - In a slightly different domain (programming with dependent types), the - paper \cite{Altenkirch10} presents a calculus with a notion of - $\alpha$-equivalence related to our binding mode \isacommand{bind (set+)}. - The definition in \cite{Altenkirch10} is similar to the one by Pottier, except that it - has a more operational flavour and calculates a partial (renaming) map. - In this way, the definition can deal with vacuous binders. However, to our - best knowledge, no concrete mathematical result concerning this - definition of $\alpha$-equivalence has been proved.\\[-7mm] -*} - -section {* Conclusion *} - -text {* - We have presented an extension of Nominal Isabelle for dealing with - general binders, that is term-constructors having multiple bound - variables. For this extension we introduced new definitions of - $\alpha$-equivalence and automated all necessary proofs in Isabelle/HOL. - To specify general binders we used the specifications from Ott, but extended them - in some places and restricted - them in others so that they make sense in the context of $\alpha$-equated terms. - We also introduced two binding modes (set and set+) that do not - exist in Ott. - We have tried out the extension with calculi such as Core-Haskell, type-schemes - and approximately a dozen of other typical examples from programming - language research~\cite{SewellBestiary}. - %The code - %will eventually become part of the next Isabelle distribution.\footnote{For the moment - %it can be downloaded from the Mercurial repository linked at - %\href{http://isabelle.in.tum.de/nominal/download} - %{http://isabelle.in.tum.de/nominal/download}.} - - We have left out a discussion about how functions can be defined over - $\alpha$-equated terms involving general binders. In earlier versions of Nominal - Isabelle this turned out to be a thorny issue. We - hope to do better this time by using the function package that has recently - been implemented in Isabelle/HOL and also by restricting function - definitions to equivariant functions (for them we can - provide more automation). - - %There are some restrictions we imposed in this paper that we would like to lift in - %future work. One is the exclusion of nested datatype definitions. Nested - %datatype definitions allow one to specify, for instance, the function kinds - %in Core-Haskell as @{text "TFun string (ty list)"} instead of the unfolded - %version @{text "TFun string ty_list"} (see Figure~\ref{nominalcorehas}). To - %achieve this, we need a slightly more clever implementation than we have at the moment. - - %A more interesting line of investigation is whether we can go beyond the - %simple-minded form of binding functions that we adopted from Ott. At the moment, binding - %functions can only return the empty set, a singleton atom set or unions - %of atom sets (similarly for lists). It remains to be seen whether - %properties like - %% - %\begin{center} - %@{text "fa_ty x = bn x \ fa_bn x"}. - %\end{center} - % - %\noindent - %allow us to support more interesting binding functions. - % - %We have also not yet played with other binding modes. For example we can - %imagine that there is need for a binding mode - %where instead of lists, we abstract lists of distinct elements. - %Once we feel confident about such binding modes, our implementation - %can be easily extended to accommodate them. - % - \smallskip - \noindent - {\bf Acknowledgements:} %We are very grateful to Andrew Pitts for - %many discussions about Nominal Isabelle. - We thank Peter Sewell for - making the informal notes \cite{SewellBestiary} available to us and - also for patiently explaining some of the finer points of the Ott-tool.\\[-7mm] - %Stephanie Weirich suggested to separate the subgrammars - %of kinds and types in our Core-Haskell example. \\[-6mm] -*} - - -(*<*) -end -(*>*) diff -r a6f3e1b08494 -r b6873d123f9b ESOP-Paper/ROOT.ML --- a/ESOP-Paper/ROOT.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -quick_and_dirty := true; -no_document use_thys ["~~/src/HOL/Library/LaTeXsugar", - "../Nominal/Nominal2"]; -use_thys ["Paper"]; \ No newline at end of file diff -r a6f3e1b08494 -r b6873d123f9b ESOP-Paper/ROOTa.ML --- a/ESOP-Paper/ROOTa.ML Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,4 +0,0 @@ -quick_and_dirty := true; -no_document use_thys ["~~/src/HOL/Library/LaTeXsugar", - "../Nominal/Nominal2"]; -use_thys ["Appendix"]; \ No newline at end of file diff -r a6f3e1b08494 -r b6873d123f9b ESOP-Paper/document/llncs.cls --- a/ESOP-Paper/document/llncs.cls Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1207 +0,0 @@ -% LLNCS DOCUMENT CLASS -- version 2.17 (12-Jul-2010) -% Springer Verlag LaTeX2e support for Lecture Notes in Computer Science -% -%% -%% \CharacterTable -%% {Upper-case \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z -%% Lower-case \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z -%% Digits \0\1\2\3\4\5\6\7\8\9 -%% Exclamation \! Double quote \" Hash (number) \# -%% Dollar \$ Percent \% Ampersand \& -%% Acute accent \' Left paren \( Right paren \) -%% Asterisk \* Plus \+ Comma \, -%% Minus \- Point \. Solidus \/ -%% Colon \: Semicolon \; Less than \< -%% Equals \= Greater than \> Question mark \? -%% Commercial at \@ Left bracket \[ Backslash \\ -%% Right bracket \] Circumflex \^ Underscore \_ -%% Grave accent \` Left brace \{ Vertical bar \| -%% Right brace \} Tilde \~} -%% -\NeedsTeXFormat{LaTeX2e}[1995/12/01] -\ProvidesClass{llncs}[2010/07/12 v2.17 -^^J LaTeX document class for Lecture Notes in Computer Science] -% Options -\let\if@envcntreset\iffalse -\DeclareOption{envcountreset}{\let\if@envcntreset\iftrue} -\DeclareOption{citeauthoryear}{\let\citeauthoryear=Y} -\DeclareOption{oribibl}{\let\oribibl=Y} -\let\if@custvec\iftrue -\DeclareOption{orivec}{\let\if@custvec\iffalse} -\let\if@envcntsame\iffalse -\DeclareOption{envcountsame}{\let\if@envcntsame\iftrue} -\let\if@envcntsect\iffalse -\DeclareOption{envcountsect}{\let\if@envcntsect\iftrue} -\let\if@runhead\iffalse -\DeclareOption{runningheads}{\let\if@runhead\iftrue} - -\let\if@openright\iftrue -\let\if@openbib\iffalse -\DeclareOption{openbib}{\let\if@openbib\iftrue} - -% languages -\let\switcht@@therlang\relax -\def\ds@deutsch{\def\switcht@@therlang{\switcht@deutsch}} -\def\ds@francais{\def\switcht@@therlang{\switcht@francais}} - -\DeclareOption*{\PassOptionsToClass{\CurrentOption}{article}} - -\ProcessOptions - -\LoadClass[twoside]{article} -\RequirePackage{multicol} % needed for the list of participants, index -\RequirePackage{aliascnt} - -\setlength{\textwidth}{12.2cm} -\setlength{\textheight}{19.3cm} -\renewcommand\@pnumwidth{2em} -\renewcommand\@tocrmarg{3.5em} -% -\def\@dottedtocline#1#2#3#4#5{% - \ifnum #1>\c@tocdepth \else - \vskip \z@ \@plus.2\p@ - {\leftskip #2\relax \rightskip \@tocrmarg \advance\rightskip by 0pt plus 2cm - \parfillskip -\rightskip \pretolerance=10000 - \parindent #2\relax\@afterindenttrue - \interlinepenalty\@M - \leavevmode - \@tempdima #3\relax - \advance\leftskip \@tempdima \null\nobreak\hskip -\leftskip - {#4}\nobreak - \leaders\hbox{$\m@th - \mkern \@dotsep mu\hbox{.}\mkern \@dotsep - mu$}\hfill - \nobreak - \hb@xt@\@pnumwidth{\hfil\normalfont \normalcolor #5}% - \par}% - \fi} -% -\def\switcht@albion{% -\def\abstractname{Abstract.} -\def\ackname{Acknowledgement.} -\def\andname{and} -\def\lastandname{\unskip, and} -\def\appendixname{Appendix} -\def\chaptername{Chapter} -\def\claimname{Claim} -\def\conjecturename{Conjecture} -\def\contentsname{Table of Contents} -\def\corollaryname{Corollary} -\def\definitionname{Definition} -\def\examplename{Example} -\def\exercisename{Exercise} -\def\figurename{Fig.} -\def\keywordname{{\bf Keywords:}} -\def\indexname{Index} -\def\lemmaname{Lemma} -\def\contriblistname{List of Contributors} -\def\listfigurename{List of Figures} -\def\listtablename{List of Tables} -\def\mailname{{\it Correspondence to\/}:} -\def\noteaddname{Note added in proof} -\def\notename{Note} -\def\partname{Part} -\def\problemname{Problem} -\def\proofname{Proof} -\def\propertyname{Property} -\def\propositionname{Proposition} -\def\questionname{Question} -\def\remarkname{Remark} -\def\seename{see} -\def\solutionname{Solution} -\def\subclassname{{\it Subject Classifications\/}:} -\def\tablename{Table} -\def\theoremname{Theorem}} -\switcht@albion -% Names of theorem like environments are already defined -% but must be translated if another language is chosen -% -% French section -\def\switcht@francais{%\typeout{On parle francais.}% - \def\abstractname{R\'esum\'e.}% - \def\ackname{Remerciements.}% - \def\andname{et}% - \def\lastandname{ et}% - \def\appendixname{Appendice} - \def\chaptername{Chapitre}% - \def\claimname{Pr\'etention}% - \def\conjecturename{Hypoth\`ese}% - \def\contentsname{Table des mati\`eres}% - \def\corollaryname{Corollaire}% - \def\definitionname{D\'efinition}% - \def\examplename{Exemple}% - \def\exercisename{Exercice}% - \def\figurename{Fig.}% - \def\keywordname{{\bf Mots-cl\'e:}} - \def\indexname{Index} - \def\lemmaname{Lemme}% - \def\contriblistname{Liste des contributeurs} - \def\listfigurename{Liste des figures}% - \def\listtablename{Liste des tables}% - \def\mailname{{\it Correspondence to\/}:} - \def\noteaddname{Note ajout\'ee \`a l'\'epreuve}% - \def\notename{Remarque}% - \def\partname{Partie}% - \def\problemname{Probl\`eme}% - \def\proofname{Preuve}% - \def\propertyname{Caract\'eristique}% -%\def\propositionname{Proposition}% - \def\questionname{Question}% - \def\remarkname{Remarque}% - \def\seename{voir} - \def\solutionname{Solution}% - \def\subclassname{{\it Subject Classifications\/}:} - \def\tablename{Tableau}% - \def\theoremname{Th\'eor\`eme}% -} -% -% German section -\def\switcht@deutsch{%\typeout{Man spricht deutsch.}% - \def\abstractname{Zusammenfassung.}% - \def\ackname{Danksagung.}% - \def\andname{und}% - \def\lastandname{ und}% - \def\appendixname{Anhang}% - \def\chaptername{Kapitel}% - \def\claimname{Behauptung}% - \def\conjecturename{Hypothese}% - \def\contentsname{Inhaltsverzeichnis}% - \def\corollaryname{Korollar}% -%\def\definitionname{Definition}% - \def\examplename{Beispiel}% - \def\exercisename{\"Ubung}% - \def\figurename{Abb.}% - \def\keywordname{{\bf Schl\"usselw\"orter:}} - \def\indexname{Index} -%\def\lemmaname{Lemma}% - \def\contriblistname{Mitarbeiter} - \def\listfigurename{Abbildungsverzeichnis}% - \def\listtablename{Tabellenverzeichnis}% - \def\mailname{{\it Correspondence to\/}:} - \def\noteaddname{Nachtrag}% - \def\notename{Anmerkung}% - \def\partname{Teil}% -%\def\problemname{Problem}% - \def\proofname{Beweis}% - \def\propertyname{Eigenschaft}% -%\def\propositionname{Proposition}% - \def\questionname{Frage}% - \def\remarkname{Anmerkung}% - \def\seename{siehe} - \def\solutionname{L\"osung}% - \def\subclassname{{\it Subject Classifications\/}:} - \def\tablename{Tabelle}% -%\def\theoremname{Theorem}% -} - -% Ragged bottom for the actual page -\def\thisbottomragged{\def\@textbottom{\vskip\z@ plus.0001fil -\global\let\@textbottom\relax}} - -\renewcommand\small{% - \@setfontsize\small\@ixpt{11}% - \abovedisplayskip 8.5\p@ \@plus3\p@ \@minus4\p@ - \abovedisplayshortskip \z@ \@plus2\p@ - \belowdisplayshortskip 4\p@ \@plus2\p@ \@minus2\p@ - \def\@listi{\leftmargin\leftmargini - \parsep 0\p@ \@plus1\p@ \@minus\p@ - \topsep 8\p@ \@plus2\p@ \@minus4\p@ - \itemsep0\p@}% - \belowdisplayskip \abovedisplayskip -} - -\frenchspacing -\widowpenalty=10000 -\clubpenalty=10000 - -\setlength\oddsidemargin {63\p@} -\setlength\evensidemargin {63\p@} -\setlength\marginparwidth {90\p@} - -\setlength\headsep {16\p@} - -\setlength\footnotesep{7.7\p@} -\setlength\textfloatsep{8mm\@plus 2\p@ \@minus 4\p@} -\setlength\intextsep {8mm\@plus 2\p@ \@minus 2\p@} - -\setcounter{secnumdepth}{2} - -\newcounter {chapter} -\renewcommand\thechapter {\@arabic\c@chapter} - -\newif\if@mainmatter \@mainmattertrue -\newcommand\frontmatter{\cleardoublepage - \@mainmatterfalse\pagenumbering{Roman}} -\newcommand\mainmatter{\cleardoublepage - \@mainmattertrue\pagenumbering{arabic}} -\newcommand\backmatter{\if@openright\cleardoublepage\else\clearpage\fi - \@mainmatterfalse} - -\renewcommand\part{\cleardoublepage - \thispagestyle{empty}% - \if@twocolumn - \onecolumn - \@tempswatrue - \else - \@tempswafalse - \fi - \null\vfil - \secdef\@part\@spart} - -\def\@part[#1]#2{% - \ifnum \c@secnumdepth >-2\relax - \refstepcounter{part}% - \addcontentsline{toc}{part}{\thepart\hspace{1em}#1}% - \else - \addcontentsline{toc}{part}{#1}% - \fi - \markboth{}{}% - {\centering - \interlinepenalty \@M - \normalfont - \ifnum \c@secnumdepth >-2\relax - \huge\bfseries \partname~\thepart - \par - \vskip 20\p@ - \fi - \Huge \bfseries #2\par}% - \@endpart} -\def\@spart#1{% - {\centering - \interlinepenalty \@M - \normalfont - \Huge \bfseries #1\par}% - \@endpart} -\def\@endpart{\vfil\newpage - \if@twoside - \null - \thispagestyle{empty}% - \newpage - \fi - \if@tempswa - \twocolumn - \fi} - -\newcommand\chapter{\clearpage - \thispagestyle{empty}% - \global\@topnum\z@ - \@afterindentfalse - \secdef\@chapter\@schapter} -\def\@chapter[#1]#2{\ifnum \c@secnumdepth >\m@ne - \if@mainmatter - \refstepcounter{chapter}% - \typeout{\@chapapp\space\thechapter.}% - \addcontentsline{toc}{chapter}% - {\protect\numberline{\thechapter}#1}% - \else - \addcontentsline{toc}{chapter}{#1}% - \fi - \else - \addcontentsline{toc}{chapter}{#1}% - \fi - \chaptermark{#1}% - \addtocontents{lof}{\protect\addvspace{10\p@}}% - \addtocontents{lot}{\protect\addvspace{10\p@}}% - \if@twocolumn - \@topnewpage[\@makechapterhead{#2}]% - \else - \@makechapterhead{#2}% - \@afterheading - \fi} -\def\@makechapterhead#1{% -% \vspace*{50\p@}% - {\centering - \ifnum \c@secnumdepth >\m@ne - \if@mainmatter - \large\bfseries \@chapapp{} \thechapter - \par\nobreak - \vskip 20\p@ - \fi - \fi - \interlinepenalty\@M - \Large \bfseries #1\par\nobreak - \vskip 40\p@ - }} -\def\@schapter#1{\if@twocolumn - \@topnewpage[\@makeschapterhead{#1}]% - \else - \@makeschapterhead{#1}% - \@afterheading - \fi} -\def\@makeschapterhead#1{% -% \vspace*{50\p@}% - {\centering - \normalfont - \interlinepenalty\@M - \Large \bfseries #1\par\nobreak - \vskip 40\p@ - }} - -\renewcommand\section{\@startsection{section}{1}{\z@}% - {-18\p@ \@plus -4\p@ \@minus -4\p@}% - {12\p@ \@plus 4\p@ \@minus 4\p@}% - {\normalfont\large\bfseries\boldmath - \rightskip=\z@ \@plus 8em\pretolerance=10000 }} -\renewcommand\subsection{\@startsection{subsection}{2}{\z@}% - {-18\p@ \@plus -4\p@ \@minus -4\p@}% - {8\p@ \@plus 4\p@ \@minus 4\p@}% - {\normalfont\normalsize\bfseries\boldmath - \rightskip=\z@ \@plus 8em\pretolerance=10000 }} -\renewcommand\subsubsection{\@startsection{subsubsection}{3}{\z@}% - {-18\p@ \@plus -4\p@ \@minus -4\p@}% - {-0.5em \@plus -0.22em \@minus -0.1em}% - {\normalfont\normalsize\bfseries\boldmath}} -\renewcommand\paragraph{\@startsection{paragraph}{4}{\z@}% - {-12\p@ \@plus -4\p@ \@minus -4\p@}% - {-0.5em \@plus -0.22em \@minus -0.1em}% - {\normalfont\normalsize\itshape}} -\renewcommand\subparagraph[1]{\typeout{LLNCS warning: You should not use - \string\subparagraph\space with this class}\vskip0.5cm -You should not use \verb|\subparagraph| with this class.\vskip0.5cm} - -\DeclareMathSymbol{\Gamma}{\mathalpha}{letters}{"00} -\DeclareMathSymbol{\Delta}{\mathalpha}{letters}{"01} -\DeclareMathSymbol{\Theta}{\mathalpha}{letters}{"02} -\DeclareMathSymbol{\Lambda}{\mathalpha}{letters}{"03} -\DeclareMathSymbol{\Xi}{\mathalpha}{letters}{"04} -\DeclareMathSymbol{\Pi}{\mathalpha}{letters}{"05} -\DeclareMathSymbol{\Sigma}{\mathalpha}{letters}{"06} -\DeclareMathSymbol{\Upsilon}{\mathalpha}{letters}{"07} -\DeclareMathSymbol{\Phi}{\mathalpha}{letters}{"08} -\DeclareMathSymbol{\Psi}{\mathalpha}{letters}{"09} -\DeclareMathSymbol{\Omega}{\mathalpha}{letters}{"0A} - -\let\footnotesize\small - -\if@custvec -\def\vec#1{\mathchoice{\mbox{\boldmath$\displaystyle#1$}} -{\mbox{\boldmath$\textstyle#1$}} -{\mbox{\boldmath$\scriptstyle#1$}} -{\mbox{\boldmath$\scriptscriptstyle#1$}}} -\fi - -\def\squareforqed{\hbox{\rlap{$\sqcap$}$\sqcup$}} -\def\qed{\ifmmode\squareforqed\else{\unskip\nobreak\hfil -\penalty50\hskip1em\null\nobreak\hfil\squareforqed -\parfillskip=0pt\finalhyphendemerits=0\endgraf}\fi} - -\def\getsto{\mathrel{\mathchoice {\vcenter{\offinterlineskip -\halign{\hfil -$\displaystyle##$\hfil\cr\gets\cr\to\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\textstyle##$\hfil\cr\gets -\cr\to\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptstyle##$\hfil\cr\gets -\cr\to\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptscriptstyle##$\hfil\cr -\gets\cr\to\cr}}}}} -\def\lid{\mathrel{\mathchoice {\vcenter{\offinterlineskip\halign{\hfil -$\displaystyle##$\hfil\cr<\cr\noalign{\vskip1.2pt}=\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\textstyle##$\hfil\cr<\cr -\noalign{\vskip1.2pt}=\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptstyle##$\hfil\cr<\cr -\noalign{\vskip1pt}=\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptscriptstyle##$\hfil\cr -<\cr -\noalign{\vskip0.9pt}=\cr}}}}} -\def\gid{\mathrel{\mathchoice {\vcenter{\offinterlineskip\halign{\hfil -$\displaystyle##$\hfil\cr>\cr\noalign{\vskip1.2pt}=\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\textstyle##$\hfil\cr>\cr -\noalign{\vskip1.2pt}=\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptstyle##$\hfil\cr>\cr -\noalign{\vskip1pt}=\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptscriptstyle##$\hfil\cr ->\cr -\noalign{\vskip0.9pt}=\cr}}}}} -\def\grole{\mathrel{\mathchoice {\vcenter{\offinterlineskip -\halign{\hfil -$\displaystyle##$\hfil\cr>\cr\noalign{\vskip-1pt}<\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\textstyle##$\hfil\cr ->\cr\noalign{\vskip-1pt}<\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptstyle##$\hfil\cr ->\cr\noalign{\vskip-0.8pt}<\cr}}} -{\vcenter{\offinterlineskip\halign{\hfil$\scriptscriptstyle##$\hfil\cr ->\cr\noalign{\vskip-0.3pt}<\cr}}}}} -\def\bbbr{{\rm I\!R}} %reelle Zahlen -\def\bbbm{{\rm I\!M}} -\def\bbbn{{\rm I\!N}} %natuerliche Zahlen -\def\bbbf{{\rm I\!F}} -\def\bbbh{{\rm I\!H}} -\def\bbbk{{\rm I\!K}} -\def\bbbp{{\rm I\!P}} -\def\bbbone{{\mathchoice {\rm 1\mskip-4mu l} {\rm 1\mskip-4mu l} -{\rm 1\mskip-4.5mu l} {\rm 1\mskip-5mu l}}} -\def\bbbc{{\mathchoice {\setbox0=\hbox{$\displaystyle\rm C$}\hbox{\hbox -to0pt{\kern0.4\wd0\vrule height0.9\ht0\hss}\box0}} -{\setbox0=\hbox{$\textstyle\rm C$}\hbox{\hbox -to0pt{\kern0.4\wd0\vrule height0.9\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptstyle\rm C$}\hbox{\hbox -to0pt{\kern0.4\wd0\vrule height0.9\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptscriptstyle\rm C$}\hbox{\hbox -to0pt{\kern0.4\wd0\vrule height0.9\ht0\hss}\box0}}}} -\def\bbbq{{\mathchoice {\setbox0=\hbox{$\displaystyle\rm -Q$}\hbox{\raise -0.15\ht0\hbox to0pt{\kern0.4\wd0\vrule height0.8\ht0\hss}\box0}} -{\setbox0=\hbox{$\textstyle\rm Q$}\hbox{\raise -0.15\ht0\hbox to0pt{\kern0.4\wd0\vrule height0.8\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptstyle\rm Q$}\hbox{\raise -0.15\ht0\hbox to0pt{\kern0.4\wd0\vrule height0.7\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptscriptstyle\rm Q$}\hbox{\raise -0.15\ht0\hbox to0pt{\kern0.4\wd0\vrule height0.7\ht0\hss}\box0}}}} -\def\bbbt{{\mathchoice {\setbox0=\hbox{$\displaystyle\rm -T$}\hbox{\hbox to0pt{\kern0.3\wd0\vrule height0.9\ht0\hss}\box0}} -{\setbox0=\hbox{$\textstyle\rm T$}\hbox{\hbox -to0pt{\kern0.3\wd0\vrule height0.9\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptstyle\rm T$}\hbox{\hbox -to0pt{\kern0.3\wd0\vrule height0.9\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptscriptstyle\rm T$}\hbox{\hbox -to0pt{\kern0.3\wd0\vrule height0.9\ht0\hss}\box0}}}} -\def\bbbs{{\mathchoice -{\setbox0=\hbox{$\displaystyle \rm S$}\hbox{\raise0.5\ht0\hbox -to0pt{\kern0.35\wd0\vrule height0.45\ht0\hss}\hbox -to0pt{\kern0.55\wd0\vrule height0.5\ht0\hss}\box0}} -{\setbox0=\hbox{$\textstyle \rm S$}\hbox{\raise0.5\ht0\hbox -to0pt{\kern0.35\wd0\vrule height0.45\ht0\hss}\hbox -to0pt{\kern0.55\wd0\vrule height0.5\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptstyle \rm S$}\hbox{\raise0.5\ht0\hbox -to0pt{\kern0.35\wd0\vrule height0.45\ht0\hss}\raise0.05\ht0\hbox -to0pt{\kern0.5\wd0\vrule height0.45\ht0\hss}\box0}} -{\setbox0=\hbox{$\scriptscriptstyle\rm S$}\hbox{\raise0.5\ht0\hbox -to0pt{\kern0.4\wd0\vrule height0.45\ht0\hss}\raise0.05\ht0\hbox -to0pt{\kern0.55\wd0\vrule height0.45\ht0\hss}\box0}}}} -\def\bbbz{{\mathchoice {\hbox{$\mathsf\textstyle Z\kern-0.4em Z$}} -{\hbox{$\mathsf\textstyle Z\kern-0.4em Z$}} -{\hbox{$\mathsf\scriptstyle Z\kern-0.3em Z$}} -{\hbox{$\mathsf\scriptscriptstyle Z\kern-0.2em Z$}}}} - -\let\ts\, - -\setlength\leftmargini {17\p@} -\setlength\leftmargin {\leftmargini} -\setlength\leftmarginii {\leftmargini} -\setlength\leftmarginiii {\leftmargini} -\setlength\leftmarginiv {\leftmargini} -\setlength \labelsep {.5em} -\setlength \labelwidth{\leftmargini} -\addtolength\labelwidth{-\labelsep} - -\def\@listI{\leftmargin\leftmargini - \parsep 0\p@ \@plus1\p@ \@minus\p@ - \topsep 8\p@ \@plus2\p@ \@minus4\p@ - \itemsep0\p@} -\let\@listi\@listI -\@listi -\def\@listii {\leftmargin\leftmarginii - \labelwidth\leftmarginii - \advance\labelwidth-\labelsep - \topsep 0\p@ \@plus2\p@ \@minus\p@} -\def\@listiii{\leftmargin\leftmarginiii - \labelwidth\leftmarginiii - \advance\labelwidth-\labelsep - \topsep 0\p@ \@plus\p@\@minus\p@ - \parsep \z@ - \partopsep \p@ \@plus\z@ \@minus\p@} - -\renewcommand\labelitemi{\normalfont\bfseries --} -\renewcommand\labelitemii{$\m@th\bullet$} - -\setlength\arraycolsep{1.4\p@} -\setlength\tabcolsep{1.4\p@} - -\def\tableofcontents{\chapter*{\contentsname\@mkboth{{\contentsname}}% - {{\contentsname}}} - \def\authcount##1{\setcounter{auco}{##1}\setcounter{@auth}{1}} - \def\lastand{\ifnum\value{auco}=2\relax - \unskip{} \andname\ - \else - \unskip \lastandname\ - \fi}% - \def\and{\stepcounter{@auth}\relax - \ifnum\value{@auth}=\value{auco}% - \lastand - \else - \unskip, - \fi}% - \@starttoc{toc}\if@restonecol\twocolumn\fi} - -\def\l@part#1#2{\addpenalty{\@secpenalty}% - \addvspace{2em plus\p@}% % space above part line - \begingroup - \parindent \z@ - \rightskip \z@ plus 5em - \hrule\vskip5pt - \large % same size as for a contribution heading - \bfseries\boldmath % set line in boldface - \leavevmode % TeX command to enter horizontal mode. - #1\par - \vskip5pt - \hrule - \vskip1pt - \nobreak % Never break after part entry - \endgroup} - -\def\@dotsep{2} - -\let\phantomsection=\relax - -\def\hyperhrefextend{\ifx\hyper@anchor\@undefined\else -{}\fi} - -\def\addnumcontentsmark#1#2#3{% -\addtocontents{#1}{\protect\contentsline{#2}{\protect\numberline - {\thechapter}#3}{\thepage}\hyperhrefextend}}% -\def\addcontentsmark#1#2#3{% -\addtocontents{#1}{\protect\contentsline{#2}{#3}{\thepage}\hyperhrefextend}}% -\def\addcontentsmarkwop#1#2#3{% -\addtocontents{#1}{\protect\contentsline{#2}{#3}{0}\hyperhrefextend}}% - -\def\@adcmk[#1]{\ifcase #1 \or -\def\@gtempa{\addnumcontentsmark}% - \or \def\@gtempa{\addcontentsmark}% - \or \def\@gtempa{\addcontentsmarkwop}% - \fi\@gtempa{toc}{chapter}% -} -\def\addtocmark{% -\phantomsection -\@ifnextchar[{\@adcmk}{\@adcmk[3]}% -} - -\def\l@chapter#1#2{\addpenalty{-\@highpenalty} - \vskip 1.0em plus 1pt \@tempdima 1.5em \begingroup - \parindent \z@ \rightskip \@tocrmarg - \advance\rightskip by 0pt plus 2cm - \parfillskip -\rightskip \pretolerance=10000 - \leavevmode \advance\leftskip\@tempdima \hskip -\leftskip - {\large\bfseries\boldmath#1}\ifx0#2\hfil\null - \else - \nobreak - \leaders\hbox{$\m@th \mkern \@dotsep mu.\mkern - \@dotsep mu$}\hfill - \nobreak\hbox to\@pnumwidth{\hss #2}% - \fi\par - \penalty\@highpenalty \endgroup} - -\def\l@title#1#2{\addpenalty{-\@highpenalty} - \addvspace{8pt plus 1pt} - \@tempdima \z@ - \begingroup - \parindent \z@ \rightskip \@tocrmarg - \advance\rightskip by 0pt plus 2cm - \parfillskip -\rightskip \pretolerance=10000 - \leavevmode \advance\leftskip\@tempdima \hskip -\leftskip - #1\nobreak - \leaders\hbox{$\m@th \mkern \@dotsep mu.\mkern - \@dotsep mu$}\hfill - \nobreak\hbox to\@pnumwidth{\hss #2}\par - \penalty\@highpenalty \endgroup} - -\def\l@author#1#2{\addpenalty{\@highpenalty} - \@tempdima=15\p@ %\z@ - \begingroup - \parindent \z@ \rightskip \@tocrmarg - \advance\rightskip by 0pt plus 2cm - \pretolerance=10000 - \leavevmode \advance\leftskip\@tempdima %\hskip -\leftskip - \textit{#1}\par - \penalty\@highpenalty \endgroup} - -\setcounter{tocdepth}{0} -\newdimen\tocchpnum -\newdimen\tocsecnum -\newdimen\tocsectotal -\newdimen\tocsubsecnum -\newdimen\tocsubsectotal -\newdimen\tocsubsubsecnum -\newdimen\tocsubsubsectotal -\newdimen\tocparanum -\newdimen\tocparatotal -\newdimen\tocsubparanum -\tocchpnum=\z@ % no chapter numbers -\tocsecnum=15\p@ % section 88. plus 2.222pt -\tocsubsecnum=23\p@ % subsection 88.8 plus 2.222pt -\tocsubsubsecnum=27\p@ % subsubsection 88.8.8 plus 1.444pt -\tocparanum=35\p@ % paragraph 88.8.8.8 plus 1.666pt -\tocsubparanum=43\p@ % subparagraph 88.8.8.8.8 plus 1.888pt -\def\calctocindent{% -\tocsectotal=\tocchpnum -\advance\tocsectotal by\tocsecnum -\tocsubsectotal=\tocsectotal -\advance\tocsubsectotal by\tocsubsecnum -\tocsubsubsectotal=\tocsubsectotal -\advance\tocsubsubsectotal by\tocsubsubsecnum -\tocparatotal=\tocsubsubsectotal -\advance\tocparatotal by\tocparanum} -\calctocindent - -\def\l@section{\@dottedtocline{1}{\tocchpnum}{\tocsecnum}} -\def\l@subsection{\@dottedtocline{2}{\tocsectotal}{\tocsubsecnum}} -\def\l@subsubsection{\@dottedtocline{3}{\tocsubsectotal}{\tocsubsubsecnum}} -\def\l@paragraph{\@dottedtocline{4}{\tocsubsubsectotal}{\tocparanum}} -\def\l@subparagraph{\@dottedtocline{5}{\tocparatotal}{\tocsubparanum}} - -\def\listoffigures{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn - \fi\section*{\listfigurename\@mkboth{{\listfigurename}}{{\listfigurename}}} - \@starttoc{lof}\if@restonecol\twocolumn\fi} -\def\l@figure{\@dottedtocline{1}{0em}{1.5em}} - -\def\listoftables{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn - \fi\section*{\listtablename\@mkboth{{\listtablename}}{{\listtablename}}} - \@starttoc{lot}\if@restonecol\twocolumn\fi} -\let\l@table\l@figure - -\renewcommand\listoffigures{% - \section*{\listfigurename - \@mkboth{\listfigurename}{\listfigurename}}% - \@starttoc{lof}% - } - -\renewcommand\listoftables{% - \section*{\listtablename - \@mkboth{\listtablename}{\listtablename}}% - \@starttoc{lot}% - } - -\ifx\oribibl\undefined -\ifx\citeauthoryear\undefined -\renewenvironment{thebibliography}[1] - {\section*{\refname} - \def\@biblabel##1{##1.} - \small - \list{\@biblabel{\@arabic\c@enumiv}}% - {\settowidth\labelwidth{\@biblabel{#1}}% - \leftmargin\labelwidth - \advance\leftmargin\labelsep - \if@openbib - \advance\leftmargin\bibindent - \itemindent -\bibindent - \listparindent \itemindent - \parsep \z@ - \fi - \usecounter{enumiv}% - \let\p@enumiv\@empty - \renewcommand\theenumiv{\@arabic\c@enumiv}}% - \if@openbib - \renewcommand\newblock{\par}% - \else - \renewcommand\newblock{\hskip .11em \@plus.33em \@minus.07em}% - \fi - \sloppy\clubpenalty4000\widowpenalty4000% - \sfcode`\.=\@m} - {\def\@noitemerr - {\@latex@warning{Empty `thebibliography' environment}}% - \endlist} -\def\@lbibitem[#1]#2{\item[{[#1]}\hfill]\if@filesw - {\let\protect\noexpand\immediate - \write\@auxout{\string\bibcite{#2}{#1}}}\fi\ignorespaces} -\newcount\@tempcntc -\def\@citex[#1]#2{\if@filesw\immediate\write\@auxout{\string\citation{#2}}\fi - \@tempcnta\z@\@tempcntb\m@ne\def\@citea{}\@cite{\@for\@citeb:=#2\do - {\@ifundefined - {b@\@citeb}{\@citeo\@tempcntb\m@ne\@citea\def\@citea{,}{\bfseries - ?}\@warning - {Citation `\@citeb' on page \thepage \space undefined}}% - {\setbox\z@\hbox{\global\@tempcntc0\csname b@\@citeb\endcsname\relax}% - \ifnum\@tempcntc=\z@ \@citeo\@tempcntb\m@ne - \@citea\def\@citea{,}\hbox{\csname b@\@citeb\endcsname}% - \else - \advance\@tempcntb\@ne - \ifnum\@tempcntb=\@tempcntc - \else\advance\@tempcntb\m@ne\@citeo - \@tempcnta\@tempcntc\@tempcntb\@tempcntc\fi\fi}}\@citeo}{#1}} -\def\@citeo{\ifnum\@tempcnta>\@tempcntb\else - \@citea\def\@citea{,\,\hskip\z@skip}% - \ifnum\@tempcnta=\@tempcntb\the\@tempcnta\else - {\advance\@tempcnta\@ne\ifnum\@tempcnta=\@tempcntb \else - \def\@citea{--}\fi - \advance\@tempcnta\m@ne\the\@tempcnta\@citea\the\@tempcntb}\fi\fi} -\else -\renewenvironment{thebibliography}[1] - {\section*{\refname} - \small - \list{}% - {\settowidth\labelwidth{}% - \leftmargin\parindent - \itemindent=-\parindent - \labelsep=\z@ - \if@openbib - \advance\leftmargin\bibindent - \itemindent -\bibindent - \listparindent \itemindent - \parsep \z@ - \fi - \usecounter{enumiv}% - \let\p@enumiv\@empty - \renewcommand\theenumiv{}}% - \if@openbib - \renewcommand\newblock{\par}% - \else - \renewcommand\newblock{\hskip .11em \@plus.33em \@minus.07em}% - \fi - \sloppy\clubpenalty4000\widowpenalty4000% - \sfcode`\.=\@m} - {\def\@noitemerr - {\@latex@warning{Empty `thebibliography' environment}}% - \endlist} - \def\@cite#1{#1}% - \def\@lbibitem[#1]#2{\item[]\if@filesw - {\def\protect##1{\string ##1\space}\immediate - \write\@auxout{\string\bibcite{#2}{#1}}}\fi\ignorespaces} - \fi -\else -\@cons\@openbib@code{\noexpand\small} -\fi - -\def\idxquad{\hskip 10\p@}% space that divides entry from number - -\def\@idxitem{\par\hangindent 10\p@} - -\def\subitem{\par\setbox0=\hbox{--\enspace}% second order - \noindent\hangindent\wd0\box0}% index entry - -\def\subsubitem{\par\setbox0=\hbox{--\,--\enspace}% third - \noindent\hangindent\wd0\box0}% order index entry - -\def\indexspace{\par \vskip 10\p@ plus5\p@ minus3\p@\relax} - -\renewenvironment{theindex} - {\@mkboth{\indexname}{\indexname}% - \thispagestyle{empty}\parindent\z@ - \parskip\z@ \@plus .3\p@\relax - \let\item\par - \def\,{\relax\ifmmode\mskip\thinmuskip - \else\hskip0.2em\ignorespaces\fi}% - \normalfont\small - \begin{multicols}{2}[\@makeschapterhead{\indexname}]% - } - {\end{multicols}} - -\renewcommand\footnoterule{% - \kern-3\p@ - \hrule\@width 2truecm - \kern2.6\p@} - \newdimen\fnindent - \fnindent1em -\long\def\@makefntext#1{% - \parindent \fnindent% - \leftskip \fnindent% - \noindent - \llap{\hb@xt@1em{\hss\@makefnmark\ }}\ignorespaces#1} - -\long\def\@makecaption#1#2{% - \small - \vskip\abovecaptionskip - \sbox\@tempboxa{{\bfseries #1.} #2}% - \ifdim \wd\@tempboxa >\hsize - {\bfseries #1.} #2\par - \else - \global \@minipagefalse - \hb@xt@\hsize{\hfil\box\@tempboxa\hfil}% - \fi - \vskip\belowcaptionskip} - -\def\fps@figure{htbp} -\def\fnum@figure{\figurename\thinspace\thefigure} -\def \@floatboxreset {% - \reset@font - \small - \@setnobreak - \@setminipage -} -\def\fps@table{htbp} -\def\fnum@table{\tablename~\thetable} -\renewenvironment{table} - {\setlength\abovecaptionskip{0\p@}% - \setlength\belowcaptionskip{10\p@}% - \@float{table}} - {\end@float} -\renewenvironment{table*} - {\setlength\abovecaptionskip{0\p@}% - \setlength\belowcaptionskip{10\p@}% - \@dblfloat{table}} - {\end@dblfloat} - -\long\def\@caption#1[#2]#3{\par\addcontentsline{\csname - ext@#1\endcsname}{#1}{\protect\numberline{\csname - the#1\endcsname}{\ignorespaces #2}}\begingroup - \@parboxrestore - \@makecaption{\csname fnum@#1\endcsname}{\ignorespaces #3}\par - \endgroup} - -% LaTeX does not provide a command to enter the authors institute -% addresses. The \institute command is defined here. - -\newcounter{@inst} -\newcounter{@auth} -\newcounter{auco} -\newdimen\instindent -\newbox\authrun -\newtoks\authorrunning -\newtoks\tocauthor -\newbox\titrun -\newtoks\titlerunning -\newtoks\toctitle - -\def\clearheadinfo{\gdef\@author{No Author Given}% - \gdef\@title{No Title Given}% - \gdef\@subtitle{}% - \gdef\@institute{No Institute Given}% - \gdef\@thanks{}% - \global\titlerunning={}\global\authorrunning={}% - \global\toctitle={}\global\tocauthor={}} - -\def\institute#1{\gdef\@institute{#1}} - -\def\institutename{\par - \begingroup - \parskip=\z@ - \parindent=\z@ - \setcounter{@inst}{1}% - \def\and{\par\stepcounter{@inst}% - \noindent$^{\the@inst}$\enspace\ignorespaces}% - \setbox0=\vbox{\def\thanks##1{}\@institute}% - \ifnum\c@@inst=1\relax - \gdef\fnnstart{0}% - \else - \xdef\fnnstart{\c@@inst}% - \setcounter{@inst}{1}% - \noindent$^{\the@inst}$\enspace - \fi - \ignorespaces - \@institute\par - \endgroup} - -\def\@fnsymbol#1{\ensuremath{\ifcase#1\or\star\or{\star\star}\or - {\star\star\star}\or \dagger\or \ddagger\or - \mathchar "278\or \mathchar "27B\or \|\or **\or \dagger\dagger - \or \ddagger\ddagger \else\@ctrerr\fi}} - -\def\inst#1{\unskip$^{#1}$} -\def\fnmsep{\unskip$^,$} -\def\email#1{{\tt#1}} -\AtBeginDocument{\@ifundefined{url}{\def\url#1{#1}}{}% -\@ifpackageloaded{babel}{% -\@ifundefined{extrasenglish}{}{\addto\extrasenglish{\switcht@albion}}% -\@ifundefined{extrasfrenchb}{}{\addto\extrasfrenchb{\switcht@francais}}% -\@ifundefined{extrasgerman}{}{\addto\extrasgerman{\switcht@deutsch}}% -}{\switcht@@therlang}% -\providecommand{\keywords}[1]{\par\addvspace\baselineskip -\noindent\keywordname\enspace\ignorespaces#1}% -} -\def\homedir{\~{ }} - -\def\subtitle#1{\gdef\@subtitle{#1}} -\clearheadinfo -% -%%% to avoid hyperref warnings -\providecommand*{\toclevel@author}{999} -%%% to make title-entry parent of section-entries -\providecommand*{\toclevel@title}{0} -% -\renewcommand\maketitle{\newpage -\phantomsection - \refstepcounter{chapter}% - \stepcounter{section}% - \setcounter{section}{0}% - \setcounter{subsection}{0}% - \setcounter{figure}{0} - \setcounter{table}{0} - \setcounter{equation}{0} - \setcounter{footnote}{0}% - \begingroup - \parindent=\z@ - \renewcommand\thefootnote{\@fnsymbol\c@footnote}% - \if@twocolumn - \ifnum \col@number=\@ne - \@maketitle - \else - \twocolumn[\@maketitle]% - \fi - \else - \newpage - \global\@topnum\z@ % Prevents figures from going at top of page. - \@maketitle - \fi - \thispagestyle{empty}\@thanks -% - \def\\{\unskip\ \ignorespaces}\def\inst##1{\unskip{}}% - \def\thanks##1{\unskip{}}\def\fnmsep{\unskip}% - \instindent=\hsize - \advance\instindent by-\headlineindent - \if!\the\toctitle!\addcontentsline{toc}{title}{\@title}\else - \addcontentsline{toc}{title}{\the\toctitle}\fi - \if@runhead - \if!\the\titlerunning!\else - \edef\@title{\the\titlerunning}% - \fi - \global\setbox\titrun=\hbox{\small\rm\unboldmath\ignorespaces\@title}% - \ifdim\wd\titrun>\instindent - \typeout{Title too long for running head. Please supply}% - \typeout{a shorter form with \string\titlerunning\space prior to - \string\maketitle}% - \global\setbox\titrun=\hbox{\small\rm - Title Suppressed Due to Excessive Length}% - \fi - \xdef\@title{\copy\titrun}% - \fi -% - \if!\the\tocauthor!\relax - {\def\and{\noexpand\protect\noexpand\and}% - \protected@xdef\toc@uthor{\@author}}% - \else - \def\\{\noexpand\protect\noexpand\newline}% - \protected@xdef\scratch{\the\tocauthor}% - \protected@xdef\toc@uthor{\scratch}% - \fi - \addtocontents{toc}{\noexpand\protect\noexpand\authcount{\the\c@auco}}% - \addcontentsline{toc}{author}{\toc@uthor}% - \if@runhead - \if!\the\authorrunning! - \value{@inst}=\value{@auth}% - \setcounter{@auth}{1}% - \else - \edef\@author{\the\authorrunning}% - \fi - \global\setbox\authrun=\hbox{\small\unboldmath\@author\unskip}% - \ifdim\wd\authrun>\instindent - \typeout{Names of authors too long for running head. Please supply}% - \typeout{a shorter form with \string\authorrunning\space prior to - \string\maketitle}% - \global\setbox\authrun=\hbox{\small\rm - Authors Suppressed Due to Excessive Length}% - \fi - \xdef\@author{\copy\authrun}% - \markboth{\@author}{\@title}% - \fi - \endgroup - \setcounter{footnote}{\fnnstart}% - \clearheadinfo} -% -\def\@maketitle{\newpage - \markboth{}{}% - \def\lastand{\ifnum\value{@inst}=2\relax - \unskip{} \andname\ - \else - \unskip \lastandname\ - \fi}% - \def\and{\stepcounter{@auth}\relax - \ifnum\value{@auth}=\value{@inst}% - \lastand - \else - \unskip, - \fi}% - \begin{center}% - \let\newline\\ - {\Large \bfseries\boldmath - \pretolerance=10000 - \@title \par}\vskip .8cm -\if!\@subtitle!\else {\large \bfseries\boldmath - \vskip -.65cm - \pretolerance=10000 - \@subtitle \par}\vskip .8cm\fi - \setbox0=\vbox{\setcounter{@auth}{1}\def\and{\stepcounter{@auth}}% - \def\thanks##1{}\@author}% - \global\value{@inst}=\value{@auth}% - \global\value{auco}=\value{@auth}% - \setcounter{@auth}{1}% -{\lineskip .5em -\noindent\ignorespaces -\@author\vskip.35cm} - {\small\institutename} - \end{center}% - } - -% definition of the "\spnewtheorem" command. -% -% Usage: -% -% \spnewtheorem{env_nam}{caption}[within]{cap_font}{body_font} -% or \spnewtheorem{env_nam}[numbered_like]{caption}{cap_font}{body_font} -% or \spnewtheorem*{env_nam}{caption}{cap_font}{body_font} -% -% New is "cap_font" and "body_font". It stands for -% fontdefinition of the caption and the text itself. -% -% "\spnewtheorem*" gives a theorem without number. -% -% A defined spnewthoerem environment is used as described -% by Lamport. -% -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\def\@thmcountersep{} -\def\@thmcounterend{.} - -\def\spnewtheorem{\@ifstar{\@sthm}{\@Sthm}} - -% definition of \spnewtheorem with number - -\def\@spnthm#1#2{% - \@ifnextchar[{\@spxnthm{#1}{#2}}{\@spynthm{#1}{#2}}} -\def\@Sthm#1{\@ifnextchar[{\@spothm{#1}}{\@spnthm{#1}}} - -\def\@spxnthm#1#2[#3]#4#5{\expandafter\@ifdefinable\csname #1\endcsname - {\@definecounter{#1}\@addtoreset{#1}{#3}% - \expandafter\xdef\csname the#1\endcsname{\expandafter\noexpand - \csname the#3\endcsname \noexpand\@thmcountersep \@thmcounter{#1}}% - \expandafter\xdef\csname #1name\endcsname{#2}% - \global\@namedef{#1}{\@spthm{#1}{\csname #1name\endcsname}{#4}{#5}}% - \global\@namedef{end#1}{\@endtheorem}}} - -\def\@spynthm#1#2#3#4{\expandafter\@ifdefinable\csname #1\endcsname - {\@definecounter{#1}% - \expandafter\xdef\csname the#1\endcsname{\@thmcounter{#1}}% - \expandafter\xdef\csname #1name\endcsname{#2}% - \global\@namedef{#1}{\@spthm{#1}{\csname #1name\endcsname}{#3}{#4}}% - \global\@namedef{end#1}{\@endtheorem}}} - -\def\@spothm#1[#2]#3#4#5{% - \@ifundefined{c@#2}{\@latexerr{No theorem environment `#2' defined}\@eha}% - {\expandafter\@ifdefinable\csname #1\endcsname - {\newaliascnt{#1}{#2}% - \expandafter\xdef\csname #1name\endcsname{#3}% - \global\@namedef{#1}{\@spthm{#1}{\csname #1name\endcsname}{#4}{#5}}% - \global\@namedef{end#1}{\@endtheorem}}}} - -\def\@spthm#1#2#3#4{\topsep 7\p@ \@plus2\p@ \@minus4\p@ -\refstepcounter{#1}% -\@ifnextchar[{\@spythm{#1}{#2}{#3}{#4}}{\@spxthm{#1}{#2}{#3}{#4}}} - -\def\@spxthm#1#2#3#4{\@spbegintheorem{#2}{\csname the#1\endcsname}{#3}{#4}% - \ignorespaces} - -\def\@spythm#1#2#3#4[#5]{\@spopargbegintheorem{#2}{\csname - the#1\endcsname}{#5}{#3}{#4}\ignorespaces} - -\def\@spbegintheorem#1#2#3#4{\trivlist - \item[\hskip\labelsep{#3#1\ #2\@thmcounterend}]#4} - -\def\@spopargbegintheorem#1#2#3#4#5{\trivlist - \item[\hskip\labelsep{#4#1\ #2}]{#4(#3)\@thmcounterend\ }#5} - -% definition of \spnewtheorem* without number - -\def\@sthm#1#2{\@Ynthm{#1}{#2}} - -\def\@Ynthm#1#2#3#4{\expandafter\@ifdefinable\csname #1\endcsname - {\global\@namedef{#1}{\@Thm{\csname #1name\endcsname}{#3}{#4}}% - \expandafter\xdef\csname #1name\endcsname{#2}% - \global\@namedef{end#1}{\@endtheorem}}} - -\def\@Thm#1#2#3{\topsep 7\p@ \@plus2\p@ \@minus4\p@ -\@ifnextchar[{\@Ythm{#1}{#2}{#3}}{\@Xthm{#1}{#2}{#3}}} - -\def\@Xthm#1#2#3{\@Begintheorem{#1}{#2}{#3}\ignorespaces} - -\def\@Ythm#1#2#3[#4]{\@Opargbegintheorem{#1} - {#4}{#2}{#3}\ignorespaces} - -\def\@Begintheorem#1#2#3{#3\trivlist - \item[\hskip\labelsep{#2#1\@thmcounterend}]} - -\def\@Opargbegintheorem#1#2#3#4{#4\trivlist - \item[\hskip\labelsep{#3#1}]{#3(#2)\@thmcounterend\ }} - -\if@envcntsect - \def\@thmcountersep{.} - \spnewtheorem{theorem}{Theorem}[section]{\bfseries}{\itshape} -\else - \spnewtheorem{theorem}{Theorem}{\bfseries}{\itshape} - \if@envcntreset - \@addtoreset{theorem}{section} - \else - \@addtoreset{theorem}{chapter} - \fi -\fi - -%definition of divers theorem environments -\spnewtheorem*{claim}{Claim}{\itshape}{\rmfamily} -\spnewtheorem*{proof}{Proof}{\itshape}{\rmfamily} -\if@envcntsame % alle Umgebungen wie Theorem. - \def\spn@wtheorem#1#2#3#4{\@spothm{#1}[theorem]{#2}{#3}{#4}} -\else % alle Umgebungen mit eigenem Zaehler - \if@envcntsect % mit section numeriert - \def\spn@wtheorem#1#2#3#4{\@spxnthm{#1}{#2}[section]{#3}{#4}} - \else % nicht mit section numeriert - \if@envcntreset - \def\spn@wtheorem#1#2#3#4{\@spynthm{#1}{#2}{#3}{#4} - \@addtoreset{#1}{section}} - \else - \def\spn@wtheorem#1#2#3#4{\@spynthm{#1}{#2}{#3}{#4} - \@addtoreset{#1}{chapter}}% - \fi - \fi -\fi -\spn@wtheorem{case}{Case}{\itshape}{\rmfamily} -\spn@wtheorem{conjecture}{Conjecture}{\itshape}{\rmfamily} -\spn@wtheorem{corollary}{Corollary}{\bfseries}{\itshape} -\spn@wtheorem{definition}{Definition}{\bfseries}{\itshape} -\spn@wtheorem{example}{Example}{\itshape}{\rmfamily} -\spn@wtheorem{exercise}{Exercise}{\itshape}{\rmfamily} -\spn@wtheorem{lemma}{Lemma}{\bfseries}{\itshape} -\spn@wtheorem{note}{Note}{\itshape}{\rmfamily} -\spn@wtheorem{problem}{Problem}{\itshape}{\rmfamily} -\spn@wtheorem{property}{Property}{\itshape}{\rmfamily} -\spn@wtheorem{proposition}{Proposition}{\bfseries}{\itshape} -\spn@wtheorem{question}{Question}{\itshape}{\rmfamily} -\spn@wtheorem{solution}{Solution}{\itshape}{\rmfamily} -\spn@wtheorem{remark}{Remark}{\itshape}{\rmfamily} - -\def\@takefromreset#1#2{% - \def\@tempa{#1}% - \let\@tempd\@elt - \def\@elt##1{% - \def\@tempb{##1}% - \ifx\@tempa\@tempb\else - \@addtoreset{##1}{#2}% - \fi}% - \expandafter\expandafter\let\expandafter\@tempc\csname cl@#2\endcsname - \expandafter\def\csname cl@#2\endcsname{}% - \@tempc - \let\@elt\@tempd} - -\def\theopargself{\def\@spopargbegintheorem##1##2##3##4##5{\trivlist - \item[\hskip\labelsep{##4##1\ ##2}]{##4##3\@thmcounterend\ }##5} - \def\@Opargbegintheorem##1##2##3##4{##4\trivlist - \item[\hskip\labelsep{##3##1}]{##3##2\@thmcounterend\ }} - } - -\renewenvironment{abstract}{% - \list{}{\advance\topsep by0.35cm\relax\small - \leftmargin=1cm - \labelwidth=\z@ - \listparindent=\z@ - \itemindent\listparindent - \rightmargin\leftmargin}\item[\hskip\labelsep - \bfseries\abstractname]} - {\endlist} - -\newdimen\headlineindent % dimension for space between -\headlineindent=1.166cm % number and text of headings. - -\def\ps@headings{\let\@mkboth\@gobbletwo - \let\@oddfoot\@empty\let\@evenfoot\@empty - \def\@evenhead{\normalfont\small\rlap{\thepage}\hspace{\headlineindent}% - \leftmark\hfil} - \def\@oddhead{\normalfont\small\hfil\rightmark\hspace{\headlineindent}% - \llap{\thepage}} - \def\chaptermark##1{}% - \def\sectionmark##1{}% - \def\subsectionmark##1{}} - -\def\ps@titlepage{\let\@mkboth\@gobbletwo - \let\@oddfoot\@empty\let\@evenfoot\@empty - \def\@evenhead{\normalfont\small\rlap{\thepage}\hspace{\headlineindent}% - \hfil} - \def\@oddhead{\normalfont\small\hfil\hspace{\headlineindent}% - \llap{\thepage}} - \def\chaptermark##1{}% - \def\sectionmark##1{}% - \def\subsectionmark##1{}} - -\if@runhead\ps@headings\else -\ps@empty\fi - -\setlength\arraycolsep{1.4\p@} -\setlength\tabcolsep{1.4\p@} - -\endinput -%end of file llncs.cls diff -r a6f3e1b08494 -r b6873d123f9b ESOP-Paper/document/proof.sty --- a/ESOP-Paper/document/proof.sty Sat May 12 21:05:59 2012 +0100 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,278 +0,0 @@ -% proof.sty (Proof Figure Macros) -% -% version 3.0 (for both LaTeX 2.09 and LaTeX 2e) -% Mar 6, 1997 -% Copyright (C) 1990 -- 1997, Makoto Tatsuta (tatsuta@kusm.kyoto-u.ac.jp) -% -% This program is free software; you can redistribute it or modify -% it under the terms of the GNU General Public License as published by -% the Free Software Foundation; either versions 1, or (at your option) -% any later version. -% -% This program is distributed in the hope that it will be useful -% but WITHOUT ANY WARRANTY; without even the implied warranty of -% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -% GNU General Public License for more details. -% -% Usage: -% In \documentstyle, specify an optional style `proof', say, -% \documentstyle[proof]{article}. -% -% The following macros are available: -% -% In all the following macros, all the arguments such as -% and are processed in math mode. -% -% \infer -% draws an inference. -% -% Use & in to delimit upper formulae. -% consists more than 0 formulae. -% -% \infer returns \hbox{ ... } or \vbox{ ... } and -% sets \@LeftOffset and \@RightOffset globally. -% -% \infer[