src/HOL/Tools/Quotient/quotient_typ.ML
author wenzelm
Sat Mar 27 21:38:38 2010 +0100 (2010-03-27)
changeset 35994 9cc3df9a606e
parent 35842 7c170d39a808
child 36323 655e2d74de3a
permissions -rw-r--r--
Typedef.info: separate global and local part, only the latter is transformed by morphisms;
     1 (*  Title:      HOL/Tools/Quotient/quotient_typ.thy
     2     Author:     Cezary Kaliszyk and Christian Urban
     3 
     4 Definition of a quotient type.
     5 
     6 *)
     7 
     8 signature QUOTIENT_TYPE =
     9 sig
    10   val add_quotient_type: ((string list * binding * mixfix) * (typ * term)) * thm
    11     -> Proof.context -> (thm * thm) * local_theory
    12 
    13   val quotient_type: ((string list * binding * mixfix) * (typ * term)) list
    14     -> Proof.context -> Proof.state
    15 
    16   val quotient_type_cmd: ((((string list * binding) * mixfix) * string) * string) list
    17     -> Proof.context -> Proof.state
    18 end;
    19 
    20 structure Quotient_Type: QUOTIENT_TYPE =
    21 struct
    22 
    23 open Quotient_Info;
    24 
    25 (* wrappers for define, note, Attrib.internal and theorem_i *)
    26 fun define (name, mx, rhs) lthy =
    27 let
    28   val ((rhs, (_ , thm)), lthy') =
    29      Local_Theory.define ((name, mx), (Attrib.empty_binding, rhs)) lthy
    30 in
    31   ((rhs, thm), lthy')
    32 end
    33 
    34 fun note (name, thm, attrs) lthy =
    35 let
    36   val ((_,[thm']), lthy') = Local_Theory.note ((name, attrs), [thm]) lthy
    37 in
    38   (thm', lthy')
    39 end
    40 
    41 fun intern_attr at = Attrib.internal (K at)
    42 
    43 fun theorem after_qed goals ctxt =
    44 let
    45   val goals' = map (rpair []) goals
    46   fun after_qed' thms = after_qed (the_single thms)
    47 in
    48   Proof.theorem_i NONE after_qed' [goals'] ctxt
    49 end
    50 
    51 
    52 
    53 (*** definition of quotient types ***)
    54 
    55 val mem_def1 = @{lemma "y : S ==> S y" by (simp add: mem_def)}
    56 val mem_def2 = @{lemma "S y ==> y : S" by (simp add: mem_def)}
    57 
    58 (* constructs the term lambda (c::rty => bool). EX (x::rty). c = rel x *)
    59 fun typedef_term rel rty lthy =
    60 let
    61   val [x, c] =
    62     [("x", rty), ("c", HOLogic.mk_setT rty)]
    63     |> Variable.variant_frees lthy [rel]
    64     |> map Free
    65 in
    66   lambda c (HOLogic.exists_const rty $
    67      lambda x (HOLogic.mk_eq (c, (rel $ x))))
    68 end
    69 
    70 
    71 (* makes the new type definitions and proves non-emptyness *)
    72 fun typedef_make (vs, qty_name, mx, rel, rty) lthy =
    73 let
    74   val typedef_tac =
    75     EVERY1 (map rtac [@{thm exI}, mem_def2, @{thm exI}, @{thm refl}])
    76 in
    77 (* FIXME: purely local typedef causes at the moment 
    78    problems with type variables
    79   
    80   Typedef.add_typedef false NONE (qty_name, vs, mx) 
    81     (typedef_term rel rty lthy) NONE typedef_tac lthy
    82 *)
    83    Local_Theory.theory_result
    84      (Typedef.add_typedef_global false NONE
    85        (qty_name, map (rpair dummyS) vs, mx)
    86          (typedef_term rel rty lthy)
    87            NONE typedef_tac) lthy
    88 end
    89 
    90 
    91 (* tactic to prove the quot_type theorem for the new type *)
    92 fun typedef_quot_type_tac equiv_thm ((_, typedef_info): Typedef.info) =
    93 let
    94   val rep_thm = #Rep typedef_info RS mem_def1
    95   val rep_inv = #Rep_inverse typedef_info
    96   val abs_inv = mem_def2 RS #Abs_inverse typedef_info
    97   val rep_inj = #Rep_inject typedef_info
    98 in
    99   (rtac @{thm quot_type.intro} THEN' RANGE [
   100     rtac equiv_thm,
   101     rtac rep_thm,
   102     rtac rep_inv,
   103     EVERY' (map rtac [abs_inv, @{thm exI}, @{thm refl}]),
   104     rtac rep_inj]) 1
   105 end
   106 
   107 
   108 (* proves the quot_type theorem for the new type *)
   109 fun typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy =
   110 let
   111   val quot_type_const = Const (@{const_name "quot_type"}, dummyT)
   112   val goal =
   113     HOLogic.mk_Trueprop (quot_type_const $ rel $ abs $ rep)
   114     |> Syntax.check_term lthy
   115 in
   116   Goal.prove lthy [] [] goal
   117     (K (typedef_quot_type_tac equiv_thm typedef_info))
   118 end
   119 
   120 (* proves the quotient theorem for the new type *)
   121 fun typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_type_thm) lthy =
   122 let
   123   val quotient_const = Const (@{const_name "Quotient"}, dummyT)
   124   val goal =
   125     HOLogic.mk_Trueprop (quotient_const $ rel $ abs $ rep)
   126     |> Syntax.check_term lthy
   127 
   128   val typedef_quotient_thm_tac =
   129     EVERY1 [
   130       K (rewrite_goals_tac [abs_def, rep_def]),
   131       rtac @{thm quot_type.Quotient},
   132       rtac quot_type_thm]
   133 in
   134   Goal.prove lthy [] [] goal
   135     (K typedef_quotient_thm_tac)
   136 end
   137 
   138 
   139 (* main function for constructing a quotient type *)
   140 fun add_quotient_type (((vs, qty_name, mx), (rty, rel)), equiv_thm) lthy =
   141 let
   142   (* generates the typedef *)
   143   val ((qty_full_name, typedef_info), lthy1) = typedef_make (vs, qty_name, mx, rel, rty) lthy
   144 
   145   (* abs and rep functions from the typedef *)
   146   val Abs_ty = #abs_type (#1 typedef_info)
   147   val Rep_ty = #rep_type (#1 typedef_info)
   148   val Abs_name = #Abs_name (#1 typedef_info)
   149   val Rep_name = #Rep_name (#1 typedef_info)
   150   val Abs_const = Const (Abs_name, Rep_ty --> Abs_ty)
   151   val Rep_const = Const (Rep_name, Abs_ty --> Rep_ty)
   152 
   153   (* more useful abs and rep definitions *)
   154   val abs_const = Const (@{const_name "quot_type.abs"}, dummyT )
   155   val rep_const = Const (@{const_name "quot_type.rep"}, dummyT )
   156   val abs_trm = Syntax.check_term lthy1 (abs_const $ rel $ Abs_const)
   157   val rep_trm = Syntax.check_term lthy1 (rep_const $ Rep_const)
   158   val abs_name = Binding.prefix_name "abs_" qty_name
   159   val rep_name = Binding.prefix_name "rep_" qty_name
   160 
   161   val ((abs, abs_def), lthy2) = define (abs_name, NoSyn, abs_trm) lthy1
   162   val ((rep, rep_def), lthy3) = define (rep_name, NoSyn, rep_trm) lthy2
   163 
   164   (* quot_type theorem *)
   165   val quot_thm = typedef_quot_type_thm (rel, Abs_const, Rep_const, equiv_thm, typedef_info) lthy3
   166 
   167   (* quotient theorem *)
   168   val quotient_thm = typedef_quotient_thm (rel, abs, rep, abs_def, rep_def, quot_thm) lthy3
   169   val quotient_thm_name = Binding.prefix_name "Quotient_" qty_name
   170 
   171   (* name equivalence theorem *)
   172   val equiv_thm_name = Binding.suffix_name "_equivp" qty_name
   173 
   174   (* storing the quot-info *)
   175   fun qinfo phi = transform_quotdata phi
   176     {qtyp = Abs_ty, rtyp = rty, equiv_rel = rel, equiv_thm = equiv_thm}
   177   val lthy4 = Local_Theory.declaration true
   178     (fn phi => quotdata_update_gen qty_full_name (qinfo phi)) lthy3
   179 in
   180   lthy4
   181   |> note (quotient_thm_name, quotient_thm, [intern_attr quotient_rules_add])
   182   ||>> note (equiv_thm_name, equiv_thm, [intern_attr equiv_rules_add])
   183 end
   184 
   185 
   186 (* sanity checks for the quotient type specifications *)
   187 fun sanity_check ((vs, qty_name, _), (rty, rel)) =
   188 let
   189   val rty_tfreesT = map fst (Term.add_tfreesT rty [])
   190   val rel_tfrees = map fst (Term.add_tfrees rel [])
   191   val rel_frees = map fst (Term.add_frees rel [])
   192   val rel_vars = Term.add_vars rel []
   193   val rel_tvars = Term.add_tvars rel []
   194   val qty_str = Binding.str_of qty_name ^ ": "
   195 
   196   val illegal_rel_vars =
   197     if null rel_vars andalso null rel_tvars then []
   198     else [qty_str ^ "illegal schematic variable(s) in the relation."]
   199 
   200   val dup_vs =
   201     (case duplicates (op =) vs of
   202        [] => []
   203      | dups => [qty_str ^ "duplicate type variable(s) on the lhs: " ^ commas_quote dups])
   204 
   205   val extra_rty_tfrees =
   206     (case subtract (op =) vs rty_tfreesT of
   207        [] => []
   208      | extras => [qty_str ^ "extra type variable(s) on the lhs: " ^ commas_quote extras])
   209 
   210   val extra_rel_tfrees =
   211     (case subtract (op =) vs rel_tfrees of
   212        [] => []
   213      | extras => [qty_str ^ "extra type variable(s) in the relation: " ^ commas_quote extras])
   214 
   215   val illegal_rel_frees =
   216     (case rel_frees of
   217       [] => []
   218     | xs => [qty_str ^ "illegal variable(s) in the relation: " ^ commas_quote xs])
   219 
   220   val errs = illegal_rel_vars @ dup_vs @ extra_rty_tfrees @ extra_rel_tfrees @ illegal_rel_frees
   221 in
   222   if null errs then () else error (cat_lines errs)
   223 end
   224 
   225 (* check for existence of map functions *)
   226 fun map_check ctxt (_, (rty, _)) =
   227 let
   228   val thy = ProofContext.theory_of ctxt
   229 
   230   fun map_check_aux rty warns =
   231     case rty of
   232       Type (_, []) => warns
   233     | Type (s, _) => if maps_defined thy s then warns else s::warns
   234     | _ => warns
   235 
   236   val warns = map_check_aux rty []
   237 in
   238   if null warns then ()
   239   else warning ("No map function defined for " ^ commas warns ^
   240     ". This will cause problems later on.")
   241 end
   242 
   243 
   244 
   245 (*** interface and syntax setup ***)
   246 
   247 
   248 (* the ML-interface takes a list of 5-tuples consisting of:
   249 
   250  - the name of the quotient type
   251  - its free type variables (first argument)
   252  - its mixfix annotation
   253  - the type to be quotient
   254  - the relation according to which the type is quotient
   255 
   256  it opens a proof-state in which one has to show that the
   257  relations are equivalence relations
   258 *)
   259 
   260 fun quotient_type quot_list lthy =
   261 let
   262   (* sanity check *)
   263   val _ = List.app sanity_check quot_list
   264   val _ = List.app (map_check lthy) quot_list
   265 
   266   fun mk_goal (rty, rel) =
   267   let
   268     val equivp_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool}
   269   in
   270     HOLogic.mk_Trueprop (Const (@{const_name equivp}, equivp_ty) $ rel)
   271   end
   272 
   273   val goals = map (mk_goal o snd) quot_list
   274 
   275   fun after_qed thms lthy =
   276     fold_map add_quotient_type (quot_list ~~ thms) lthy |> snd
   277 in
   278   theorem after_qed goals lthy
   279 end
   280 
   281 fun quotient_type_cmd specs lthy =
   282 let
   283   fun parse_spec ((((vs, qty_name), mx), rty_str), rel_str) lthy =
   284   let
   285     val rty = Syntax.read_typ lthy rty_str
   286     val lthy1 = Variable.declare_typ rty lthy
   287     val rel = 
   288       Syntax.parse_term lthy1 rel_str
   289       |> Syntax.type_constraint (rty --> rty --> @{typ bool}) 
   290       |> Syntax.check_term lthy1 
   291     val lthy2 = Variable.declare_term rel lthy1 
   292   in
   293     (((vs, qty_name, mx), (rty, rel)), lthy2)
   294   end
   295 
   296   val (spec', lthy') = fold_map parse_spec specs lthy
   297 in
   298   quotient_type spec' lthy'
   299 end
   300 
   301 val quotspec_parser =
   302     OuterParse.and_list1
   303      ((OuterParse.type_args -- OuterParse.binding) --
   304         OuterParse.opt_mixfix -- (OuterParse.$$$ "=" |-- OuterParse.typ) --
   305          (OuterParse.$$$ "/" |-- OuterParse.term))
   306 
   307 val _ = OuterKeyword.keyword "/"
   308 
   309 val _ =
   310     OuterSyntax.local_theory_to_proof "quotient_type"
   311       "quotient type definitions (require equivalence proofs)"
   312          OuterKeyword.thy_goal (quotspec_parser >> quotient_type_cmd)
   313 
   314 end; (* structure *)