--- a/Attic/FIXME-TODO Sat Dec 17 16:57:25 2011 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,70 +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.
-
-- Provide syntax for different names of Abs and Rep functions
- in a similar way to typedef
-
- typedef (open) 'a dlist = "{xs::'a list. distinct xs}"
- morphisms list_of_dlist Abs_dlist
-
-- Allow defining constants with existing names.
- Since 'insert' is defined for sets,
- "quotient_definition insert" fails for fset
- however "definition" succeeds.
-
-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, Dlist.
-
-- The current syntax of the quotient_definition is
-
- "qconst :: qty"
- as "rconst"
-
- Is it possible to have the more Isabelle-like
- syntax
-
- qconst :: "qty"
- as "rconst"
-
- That means "qconst :: qty" is not read as a term, but
- as two entities.
--- a/Attic/Fv.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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)) \<approx>gen
- \<lambda>(argl,argl1,..,argln) (argr,argr1,..,argrn).
- (alpha_ty argl argr) \<and> (alpha_i1 argl1 argr1) \<and> .. \<and> (alpha_in argln argrn)
- \<lambda>(arg,arg1,..,argn). (fv_ty arg) \<union> (fv_i1 arg1) \<union> .. \<union> (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 \<union>..\<union> bnl \<union> f1 a1l \<union>..\<union> fn anl, argl) \<approx>gen
- alpha_ty fv_ty (p1 +..+ pl)
- (b1r \<union>..\<union> bnr \<union> f1 a1r \<union>..\<union> 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 \<Rightarrow> 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' \<and> R y y' \<and> 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 \<Rightarrow> 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
--- a/Attic/IsaMakefile Sat Dec 17 16:57:25 2011 +0000
+++ /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
--- a/Attic/Parser.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<notsimeq> C2 y ...) (Proof by cases; simp)
-
-Tacs.thy/build_rel_inj
- 6) prove alpha_eq_iff (C1 x = C2 y \<leftrightarrow> 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
-
-
-
--- a/Attic/Prove.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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
--- a/Attic/Quot/Examples/AbsRepTest.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 "\<approx>1" 50)
-where
- "erel1 \<equiv> \<lambda>xs ys. \<forall>e. e \<in> set xs \<longleftrightarrow> e \<in> 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 "\<approx>2" 50)
-where
- "erel2 \<equiv> \<lambda>(xs::('a * 'a) list) ys. \<forall>e. e \<in> set xs \<longleftrightarrow> e \<in> 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 "\<approx>3" 50)
-where
- "erel3 \<equiv> \<lambda>(xs::('a * int) list) ys. \<forall>e. e \<in> set xs \<longleftrightarrow> e \<in> 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 \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool" (infixl "\<approx>4" 50)
-where
- "intrel (x, y) (u, v) = (x + v = u + y)"
-
-quotient_type myint = "nat \<times> nat" / intrel
- by (auto simp add: equivp_def expand_fun_eq)
-
-ML {*
-test_funs AbsF @{context}
- (@{typ "nat \<times> 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 \<Rightarrow> 'a list"},
- @{typ "('a fset) fset \<Rightarrow> '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: "(\<forall>e. ((e \<in> A) \<longleftrightarrow> (e \<in> B))) \<equiv> A = B"
- apply (rule eq_reflection)
- apply auto
- done
-
-lemma map_rel_cong: "b \<approx>1 ba \<Longrightarrow> map f b \<approx>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 \<approx>1) r s =
- ((list_rel r2 OOO op \<approx>1) r r \<and> (list_rel r2 OOO op \<approx>1) s s \<and>
- 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 \<approx>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 \<approx>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 \<approx>1))
- (abs_fset \<circ> (map abs2)) ((map rep2) \<circ> 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 \<circ> (map abs2)) ((map rep2) \<circ> 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
--- a/Attic/Quot/Examples/FSet3.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<Rightarrow> fsc_qual \<Rightarrow> fsc_quals \<Rightarrow> 'a fset" ("{|_ . __")
-"_fsc_gen" :: "'a \<Rightarrow> 'a fset \<Rightarrow> fsc_qual" ("_ <- _")
-"_fsc_test" :: "bool \<Rightarrow> fsc_qual" ("_")
-"_fsc_end" :: "fsc_quals" ("|}")
-"_fsc_quals" :: "fsc_qual \<Rightarrow> fsc_quals \<Rightarrow> fsc_quals" (", __")
-"_fsc_abs" :: "'a => 'b fset => 'b fset"
-
-syntax (xsymbols)
-"_fsc_gen" :: "'a \<Rightarrow> 'a fset \<Rightarrow> fsc_qual" ("_ \<leftarrow> _")
-syntax (HTML output)
-"_fsc_gen" :: "'a \<Rightarrow> 'a fset \<Rightarrow> fsc_qual" ("_ \<leftarrow> _")
-
-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 \<leftarrow> xs|}"
-term "{|(x,y,z). x\<leftarrow>xs|}"
-term "{|e x y. x\<leftarrow>xs, y\<leftarrow>ys|}"
-term "{|(x,y,z). x<a, x>b|}"
-term "{|(x,y,z). x\<leftarrow>xs, x>b|}"
-term "{|(x,y,z). x<a, x\<leftarrow>xs|}"
-term "{|(x,y). Cons True x \<leftarrow> xs|}"
-term "{|(x,y,z). Cons x [] \<leftarrow> xs|}"
-term "{|(x,y,z). x<a, x>b, x=d|}"
-term "{|(x,y,z). x<a, x>b, y\<leftarrow>ys|}"
-term "{|(x,y,z). x<a, x\<leftarrow>xs,y>b|}"
-term "{|(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys|}"
-term "{|(x,y,z). x\<leftarrow>xs, x>b, y<a|}"
-term "{|(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys|}"
-term "{|(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,y>x|}"
-term "{|(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs|}"
-*)
-
-(* BELOW CONSTRUCTION SITE *)
-
-
-end
--- a/Attic/Quot/Examples/FSet_BallBex.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 "\<approx>" 50)
-
-lemma test:
- "\<forall>xs \<in> (\<lambda>xs. memb x xs). memb x (y # xs)"
- apply (simp add: memb_def)
- apply (metis mem_def)
- done
-
-thm test[quot_lifted]
-
-lemma "\<forall>xs \<in> (\<lambda>xs. x |\<in>| xs). x |\<in>| 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:
- "\<exists>xs \<in> (\<lambda>xs. xs \<approx> []). xs \<approx> []"
- apply (rule_tac x="[]" in bexI)
- apply (auto simp add: mem_def)
- done
-
-thm test2[quot_lifted]
-
-lemma "\<exists>xs \<in> (\<lambda>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
--- a/Attic/Quot/Examples/IntEx2.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<Rightarrow> '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 \<Rightarrow> int" where
- [code del]: "Bit0 k = k + k"
-
-definition
- Bit1 :: "int \<Rightarrow> int" where
- [code del]: "Bit1 k = 1 + k + k"
-
-class number = -- {* for numeric types: nat, int, real, \dots *}
- fixes number_of :: "int \<Rightarrow> 'a"
-
-(*use "~~/src/HOL/Tools/numeral.ML"
-
-syntax
- "_Numeral" :: "num_const \<Rightarrow> 'a" ("_")
-
-use "~~/src/HOL/Tools/numeral_syntax.ML"
-
-setup NumeralSyntax.setup
-
-abbreviation
- "Numeral0 \<equiv> number_of Pls"
-
-abbreviation
- "Numeral1 \<equiv> 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 \<Rightarrow> int" where
- [code del]: "succ k = k + 1"
-
-definition
- pred :: "int \<Rightarrow> 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
--- a/Attic/Quot/Examples/LFex.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<Rightarrow> name set"
-and fv_ty :: "ty \<Rightarrow> name set"
-and fv_trm :: "trm \<Rightarrow> name set"
-where
- "fv_kind (Type) = {}"
-| "fv_kind (KPi A x K) = (fv_ty A) \<union> ((fv_kind K) - {x})"
-| "fv_ty (TConst i) = {}"
-| "fv_ty (TApp A M) = (fv_ty A) \<union> (fv_trm M)"
-| "fv_ty (TPi A x B) = (fv_ty A) \<union> ((fv_ty B) - {x})"
-| "fv_trm (Const i) = {}"
-| "fv_trm (Var x) = {x}"
-| "fv_trm (App M N) = (fv_trm M) \<union> (fv_trm N)"
-| "fv_trm (Lam A x M) = (fv_ty A) \<union> ((fv_trm M) - {x})"
-sorry
-
-termination fv_kind sorry
-
-inductive
- akind :: "kind \<Rightarrow> kind \<Rightarrow> bool" ("_ \<approx>ki _" [100, 100] 100)
-and aty :: "ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<approx>ty _" [100, 100] 100)
-and atrm :: "trm \<Rightarrow> trm \<Rightarrow> bool" ("_ \<approx>tr _" [100, 100] 100)
-where
- a1: "(Type) \<approx>ki (Type)"
-| a21: "\<lbrakk>A \<approx>ty A'; K \<approx>ki K'\<rbrakk> \<Longrightarrow> (KPi A x K) \<approx>ki (KPi A' x K')"
-| a22: "\<lbrakk>A \<approx>ty A'; K \<approx>ki ([(x,x')]\<bullet>K'); x \<notin> (fv_ty A'); x \<notin> ((fv_kind K') - {x'})\<rbrakk>
- \<Longrightarrow> (KPi A x K) \<approx>ki (KPi A' x' K')"
-| a3: "i = j \<Longrightarrow> (TConst i) \<approx>ty (TConst j)"
-| a4: "\<lbrakk>A \<approx>ty A'; M \<approx>tr M'\<rbrakk> \<Longrightarrow> (TApp A M) \<approx>ty (TApp A' M')"
-| a51: "\<lbrakk>A \<approx>ty A'; B \<approx>ty B'\<rbrakk> \<Longrightarrow> (TPi A x B) \<approx>ty (TPi A' x B')"
-| a52: "\<lbrakk>A \<approx>ty A'; B \<approx>ty ([(x,x')]\<bullet>B'); x \<notin> (fv_ty B'); x \<notin> ((fv_ty B') - {x'})\<rbrakk>
- \<Longrightarrow> (TPi A x B) \<approx>ty (TPi A' x' B')"
-| a6: "i = j \<Longrightarrow> (Const i) \<approx>trm (Const j)"
-| a7: "x = y \<Longrightarrow> (Var x) \<approx>trm (Var y)"
-| a8: "\<lbrakk>M \<approx>trm M'; N \<approx>tr N'\<rbrakk> \<Longrightarrow> (App M N) \<approx>tr (App M' N')"
-| a91: "\<lbrakk>A \<approx>ty A'; M \<approx>tr M'\<rbrakk> \<Longrightarrow> (Lam A x M) \<approx>tr (Lam A' x M')"
-| a92: "\<lbrakk>A \<approx>ty A'; M \<approx>tr ([(x,x')]\<bullet>M'); x \<notin> (fv_ty B'); x \<notin> ((fv_trm M') - {x'})\<rbrakk>
- \<Longrightarrow> (Lam A x M) \<approx>tr (Lam A' x' M')"
-
-lemma al_refl:
- fixes K::"kind"
- and A::"ty"
- and M::"trm"
- shows "K \<approx>ki K"
- and "A \<approx>ty A"
- and "M \<approx>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 \<Rightarrow> name \<Rightarrow> KIND \<Rightarrow> KIND"
-is
- "KPi"
-
-quotient_definition
- "TCONST :: ident \<Rightarrow> TY"
-is
- "TConst"
-
-quotient_definition
- "TAPP :: TY \<Rightarrow> TRM \<Rightarrow> TY"
-is
- "TApp"
-
-quotient_definition
- "TPI :: TY \<Rightarrow> name \<Rightarrow> TY \<Rightarrow> TY"
-is
- "TPi"
-
-(* FIXME: does not work with CONST *)
-quotient_definition
- "CONS :: ident \<Rightarrow> TRM"
-is
- "Const"
-
-quotient_definition
- "VAR :: name \<Rightarrow> TRM"
-is
- "Var"
-
-quotient_definition
- "APP :: TRM \<Rightarrow> TRM \<Rightarrow> TRM"
-is
- "App"
-
-quotient_definition
- "LAM :: TY \<Rightarrow> name \<Rightarrow> TRM \<Rightarrow> 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 \<Rightarrow> name set *)
-quotient_definition
- "FV_kind :: KIND \<Rightarrow> name set"
-is
- "fv_kind"
-
-quotient_definition
- "FV_ty :: TY \<Rightarrow> name set"
-is
- "fv_ty"
-
-quotient_definition
- "FV_trm :: TRM \<Rightarrow> 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 \<equiv> "perm :: 'x prm \<Rightarrow> KIND \<Rightarrow> KIND" (unchecked)
- perm_ty \<equiv> "perm :: 'x prm \<Rightarrow> TY \<Rightarrow> TY" (unchecked)
- perm_trm \<equiv> "perm :: 'x prm \<Rightarrow> TRM \<Rightarrow> TRM" (unchecked)
-begin
-
-quotient_definition
- "perm_kind :: 'x prm \<Rightarrow> KIND \<Rightarrow> KIND"
-is
- "(perm::'x prm \<Rightarrow> kind \<Rightarrow> kind)"
-
-quotient_definition
- "perm_ty :: 'x prm \<Rightarrow> TY \<Rightarrow> TY"
-is
- "(perm::'x prm \<Rightarrow> ty \<Rightarrow> ty)"
-
-quotient_definition
- "perm_trm :: 'x prm \<Rightarrow> TRM \<Rightarrow> TRM"
-is
- "(perm::'x prm \<Rightarrow> trm \<Rightarrow> 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 \<bullet> op \<bullet>" sorry
-lemma perm_ty_rsp[quot_respect]:
- "(op = ===> aty ===> aty) op \<bullet> op \<bullet>" sorry
-lemma perm_trm_rsp[quot_respect]:
- "(op = ===> atrm ===> atrm) op \<bullet> op \<bullet>" 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:
- "\<And>A A' K K' x. \<lbrakk>(A::TY) = A'; P2 A A'; (K::KIND) = K'; P1 K K'\<rbrakk>
- \<Longrightarrow> P1 (KPI A x K) (KPI A' x K')"
- and a2:
- "\<And>A A' K K' x x'. \<lbrakk>(A ::TY) = A'; P2 A A'; (K :: KIND) = ([(x, x')] \<bullet> K'); P1 K ([(x, x')] \<bullet> K');
- x \<notin> FV_ty A'; x \<notin> FV_kind K' - {x'}\<rbrakk> \<Longrightarrow> P1 (KPI A x K) (KPI A' x' K')"
- and a3:
- "\<And>i j. i = j \<Longrightarrow> P2 (TCONST i) (TCONST j)"
- and a4:
- "\<And>A A' M M'. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\<rbrakk> \<Longrightarrow> P2 (TAPP A M) (TAPP A' M')"
- and a5:
- "\<And>A A' B B' x. \<lbrakk>(A ::TY) = A'; P2 A A'; (B ::TY) = B'; P2 B B'\<rbrakk> \<Longrightarrow> P2 (TPI A x B) (TPI A' x B')"
- and a6:
- "\<And>A A' B x x' B'. \<lbrakk>(A ::TY) = A'; P2 A A'; (B ::TY) = ([(x, x')] \<bullet> B'); P2 B ([(x, x')] \<bullet> B');
- x \<notin> FV_ty B'; x \<notin> FV_ty B' - {x'}\<rbrakk> \<Longrightarrow> P2 (TPI A x B) (TPI A' x' B')"
- and a7:
- "\<And>i j m. i = j \<Longrightarrow> P3 (CONS i) (m (CONS j))"
- and a8:
- "\<And>x y m. x = y \<Longrightarrow> P3 (VAR x) (m (VAR y))"
- and a9:
- "\<And>M m M' N N'. \<lbrakk>(M :: TRM) = m M'; P3 M (m M'); (N :: TRM) = N'; P3 N N'\<rbrakk> \<Longrightarrow> P3 (APP M N) (APP M' N')"
- and a10:
- "\<And>A A' M M' x. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = M'; P3 M M'\<rbrakk> \<Longrightarrow> P3 (LAM A x M) (LAM A' x M')"
- and a11:
- "\<And>A A' M x x' M' B'. \<lbrakk>(A ::TY) = A'; P2 A A'; (M :: TRM) = ([(x, x')] \<bullet> M'); P3 M ([(x, x')] \<bullet> M');
- x \<notin> FV_ty B'; x \<notin> FV_trm M' - {x'}\<rbrakk> \<Longrightarrow> P3 (LAM A x M) (LAM A' x' M')"
- shows "((x1 :: KIND) = x2 \<longrightarrow> P1 x1 x2) \<and>
- ((x3 ::TY) = x4 \<longrightarrow> P2 x3 x4) \<and>
- ((x5 :: TRM) = x6 \<longrightarrow> 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: "\<And>ty name kind. \<lbrakk>P2 ty; P1 kind\<rbrakk> \<Longrightarrow> P1 (KPI ty name kind)"
- and a2: "\<And>id. P2 (TCONST id)"
- and a3: "\<And>ty trm. \<lbrakk>P2 ty; P3 trm\<rbrakk> \<Longrightarrow> P2 (TAPP ty trm)"
- and a4: "\<And>ty1 name ty2. \<lbrakk>P2 ty1; P2 ty2\<rbrakk> \<Longrightarrow> P2 (TPI ty1 name ty2)"
- and a5: "\<And>id. P3 (CONS id)"
- and a6: "\<And>name. P3 (VAR name)"
- and a7: "\<And>trm1 trm2. \<lbrakk>P3 trm1; P3 trm2\<rbrakk> \<Longrightarrow> P3 (APP trm1 trm2)"
- and a8: "\<And>ty name trm. \<lbrakk>P2 ty; P3 trm\<rbrakk> \<Longrightarrow> P3 (LAM ty name trm)"
- shows "P1 mkind \<and> P2 mty \<and> P3 mtrm"
-using a0 a1 a2 a3 a4 a5 a6 a7 a8
-*)
-
-
-lemma "\<lbrakk>P TYP;
- \<And>ty name kind. \<lbrakk>Q ty; P kind\<rbrakk> \<Longrightarrow> P (KPI ty name kind);
- \<And>id. Q (TCONST id);
- \<And>ty trm. \<lbrakk>Q ty; R trm\<rbrakk> \<Longrightarrow> Q (TAPP ty trm);
- \<And>ty1 name ty2. \<lbrakk>Q ty1; Q ty2\<rbrakk> \<Longrightarrow> Q (TPI ty1 name ty2);
- \<And>id. R (CONS id); \<And>name. R (VAR name);
- \<And>trm1 trm2. \<lbrakk>R trm1; R trm2\<rbrakk> \<Longrightarrow> R (APP trm1 trm2);
- \<And>ty name trm. \<lbrakk>Q ty; R trm\<rbrakk> \<Longrightarrow> R (LAM ty name trm)\<rbrakk>
- \<Longrightarrow> P mkind \<and> Q mty \<and> R mtrm"
-apply(lifting kind_ty_trm.induct)
-done
-
-end
-
-
-
-
--- a/Attic/Quot/Examples/LamEx.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<Rightarrow> name set"
-where
- rfv_var: "rfv (rVar a) = {a}"
-| rfv_app: "rfv (rApp t1 t2) = (rfv t1) \<union> (rfv t2)"
-| rfv_lam: "rfv (rLam a t) = (rfv t) - {a}"
-
-overloading
- perm_rlam \<equiv> "perm :: 'x prm \<Rightarrow> rlam \<Rightarrow> rlam" (unchecked)
-begin
-
-fun
- perm_rlam
-where
- "perm_rlam pi (rVar a) = rVar (pi \<bullet> a)"
-| "perm_rlam pi (rApp t1 t2) = rApp (perm_rlam pi t1) (perm_rlam pi t2)"
-| "perm_rlam pi (rLam a t) = rLam (pi \<bullet> 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\<bullet>rfv t) = rfv (pi\<bullet>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 \<Rightarrow> rlam \<Rightarrow> bool" ("_ \<approx> _" [100, 100] 100)
-where
- a1: "a = b \<Longrightarrow> (rVar a) \<approx> (rVar b)"
-| a2: "\<lbrakk>t1 \<approx> t2; s1 \<approx> s2\<rbrakk> \<Longrightarrow> rApp t1 s1 \<approx> rApp t2 s2"
-| a3: "\<exists>pi::name prm. (rfv t - {a} = rfv s - {b} \<and> (rfv t - {a})\<sharp>* pi \<and> (pi \<bullet> t) \<approx> s \<and> (pi \<bullet> a) = b)
- \<Longrightarrow> rLam a t \<approx> rLam b s"
-
-
-(* should be automatic with new version of eqvt-machinery *)
-lemma alpha_eqvt:
- fixes pi::"name prm"
- shows "t \<approx> s \<Longrightarrow> (pi \<bullet> t) \<approx> (pi \<bullet> 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 \<bullet> 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 \<approx> 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 \<approx> s \<Longrightarrow> s \<approx> 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 \<approx> t2 \<Longrightarrow> t2 \<approx> t3 \<Longrightarrow> t1 \<approx> 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 \<bullet> 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 \<approx> s \<Longrightarrow> 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 \<Rightarrow> lam"
-is
- "rVar"
-
-quotient_definition
- "App :: lam \<Rightarrow> lam \<Rightarrow> lam"
-is
- "rApp"
-
-quotient_definition
- "Lam :: name \<Rightarrow> lam \<Rightarrow> lam"
-is
- "rLam"
-
-quotient_definition
- "fv :: lam \<Rightarrow> name set"
-is
- "rfv"
-
-(* definition of overloaded permutation function *)
-(* for the lifted type lam *)
-overloading
- perm_lam \<equiv> "perm :: 'x prm \<Rightarrow> lam \<Rightarrow> lam" (unchecked)
-begin
-
-quotient_definition
- "perm_lam :: 'x prm \<Rightarrow> lam \<Rightarrow> lam"
-is
- "perm::'x prm \<Rightarrow> rlam \<Rightarrow> rlam"
-
-end
-
-lemma perm_rsp[quot_respect]:
- "(op = ===> alpha ===> alpha) op \<bullet> (op \<bullet> :: (name \<times> name) list \<Rightarrow> rlam \<Rightarrow> 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:
- "\<lbrakk>\<And>name. P (Var name);
- \<And>lam1 lam2. \<lbrakk>P lam1; P lam2\<rbrakk> \<Longrightarrow> P (App lam1 lam2);
- \<And>name lam. P lam \<Longrightarrow> P (Lam name lam)\<rbrakk>
- \<Longrightarrow> P lam"
- by (lifting rlam.induct)
-
-lemma perm_lam [simp]:
- fixes pi::"name prm"
- shows "pi \<bullet> Var a = Var (pi \<bullet> a)"
- and "pi \<bullet> App t1 t2 = App (pi \<bullet> t1) (pi \<bullet> t2)"
- and "pi \<bullet> Lam a t = Lam (pi \<bullet> a) (pi \<bullet> 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 \<union> fv t2"
- and "fv (Lam a t) = fv t - {a}"
- by(lifting rfv_var rfv_app rfv_lam)
-
-lemma a1:
- "a = b \<Longrightarrow> Var a = Var b"
- by (lifting a1)
-
-lemma a2:
- "\<lbrakk>x = xa; xb = xc\<rbrakk> \<Longrightarrow> App x xb = App xa xc"
- by (lifting a2)
-
-lemma a3:
- "\<lbrakk>\<exists>pi::name prm. (fv t - {a} = fv s - {b} \<and> (fv t - {a})\<sharp>* pi \<and> (pi \<bullet> t) = s \<and> (pi \<bullet> a) = b)\<rbrakk>
- \<Longrightarrow> Lam a t = Lam b s"
- by (lifting a3)
-
-lemma alpha_cases:
- "\<lbrakk>a1 = a2; \<And>a b. \<lbrakk>a1 = Var a; a2 = Var b; a = b\<rbrakk> \<Longrightarrow> P;
- \<And>x xa xb xc. \<lbrakk>a1 = App x xb; a2 = App xa xc; x = xa; xb = xc\<rbrakk> \<Longrightarrow> P;
- \<And>t a s b. \<lbrakk>a1 = Lam a t; a2 = Lam b s;
- \<exists>pi::name prm. fv t - {a} = fv s - {b} \<and> (fv t - {a}) \<sharp>* pi \<and> (pi \<bullet> t) = s \<and> pi \<bullet> a = b\<rbrakk> \<Longrightarrow> P\<rbrakk>
- \<Longrightarrow> P"
- by (lifting alpha.cases)
-
-lemma alpha_induct:
- "\<lbrakk>qx = qxa; \<And>a b. a = b \<Longrightarrow> qxb (Var a) (Var b);
- \<And>x xa xb xc. \<lbrakk>x = xa; qxb x xa; xb = xc; qxb xb xc\<rbrakk> \<Longrightarrow> qxb (App x xb) (App xa xc);
- \<And>t a s b.
- \<lbrakk>\<exists>pi::name prm. fv t - {a} = fv s - {b} \<and>
- (fv t - {a}) \<sharp>* pi \<and> ((pi \<bullet> t) = s \<and> qxb (pi \<bullet> t) s) \<and> pi \<bullet> a = b\<rbrakk> \<Longrightarrow> qxb (Lam a t) (Lam b s)\<rbrakk>
- \<Longrightarrow> 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 \<and> 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 "\<not>(rVar nam \<approx> rApp rlam1' rlam2')"
- and "\<not>(rApp rlam1' rlam2' \<approx> rVar nam)"
- and "\<not>(rVar nam \<approx> rLam nam' rlam')"
- and "\<not>(rLam nam' rlam' \<approx> rVar nam)"
- and "\<not>(rApp rlam1 rlam2 \<approx> rLam nam' rlam')"
- and "\<not>(rLam nam' rlam' \<approx> 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 \<noteq> App lam1' lam2'"
- and "App lam1' lam2' \<noteq> Var nam"
- and "Var nam \<noteq> Lam nam' lam'"
- and "Lam nam' lam' \<noteq> Var nam"
- and "App lam1 lam2 \<noteq> Lam nam' lam'"
- and "Lam nam' lam' \<noteq> 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) \<union> ((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 \<sharp> Lam b t) \<longleftrightarrow> (a = b) \<or> (a \<noteq> b \<and> a \<sharp> 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: "\<And>name b. P b (Var name)"
- and a2: "\<And>lam1 lam2 b. \<lbrakk>\<And>c. P c lam1; \<And>c. P c lam2\<rbrakk> \<Longrightarrow> P b (App lam1 lam2)"
- and a3: "\<And>name lam b. \<lbrakk>\<And>c. P c lam; name \<sharp> b\<rbrakk> \<Longrightarrow> P b (Lam name lam)"
- shows "P a lam"
-proof -
- have "\<And>(pi::name prm) a. P a (pi \<bullet> lam)"
- proof (induct lam rule: lam_induct)
- case (1 name pi)
- show "P a (pi \<bullet> Var name)"
- apply (simp)
- apply (rule a1)
- done
- next
- case (2 lam1 lam2 pi)
- have b1: "\<And>(pi::name prm) a. P a (pi \<bullet> lam1)" by fact
- have b2: "\<And>(pi::name prm) a. P a (pi \<bullet> lam2)" by fact
- show "P a (pi \<bullet> App lam1 lam2)"
- apply (simp)
- apply (rule a2)
- apply (rule b1)
- apply (rule b2)
- done
- next
- case (3 name lam pi a)
- have b: "\<And>(pi::name prm) a. P a (pi \<bullet> lam)" by fact
- obtain c::name where fr: "c\<sharp>(a, pi\<bullet>name, pi\<bullet>lam)"
- apply(rule exists_fresh[of "(a, pi\<bullet>name, pi\<bullet>lam)"])
- apply(simp_all add: fs_name1)
- done
- from b fr have p: "P a (Lam c (([(c, pi\<bullet>name)]@pi)\<bullet>lam))"
- apply -
- apply(rule a3)
- apply(blast)
- apply(simp)
- done
- have eq: "[(c, pi\<bullet>name)] \<bullet> Lam (pi \<bullet> name) (pi \<bullet> lam) = Lam (pi \<bullet> name) (pi \<bullet> lam)"
- apply(rule perm_fresh_fresh)
- using fr
- apply(simp add: fresh_lam)
- apply(simp add: fresh_lam)
- done
- show "P a (pi \<bullet> 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) \<bullet> lam)" by blast
- then show "P a lam" by simp
-qed
-
-
-lemma var_fresh:
- fixes a::"name"
- shows "(a \<sharp> (Var b)) = (a \<sharp> 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 \<Rightarrow> ('a::pt_name)"
- shows "(pi\<bullet>rlam_rec f1 f2 f3 t) = rlam_rec (pi\<bullet>f1) (pi\<bullet>f2) (pi\<bullet>f3) (pi\<bullet>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 \<in> Respects (op= ===> op=)"
- and f2: "f_app \<in> Respects (alpha ===> alpha ===> op= ===> op= ===> op=)"
- and f3: "f_lam \<in> Respects (op= ===> alpha ===> op= ===> op=)"
- shows "rlam_rec f_var f_app f_lam \<in> 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 \<Rightarrow> 'a) \<Rightarrow>
- (rlam \<Rightarrow> rlam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow>
- ((name \<Rightarrow> rlam) \<Rightarrow> (name \<Rightarrow> 'a) \<Rightarrow> 'a) \<Rightarrow> rlam \<Rightarrow> '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' (\<lambda>y. [(x, y)] \<bullet> u) (\<lambda>y. term1_hom var app abs' ([(x, y)] \<bullet> u))"
-apply(pat_completeness)
-apply(auto)
-done
-
-lemma pi_size:
- fixes pi::"name prm"
- and t::"rlam"
- shows "size (pi \<bullet> t) = size t"
-apply(induct t)
-apply(auto)
-done
-
-termination term1_hom
- apply(relation "measure (\<lambda>(f1, f2, f3, t). size t)")
-apply(auto simp add: pi_size)
-done
-
-lemma lam_exhaust:
- "\<lbrakk>\<And>name. y = Var name \<Longrightarrow> P; \<And>rlam1 rlam2. y = App rlam1 rlam2 \<Longrightarrow> P; \<And>name rlam. y = Lam name rlam \<Longrightarrow> P\<rbrakk>
- \<Longrightarrow> 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) = ((\<lambda>c. [(a, c)] \<bullet> x) = (\<lambda>c. [(b, c)] \<bullet> y))"
-sorry
-
-function
- hom :: "(name \<Rightarrow> 'a) \<Rightarrow>
- (lam \<Rightarrow> lam \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow>
- ((name \<Rightarrow> lam) \<Rightarrow> (name \<Rightarrow> 'a) \<Rightarrow> 'a) \<Rightarrow> lam \<Rightarrow> '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 (\<lambda>b. ([(a,b)] \<bullet> x)) (\<lambda>b. hom f_var f_app f_lam ([(a,b)] \<bullet> 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:
- "\<lbrakk>(alpha ===> alpha ===> op =) f_app f_app; ((op = ===> alpha) ===> op =) f_lam f_lam\<rbrakk>
- \<Longrightarrow> (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: "
-\<forall>f_var. \<forall>f_app \<in> Respects(alpha ===> alpha ===> op =).
-\<forall>f_lam \<in> Respects((op = ===> alpha) ===> op =).
-\<exists>hom\<in>Respects (alpha ===> op =).
- ((\<forall>x. hom (rVar x) = f_var x) \<and>
- (\<forall>l r. hom (rApp l r) = f_app l r (hom l) (hom r)) \<and>
- (\<forall>x a. hom (rLam a x) = f_lam (\<lambda>b. ([(a,b)]\<bullet> x)) (\<lambda>b. hom ([(a,b)] \<bullet> 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':
-"\<exists>hom.
- ((\<forall>x. hom (Var x) = f_var x) \<and>
- (\<forall>l r. hom (App l r) = f_app l r (hom l) (hom r)) \<and>
- (\<forall>x a. hom (Lam a x) = f_lam (\<lambda>b. ([(a,b)] \<bullet> x)) (\<lambda>b. hom ([(a,b)] \<bullet> x))))"
-apply (lifting hom)
-done
-
-(* test test
-lemma raw_hom_correct:
- assumes f1: "f_var \<in> Respects (op= ===> op=)"
- and f2: "f_app \<in> Respects (alpha ===> alpha ===> op= ===> op= ===> op=)"
- and f3: "f_lam \<in> Respects ((op= ===> alpha) ===> (op= ===> op=) ===> op=)"
- shows "\<exists>!hom\<in>Respects (alpha ===> op =).
- ((\<forall>x. hom (rVar x) = f_var x) \<and>
- (\<forall>l r. hom (rApp l r) = f_app l r (hom l) (hom r)) \<and>
- (\<forall>x a. hom (rLam a x) = f_lam (\<lambda>b. ([(a,b)]\<bullet> x)) (\<lambda>b. hom ([(a,b)] \<bullet> x))))"
-unfolding Bex1_def
-apply(rule ex1I)
-sorry
-*)
-
-
-end
-
--- a/Attic/Quot/Examples/Pair.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<times> 'a) \<Rightarrow> ('a \<times> 'a) \<Rightarrow> bool" (infix "\<approx>" 100)
-where
- "(a, b) \<approx> (c, d) = (a = c \<and> b = d \<or> a = d \<and> b = c)"
-
-lemma alpha_refl:
- shows "z \<approx> z"
- by (case_tac z, auto)
-
-lemma alpha_equivp:
- shows "equivp op \<approx>"
- unfolding equivp_reflp_symp_transp reflp_def symp_def transp_def
- by auto
-
-quotient_type
- 'a pair_set = "'a \<times> 'a" / alpha
- by (auto intro: alpha_equivp)
-
-quotient_definition
- "Two :: 'a \<Rightarrow> 'a \<Rightarrow> 'a pair_set"
-is
- "Pair :: 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a)"
-
-fun
- memb_both_lists
-where
- "memb_both_lists a (b, c) = (memb a b \<and> memb a c)"
-
-quotient_definition
- "mem_fsets :: 'a \<Rightarrow> 'a fset pair_set \<Rightarrow> 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 \<approx>) OOO (prod_rel list_eq list_eq))
- (abs_pair_set \<circ> prod_fun abs_fset abs_fset)
- (prod_fun rep_fset rep_fset \<circ> 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 \<approx> 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 \<approx> 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 \<circ> 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 |\<in>| b \<and> a |\<in>| c)"
- by (lifting memb_both_lists.simps)
-
-(* Doing it in 2 steps *)
-
-quotient_definition
- "mem_lists :: 'a \<Rightarrow> 'a list pair_set \<Rightarrow> bool"
-is memb_both_lists
-
-lemma [quot_respect]: "(op = ===> op \<approx> ===> op =) memb_both_lists memb_both_lists"
- by auto
-
-lemma [quot_respect]: "(op = ===> op = ===> op \<approx>) Pair Pair"
- by auto
-
-lemma step1: "mem_lists a (Two b c) = (memb a b \<and> memb a c)"
- by (lifting memb_both_lists.simps)
-
-lemma step2: "mem_fsets a (Two b c) = (a |\<in>| b \<and> a |\<in>| c)"
- (* apply (lifting step1) ??? *)
- oops
-
-(* Doing it in 2 steps the other way *)
-
-quotient_definition
- "memb_both_fsets :: 'a \<Rightarrow> 'a fset \<times> 'a fset \<Rightarrow> 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 |\<in>| b \<and> a |\<in>| c)"
- by (lifting memb_both_lists.simps)
-
-lemma step2: "mem_fsets a (Two b c) = (a |\<in>| b \<and> a |\<in>| c)"
- (* ??? *)
- oops
-
-end
-
--- a/Attic/Quot/Examples/SigmaEx.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<times> rmethod) list"
-| rInv "robj" "string"
-| rUpd "robj" "string" "rmethod"
-and rmethod =
- rSig "name" "robj"
-
-inductive
- alpha_obj :: "robj \<Rightarrow> robj \<Rightarrow> bool" ("_ \<approx>o _" [100, 100] 100)
-and alpha_method :: "rmethod \<Rightarrow> rmethod \<Rightarrow> bool" ("_ \<approx>m _" [100, 100] 100)
-where
- a1: "a = b \<Longrightarrow> (rVar a) \<approx>o (rVar b)"
-| a2: "rObj [] \<approx>o rObj []"
-| a3: "rObj t1 \<approx>o rObj t2 \<Longrightarrow> m1 \<approx>m r2 \<Longrightarrow> rObj ((l1, m1) # t1) \<approx>o rObj ((l2, m2) # t2)"
-| a4: "x \<approx>o y \<Longrightarrow> rInv x l1 \<approx>o rInv y l2"
-| a5: "\<exists>pi::name prm. (rfv t - {a} = rfv s - {b} \<and> (rfv t - {a})\<sharp>* pi \<and> (pi \<bullet> t) \<approx>o s \<and> (pi \<bullet> a) = b)
- \<Longrightarrow> rSig a t \<approx>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 \<Rightarrow> obj"
-is
- "rVar"
-
-quotient_definition
- "Obj :: (string \<times> method) list \<Rightarrow> obj"
-is
- "rObj"
-
-quotient_definition
- "Inv :: obj \<Rightarrow> string \<Rightarrow> obj"
-is
- "rInv"
-
-quotient_definition
- "Upd :: obj \<Rightarrow> string \<Rightarrow> method \<Rightarrow> obj"
-is
- "rUpd"
-
-quotient_definition
- "Sig :: name \<Rightarrow> obj \<Rightarrow> method"
-is
- "rSig"
-
-overloading
- perm_obj \<equiv> "perm :: 'x prm \<Rightarrow> obj \<Rightarrow> obj" (unchecked)
- perm_method \<equiv> "perm :: 'x prm \<Rightarrow> method \<Rightarrow> method" (unchecked)
-begin
-
-quotient_definition
- "perm_obj :: 'x prm \<Rightarrow> obj \<Rightarrow> obj"
-is
- "(perm::'x prm \<Rightarrow> robj \<Rightarrow> robj)"
-
-quotient_definition
- "perm_method :: 'x prm \<Rightarrow> method \<Rightarrow> method"
-is
- "(perm::'x prm \<Rightarrow> rmethod \<Rightarrow> rmethod)"
-
-end
-
-
-
-lemma tolift:
-"\<forall> fvar.
- \<forall> fobj\<in>Respects (op = ===> list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<forall> fnvk\<in>Respects (op = ===> alpha_obj ===> op =).
- \<forall> fupd\<in>Respects (op = ===> op = ===> alpha_obj ===> op = ===> alpha_method ===> op =).
- \<forall> fcns\<in>Respects (op = ===> op = ===> prod_rel (op =) alpha_method ===> list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<forall> fnil.
- \<forall> fpar\<in>Respects (op = ===> op = ===> alpha_method ===> op =).
- \<forall> fsgm\<in>Respects (op = ===> (op = ===> alpha_obj) ===> op =).
-
- Ex1 (\<lambda>x.
-(x \<in> (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 =)
- )
- )))) \<and>
-(\<lambda> (hom_o\<Colon>robj \<Rightarrow> 'a, hom_d\<Colon>(char list \<times> rmethod) list \<Rightarrow> 'b, hom_e\<Colon>char list \<times> rmethod \<Rightarrow> 'c, hom_m\<Colon>rmethod \<Rightarrow> 'd).
-
-((\<forall>x. hom_o (rVar x) = fvar x) \<and>
- (\<forall>d. hom_o (rObj d) = fobj (hom_d d) d) \<and>
- (\<forall>a l. hom_o (rInv a l) = fnvk (hom_o a) a l) \<and>
- (\<forall>a l m. hom_o (rUpd a l m) = fupd (hom_o a) (hom_m m) a l m) \<and>
- (\<forall>e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \<and>
- (hom_d [] = fnil) \<and>
- (\<forall>l m. hom_e (l, m) = fpar (hom_m m) l m) \<and>
- (\<forall>x a. hom_m (rSig x a) = fsgm (\<lambda>y. hom_o ([(x, y)] \<bullet> a)) (\<lambda>y. [(x, y)] \<bullet> a))
-)) x) "
-sorry
-
-lemma test_to: "Ex1 (\<lambda>x. (x \<in> (Respects alpha_obj)) \<and> P x)"
-ML_prf {* prop_of (#goal (Isar.goal ())) *}
-sorry
-lemma test_tod: "Ex1 (P :: obj \<Rightarrow> bool)"
-apply (lifting test_to)
-done
-
-
-
-
-(*syntax
- "_expttrn" :: "pttrn => bool => bool" ("(3\<exists>\<exists> _./ _)" [0, 10] 10)
-
-translations
- "\<exists>\<exists> 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 \<bullet> op \<bullet>"
-sorry
-
-
-lemma bex1_bex1reg: "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>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 (\<lambda>(hom_o, hom_d, hom_e, hom_m).
-
- (\<forall>x. hom_o (Var x) = fvar x) \<and>
- (\<forall>d. hom_o (Obj d) = fobj (hom_d d) d) \<and>
- (\<forall>a l. hom_o (Inv a l) = fnvk (hom_o a) a l) \<and>
- (\<forall>a l m. hom_o (Upd a l m) = fupd (hom_o a) (hom_m m) a l m) \<and>
- (\<forall>e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \<and>
- (hom_d [] = fnil) \<and>
- (\<forall>l m. hom_e (l, m) = fpar (hom_m m) l m) \<and>
- (\<forall>x a. hom_m (Sig x a) = fsgm (\<lambda>y. hom_o ([(x, y)] \<bullet> a)) (\<lambda>y. [(x, y)] \<bullet> a))
-)"
-apply (lifting tolift)
-done
-
-lemma tolift':
-"\<forall> fvar.
- \<forall> fobj\<in>Respects (op = ===> list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<forall> fnvk\<in>Respects (op = ===> alpha_obj ===> op =).
- \<forall> fupd\<in>Respects (op = ===> op = ===> alpha_obj ===> op = ===> alpha_method ===> op =).
- \<forall> fcns\<in>Respects (op = ===> op = ===> prod_rel (op =) alpha_method ===> list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<forall> fnil.
- \<forall> fpar\<in>Respects (op = ===> op = ===> alpha_method ===> op =).
- \<forall> fsgm\<in>Respects (op = ===> (op = ===> alpha_obj) ===> op =).
-
- \<exists> hom_o\<Colon>robj \<Rightarrow> 'a \<in> Respects (alpha_obj ===> op =).
- \<exists> hom_d\<Colon>(char list \<times> rmethod) list \<Rightarrow> 'b \<in> Respects (list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<exists> hom_e\<Colon>char list \<times> rmethod \<Rightarrow> 'c \<in> Respects ((prod_rel (op =) alpha_method) ===> op =).
- \<exists> hom_m\<Colon>rmethod \<Rightarrow> 'd \<in> Respects (alpha_method ===> op =).
-(
- (\<forall>x. hom_o (rVar x) = fvar x) \<and>
- (\<forall>d. hom_o (rObj d) = fobj (hom_d d) d) \<and>
- (\<forall>a l. hom_o (rInv a l) = fnvk (hom_o a) a l) \<and>
- (\<forall>a l m. hom_o (rUpd a l m) = fupd (hom_o a) (hom_m m) a l m) \<and>
- (\<forall>e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \<and>
- (hom_d [] = fnil) \<and>
- (\<forall>l m. hom_e (l, m) = fpar (hom_m m) l m) \<and>
- (\<forall>x a. hom_m (rSig x a) = fsgm (\<lambda>y. hom_o ([(x, y)] \<bullet> a)) (\<lambda>y. [(x, y)] \<bullet> a))
-)"
-sorry
-
-lemma liftd': "
-\<exists>hom_o. \<exists>hom_d. \<exists>hom_e. \<exists>hom_m.
-(
- (\<forall>x. hom_o (Var x) = fvar x) \<and>
- (\<forall>d. hom_o (Obj d) = fobj (hom_d d) d) \<and>
- (\<forall>a l. hom_o (Inv a l) = fnvk (hom_o a) a l) \<and>
- (\<forall>a l m. hom_o (Upd a l m) = fupd (hom_o a) (hom_m m) a l m) \<and>
- (\<forall>e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \<and>
- (hom_d [] = fnil) \<and>
- (\<forall>l m. hom_e (l, m) = fpar (hom_m m) l m) \<and>
- (\<forall>x a. hom_m (Sig x a) = fsgm (\<lambda>y. hom_o ([(x, y)] \<bullet> a)) (\<lambda>y. [(x, y)] \<bullet> a))
-)"
-apply (lifting tolift')
-done
-
-lemma tolift'':
-"\<forall> fvar.
- \<forall> fobj\<in>Respects (op = ===> list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<forall> fnvk\<in>Respects (op = ===> alpha_obj ===> op =).
- \<forall> fupd\<in>Respects (op = ===> op = ===> alpha_obj ===> op = ===> alpha_method ===> op =).
- \<forall> fcns\<in>Respects (op = ===> op = ===> prod_rel (op =) alpha_method ===> list_rel (prod_rel (op =) alpha_method) ===> op =).
- \<forall> fnil.
- \<forall> fpar\<in>Respects (op = ===> op = ===> alpha_method ===> op =).
- \<forall> fsgm\<in>Respects (op = ===> (op = ===> alpha_obj) ===> op =).
-
- Bex1_rel (alpha_obj ===> op =) (\<lambda>hom_o\<Colon>robj \<Rightarrow> 'a .
- Bex1_rel (list_rel (prod_rel (op =) alpha_method) ===> op =) (\<lambda>hom_d\<Colon>(char list \<times> rmethod) list \<Rightarrow> 'b.
- Bex1_rel ((prod_rel (op =) alpha_method) ===> op =) (\<lambda>hom_e\<Colon>char list \<times> rmethod \<Rightarrow> 'c.
- Bex1_rel (alpha_method ===> op =) (\<lambda>hom_m\<Colon>rmethod \<Rightarrow> 'd.
-(
- (\<forall>x. hom_o (rVar x) = fvar x) \<and>
- (\<forall>d. hom_o (rObj d) = fobj (hom_d d) d) \<and>
- (\<forall>a l. hom_o (rInv a l) = fnvk (hom_o a) a l) \<and>
- (\<forall>a l m. hom_o (rUpd a l m) = fupd (hom_o a) (hom_m m) a l m) \<and>
- (\<forall>e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \<and>
- (hom_d [] = fnil) \<and>
- (\<forall>l m. hom_e (l, m) = fpar (hom_m m) l m) \<and>
- (\<forall>x a. hom_m (rSig x a) = fsgm (\<lambda>y. hom_o ([(x, y)] \<bullet> a)) (\<lambda>y. [(x, y)] \<bullet> a))
-)
-))))"
-sorry
-
-lemma liftd'': "
-\<exists>!hom_o. \<exists>!hom_d. \<exists>!hom_e. \<exists>!hom_m.
-(
- (\<forall>x. hom_o (Var x) = fvar x) \<and>
- (\<forall>d. hom_o (Obj d) = fobj (hom_d d) d) \<and>
- (\<forall>a l. hom_o (Inv a l) = fnvk (hom_o a) a l) \<and>
- (\<forall>a l m. hom_o (Upd a l m) = fupd (hom_o a) (hom_m m) a l m) \<and>
- (\<forall>e d. hom_d (e # d) = fcns (hom_e e) (hom_d d) e d) \<and>
- (hom_d [] = fnil) \<and>
- (\<forall>l m. hom_e (l, m) = fpar (hom_m m) l m) \<and>
- (\<forall>x a. hom_m (Sig x a) = fsgm (\<lambda>y. hom_o ([(x, y)] \<bullet> a)) (\<lambda>y. [(x, y)] \<bullet> a))
-)"
-apply (lifting tolift'')
-done
-
-
-end
-
--- a/Attic/Quot/Examples/Terms.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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) \<union> (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) \<union> (fv_trm1 t2)"
-| "fv_trm1 (Lm1 x t) = (fv_trm1 t) - {x}"
-| "fv_trm1 (Lt1 bp t1 t2) = (fv_trm1 t1) \<union> (fv_trm1 t2 - bv1 bp)"
-| "fv_bp (BUnit) = {}"
-| "fv_bp (BVr x) = {x}"
-| "fv_bp (BPr b1 b2) = (fv_bp b1) \<union> (fv_bp b2)"
-
-(* needs to be stated by the package *)
-overloading
- perm_trm1 \<equiv> "perm :: 'x prm \<Rightarrow> trm1 \<Rightarrow> trm1" (unchecked)
- perm_bp \<equiv> "perm :: 'x prm \<Rightarrow> bp \<Rightarrow> bp" (unchecked)
-begin
-
-primrec
- perm_trm1 and perm_bp
-where
- "perm_trm1 pi (Vr1 a) = Vr1 (pi \<bullet> a)"
-| "perm_trm1 pi (Ap1 t1 t2) = Ap1 (perm_trm1 pi t1) (perm_trm1 pi t2)"
-| "perm_trm1 pi (Lm1 a t) = Lm1 (pi \<bullet> 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 \<bullet> a)"
-| "perm_bp pi (BPr bp1 bp2) = BPr (perm_bp pi bp1) (perm_bp pi bp2)"
-
-end
-
-inductive
- alpha1 :: "trm1 \<Rightarrow> trm1 \<Rightarrow> bool" ("_ \<approx>1 _" [100, 100] 100)
-where
- a1: "a = b \<Longrightarrow> (Vr1 a) \<approx>1 (Vr1 b)"
-| a2: "\<lbrakk>t1 \<approx>1 t2; s1 \<approx>1 s2\<rbrakk> \<Longrightarrow> Ap1 t1 s1 \<approx>1 Ap1 t2 s2"
-| a3: "\<exists>pi::name prm. (fv_trm1 t - {a} = fv_trm1 s - {b} \<and>
- (fv_trm1 t - {a})\<sharp>* pi \<and>
- (pi \<bullet> t) \<approx>1 s \<and> (pi \<bullet> a) = b)
- \<Longrightarrow> Lm1 a t \<approx>1 Lm1 b s"
-| a4: "\<exists>pi::name prm.(
- t1 \<approx>1 t2 \<and>
- (fv_trm1 s1 - fv_bp b1 = fv_trm1 s2 - fv_bp b2) \<and>
- (fv_trm1 s1 - fv_bp b1) \<sharp>* pi \<and>
- (pi \<bullet> s1 = s2) (* Optional: \<and> (pi \<bullet> b1 = b2) *)
- ) \<Longrightarrow> Lt1 b1 t1 s1 \<approx>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) \<union> (fv_trm2 t2)"
-| "fv_trm2 (Lm2 x t) = (fv_trm2 t) - {x}"
-| "fv_trm2 (Lt2 as t) = (fv_trm2 t - bv2 as) \<union> (fv_assign as)"
-| "fv_assign (As x t) = (fv_trm2 t)"
-
-(* needs to be stated by the package *)
-overloading
- perm_trm2 \<equiv> "perm :: 'x prm \<Rightarrow> trm2 \<Rightarrow> trm2" (unchecked)
- perm_assign \<equiv> "perm :: 'x prm \<Rightarrow> assign \<Rightarrow> assign" (unchecked)
-begin
-
-primrec
- perm_trm2 and perm_assign
-where
- "perm_trm2 pi (Vr2 a) = Vr2 (pi \<bullet> a)"
-| "perm_trm2 pi (Ap2 t1 t2) = Ap2 (perm_trm2 pi t1) (perm_trm2 pi t2)"
-| "perm_trm2 pi (Lm2 a t) = Lm2 (pi \<bullet> 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 \<bullet> a) (perm_trm2 pi t)"
-
-end
-
-inductive
- alpha2 :: "trm2 \<Rightarrow> trm2 \<Rightarrow> bool" ("_ \<approx>2 _" [100, 100] 100)
-where
- a1: "a = b \<Longrightarrow> (Vr2 a) \<approx>2 (Vr2 b)"
-| a2: "\<lbrakk>t1 \<approx>2 t2; s1 \<approx>2 s2\<rbrakk> \<Longrightarrow> Ap2 t1 s1 \<approx>2 Ap2 t2 s2"
-| a3: "\<exists>pi::name prm. (fv_trm2 t - {a} = fv_trm2 s - {b} \<and>
- (fv_trm2 t - {a})\<sharp>* pi \<and>
- (pi \<bullet> t) \<approx>2 s \<and>
- (pi \<bullet> a) = b)
- \<Longrightarrow> Lm2 a t \<approx>2 Lm2 b s"
-| a4: "\<exists>pi::name prm. (
- fv_trm2 t1 - fv_assign b1 = fv_trm2 t2 - fv_assign b2 \<and>
- (fv_trm2 t1 - fv_assign b1) \<sharp>* pi \<and>
- pi \<bullet> t1 = t2 (* \<and> (pi \<bullet> b1 = b2) *)
- ) \<Longrightarrow> Lt2 b1 t1 \<approx>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} \<union> (bv3 as)"
-
-primrec
- fv_trm3 and fv_assigns
-where
- "fv_trm3 (Vr3 x) = {x}"
-| "fv_trm3 (Ap3 t1 t2) = (fv_trm3 t1) \<union> (fv_trm3 t2)"
-| "fv_trm3 (Lm3 x t) = (fv_trm3 t) - {x}"
-| "fv_trm3 (Lt3 as t) = (fv_trm3 t - bv3 as) \<union> (fv_assigns as)"
-| "fv_assigns (ANil) = {}"
-| "fv_assigns (ACons x t as) = (fv_trm3 t) \<union> (fv_assigns as)"
-
-(* needs to be stated by the package *)
-overloading
- perm_trm3 \<equiv> "perm :: 'x prm \<Rightarrow> trm3 \<Rightarrow> trm3" (unchecked)
- perm_assigns \<equiv> "perm :: 'x prm \<Rightarrow> assigns \<Rightarrow> assigns" (unchecked)
-begin
-
-primrec
- perm_trm3 and perm_assigns
-where
- "perm_trm3 pi (Vr3 a) = Vr3 (pi \<bullet> a)"
-| "perm_trm3 pi (Ap3 t1 t2) = Ap3 (perm_trm3 pi t1) (perm_trm3 pi t2)"
-| "perm_trm3 pi (Lm3 a t) = Lm3 (pi \<bullet> 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 \<bullet> a) (perm_trm3 pi t) (perm_assigns pi as)"
-
-end
-
-inductive
- alpha3 :: "trm3 \<Rightarrow> trm3 \<Rightarrow> bool" ("_ \<approx>3 _" [100, 100] 100)
-where
- a1: "a = b \<Longrightarrow> (Vr3 a) \<approx>3 (Vr3 b)"
-| a2: "\<lbrakk>t1 \<approx>3 t2; s1 \<approx>3 s2\<rbrakk> \<Longrightarrow> Ap3 t1 s1 \<approx>3 Ap3 t2 s2"
-| a3: "\<exists>pi::name prm. (fv_trm3 t - {a} = fv_trm3 s - {b} \<and>
- (fv_trm3 t - {a})\<sharp>* pi \<and>
- (pi \<bullet> t) \<approx>3 s \<and>
- (pi \<bullet> a) = b)
- \<Longrightarrow> Lm3 a t \<approx>3 Lm3 b s"
-| a4: "\<exists>pi::name prm. (
- fv_trm3 t1 - fv_assigns b1 = fv_trm3 t2 - fv_assigns b2 \<and>
- (fv_trm3 t1 - fv_assigns b1) \<sharp>* pi \<and>
- pi \<bullet> t1 = t2 (* \<and> (pi \<bullet> b1 = b2) *)
- ) \<Longrightarrow> Lt3 b1 t1 \<approx>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) \<union> (fv_trm4_list ts)"
-| "fv_trm4 (Lm4 x t) = (fv_trm4 t) - {x}"
-| "fv_trm4_list ([]) = {}"
-| "fv_trm4_list (t#ts) = (fv_trm4 t) \<union> (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 \<equiv> "perm :: 'x prm \<Rightarrow> trm4 \<Rightarrow> trm4" (unchecked)
-begin
-
-primrec
- perm_trm4
-where
- "perm_trm4 pi (Vr4 a) = Vr4 (pi \<bullet> a)"
-| "perm_trm4 pi (Ap4 t ts) = Ap4 (perm_trm4 pi t) (pi \<bullet> ts)"
-| "perm_trm4 pi (Lm4 a t) = Lm4 (pi \<bullet> a) (perm_trm4 pi t)"
-
-end
-
-inductive
- alpha4 :: "trm4 \<Rightarrow> trm4 \<Rightarrow> bool" ("_ \<approx>4 _" [100, 100] 100)
-and alpha4list :: "trm4 list \<Rightarrow> trm4 list \<Rightarrow> bool" ("_ \<approx>4list _" [100, 100] 100)
-where
- a1: "a = b \<Longrightarrow> (Vr4 a) \<approx>4 (Vr4 b)"
-| a2: "\<lbrakk>t1 \<approx>4 t2; s1 \<approx>4list s2\<rbrakk> \<Longrightarrow> Ap4 t1 s1 \<approx>4 Ap4 t2 s2"
-| a4: "\<exists>pi::name prm. (fv_trm4 t - {a} = fv_trm4 s - {b} \<and>
- (fv_trm4 t - {a})\<sharp>* pi \<and>
- (pi \<bullet> t) \<approx>4 s \<and>
- (pi \<bullet> a) = b)
- \<Longrightarrow> Lm4 a t \<approx>4 Lm4 b s"
-| a5: "[] \<approx>4list []"
-| a6: "\<lbrakk>t \<approx>4 s; ts \<approx>4list ss\<rbrakk> \<Longrightarrow> (t#ts) \<approx>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
--- a/Attic/Quot/Quotient.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<equiv> \<forall>x y. E x y = (E x = E y)"
-
-definition
- "reflp E \<equiv> \<forall>x. E x x"
-
-definition
- "symp E \<equiv> \<forall>x y. E x y \<longrightarrow> E y x"
-
-definition
- "transp E \<equiv> \<forall>x y z. E x y \<and> E y z \<longrightarrow> E x z"
-
-lemma equivp_reflp_symp_transp:
- shows "equivp E = (reflp E \<and> symp E \<and> transp E)"
- unfolding equivp_def reflp_def symp_def transp_def expand_fun_eq
- by blast
-
-lemma equivp_reflp:
- shows "equivp E \<Longrightarrow> E x x"
- by (simp only: equivp_reflp_symp_transp reflp_def)
-
-lemma equivp_symp:
- shows "equivp E \<Longrightarrow> E x y \<Longrightarrow> E y x"
- by (metis equivp_reflp_symp_transp symp_def)
-
-lemma equivp_transp:
- shows "equivp E \<Longrightarrow> E x y \<Longrightarrow> E y z \<Longrightarrow> 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 \<equiv> (\<exists>x. E x x) \<and> (\<forall>x y. E x y = (E x x \<and> E y y \<and> (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 \<equiv> 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 \<equiv> R x x"
-
-lemma in_respects:
- shows "(x \<in> 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 = (\<forall>x y. E1 x y \<longrightarrow> 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: "\<And>x y. R1 x y \<Longrightarrow> R2 (f x) (g y)"
- shows "(R1 ===> R2) f g"
- using a by simp
-
-lemma fun_rel_id_asm:
- assumes a: "\<And>x y. R1 x y \<Longrightarrow> (A \<longrightarrow> R2 (f x) (g y))"
- shows "A \<longrightarrow> (R1 ===> R2) f g"
- using a by auto
-
-
-section {* Quotient Predicate *}
-
-definition
- "Quotient E Abs Rep \<equiv>
- (\<forall>a. Abs (Rep a) = a) \<and> (\<forall>a. E (Rep a) (Rep a)) \<and>
- (\<forall>r s. E r s = (E r r \<and> E s s \<and> (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 \<and> E s s \<and> (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 \<Longrightarrow> 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 \<Longrightarrow> 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 "\<forall>a. (rep1 ---> abs2) ((abs1 ---> rep2) a) = a"
- using q1 q2
- unfolding Quotient_def
- unfolding expand_fun_eq
- by simp
- moreover
- have "\<forall>a. (R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)"
- using q1 q2
- unfolding Quotient_def
- by (simp (no_asm)) (metis)
- moreover
- have "\<forall>r s. (R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
- (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) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>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) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>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 \<Rightarrow> '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 \<Rightarrow> 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 \<Rightarrow> 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: "\<And>x. R x \<Longrightarrow> P x \<longrightarrow> Q x"
- shows "All P \<longrightarrow> Ball R Q"
- using a by (metis COMBC_def Collect_def Collect_mem_eq)
-
-lemma bex_reg_left:
- assumes a: "\<And>x. R x \<Longrightarrow> Q x \<longrightarrow> P x"
- shows "Bex R Q \<longrightarrow> Ex P"
- using a by (metis COMBC_def Collect_def Collect_mem_eq)
-
-lemma ball_reg_left:
- assumes a: "equivp R"
- shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
- using a by (metis equivp_reflp in_respects)
-
-lemma bex_reg_right:
- assumes a: "equivp R"
- shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
- using a by (metis equivp_reflp in_respects)
-
-lemma ball_reg_eqv_range:
- fixes P::"'a \<Rightarrow> bool"
- and x::"'a"
- assumes a: "equivp R2"
- shows "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
- apply(rule iffI)
- apply(rule allI)
- apply(drule_tac x="\<lambda>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)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
- apply(auto)
- apply(rule_tac x="\<lambda>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 "\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)"
- shows "(\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y)"
- using assms by auto
-
-lemma bex_ex_comm:
- assumes "(\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)"
- shows "(\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y)"
- using assms by auto
-
-section {* Bounded abstraction *}
-
-definition
- Babs :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
-where
- "x \<in> p \<Longrightarrow> 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 \<in> Respects R1 \<and> y \<in> 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 \<in> 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 \<in> Respects R1 \<and> y \<in> 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 \<Longrightarrow> 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 (\<lambda>x. x \<in> Respects R \<and> f x) = Ex1 (\<lambda>x. x \<in> Respects R \<and> 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 \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
-where
- "Bex1_rel R P \<longleftrightarrow> (\<exists>x \<in> Respects R. P x) \<and> (\<forall>x \<in> Respects R. \<forall>y \<in> Respects R. ((P x \<and> P y) \<longrightarrow> (R x y)))"
-
-lemma bex1_rel_aux:
- "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R x\<rbrakk> \<Longrightarrow> 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:
- "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R y\<rbrakk> \<Longrightarrow> 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 "\<forall>y. R y y \<longrightarrow> f (absf y) \<longrightarrow> 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: "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>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 \<Rightarrow> 'a \<Rightarrow> bool"
- and Abs :: "('a \<Rightarrow> bool) \<Rightarrow> 'b"
- and Rep :: "'b \<Rightarrow> ('a \<Rightarrow> bool)"
- assumes equivp: "equivp R"
- and rep_prop: "\<And>y. \<exists>x. Rep y = R x"
- and rep_inverse: "\<And>x. Abs (Rep x) = x"
- and abs_inverse: "\<And>x. (Rep (Abs (R x))) = (R x)"
- and rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
-begin
-
-definition
- abs::"'a \<Rightarrow> 'b"
-where
- "abs x \<equiv> Abs (R x)"
-
-definition
- rep::"'b \<Rightarrow> '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 "\<dots> = Abs (R x)" using homeier_lem9 by simp
- also have "\<dots> = Abs (Rep a)" using eq by simp
- also have "\<dots> = 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 "\<dots> = ?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 \<equiv> True"
-
-lemma
- shows QT_all: "Quot_True (All P) \<Longrightarrow> Quot_True P"
- and QT_ex: "Quot_True (Ex P) \<Longrightarrow> Quot_True P"
- and QT_ex1: "Quot_True (Ex1 P) \<Longrightarrow> Quot_True P"
- and QT_lam: "Quot_True (\<lambda>x. P x) \<Longrightarrow> (\<And>x. Quot_True (P x))"
- and QT_ext: "(\<And>x. Quot_True (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (Quot_True a \<Longrightarrow> f = g)"
- by (simp_all add: Quot_True_def ext)
-
-lemma QT_imp: "Quot_True a \<equiv> 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
-
--- a/Attic/Quot/Quotient_List.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<and> list_rel R xs ys)"
-
-declare [[map list = (map, list_rel)]]
-
-lemma split_list_all:
- shows "(\<forall>x. P x) \<longleftrightarrow> P [] \<and> (\<forall>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 \<Longrightarrow> 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 \<Longrightarrow> 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 \<Longrightarrow> list_rel R xs2 xs3 \<Longrightarrow> 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 \<and> list_rel R s s \<and> (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 \<Longrightarrow> length b = 0"
- by (induct b) (simp_all)
-
-lemma list_rel_len:
- shows "list_rel R a b \<Longrightarrow> 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 \<longrightarrow> list_rel R2 xb yb \<longrightarrow> 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 \<longrightarrow> list_rel R1 xa ya \<longrightarrow> 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: "\<And>x y. R x y = (R x = R y)"
- shows "list_rel R x x"
- by (induct x) (auto simp add: a)
-
-end
--- a/Attic/Quot/Quotient_Option.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 "(\<forall>x. P x) \<longleftrightarrow> P None \<and> (\<forall>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
--- a/Attic/Quot/Quotient_Product.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 = (\<lambda>(a, b) (c, d). R1 a c \<and> 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
--- a/Attic/Quot/Quotient_Sum.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x. P (Inl x)) \<and> (\<forall>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
--- a/Attic/Quot/Quotient_Syntax.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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
-(*>*)
--- a/Attic/Quot/ROOT.ML Sat Dec 17 16:57:25 2011 +0000
+++ /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"];
--- a/Attic/Quot/quotient_def.ML Sat Dec 17 16:57:25 2011 +0000
+++ /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 *)
--- a/Attic/Quot/quotient_info.ML Sat Dec 17 16:57:25 2011 +0000
+++ /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 *)
--- a/Attic/Quot/quotient_tacs.ML Sat Dec 17 16:57:25 2011 +0000
+++ /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 *)
--- a/Attic/Quot/quotient_term.ML Sat Dec 17 16:57:25 2011 +0000
+++ /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 *)
--- a/Attic/Quot/quotient_typ.ML Sat Dec 17 16:57:25 2011 +0000
+++ /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 *)
--- a/Attic/Unused.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" ("(3\<exists>!!_\<in>_./ _)" [0, 0, 10] 10)
-translations
- "\<exists>!!x\<in>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)*)
--- a/Attic/UnusedQuotBase.thy Sat Dec 17 16:57:25 2011 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,90 +0,0 @@
-lemma in_fun:
- shows "x \<in> ((f ---> g) s) = g (f x \<in> s)"
- by (simp add: mem_def)
-
-lemma respects_thm:
- shows "Respects (R1 ===> R2) f = (\<forall>x y. R1 x y \<longrightarrow> 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) \<and> (Respects (R1 ===> R2) g)
- \<and> ((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 \<in> r \<Longrightarrow> 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) = (\<forall>x y. R1 x y \<longrightarrow> 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 \<Longrightarrow> R2 (f x) (g y)"
- using q1 q2 r1 r2 a
- by (simp add: fun_rel_equals)
-
-lemma lambda_rep_abs_rsp:
- assumes r1: "\<And>r r'. R1 r r' \<Longrightarrow>R1 r (Rep1 (Abs1 r'))"
- and r2: "\<And>r r'. R2 r r' \<Longrightarrow>R2 r (Rep2 (Abs2 r'))"
- shows "(R1 ===> R2) f1 f2 \<Longrightarrow> (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
--- a/Attic/UnusedQuotMain.thy Sat Dec 17 16:57:25 2011 +0000
+++ /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 ())))) *}
--- a/Attic/isar-keywords-quot.el Sat Dec 17 16:57:25 2011 +0000
+++ /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)