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