signature QUOTIENT_TYPE =+
−
sig+
−
  exception LIFT_MATCH of string+
−
+
−
  val quotient_type: ((binding * mixfix) * (typ * term)) list -> Proof.context -> Proof.state+
−
  val quotient_type_cmd: (((bstring * mixfix) * string) * string) list -> Proof.context -> Proof.state+
−
+
−
end;+
−
+
−
structure Quotient_Type: QUOTIENT_TYPE =+
−
struct+
−
+
−
open Quotient_Info;+
−
+
−
exception LIFT_MATCH of string+
−
+
−
(* 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 *)+
−
(********************************)+
−
+
−
(* 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 (qty_name, mx, rel, rty) lthy =+
−
let+
−
  val typedef_tac =+
−
     EVERY1 [rewrite_goal_tac @{thms mem_def},+
−
             rtac @{thm exI},+
−
             rtac @{thm exI},+
−
             rtac @{thm refl}]+
−
  val tfrees = map fst (Term.add_tfreesT rty [])+
−
in+
−
  Local_Theory.theory_result+
−
    (Typedef.add_typedef false NONE+
−
       (qty_name, tfrees, 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 unfold_mem = MetaSimplifier.rewrite_rule [@{thm mem_def}]+
−
  val rep_thm = #Rep typedef_info |> unfold_mem+
−
  val rep_inv = #Rep_inverse typedef_info+
−
  val abs_inv = #Abs_inverse typedef_info |> unfold_mem+
−
  val rep_inj = #Rep_inject typedef_info+
−
in+
−
  EVERY1 [rtac @{thm QUOT_TYPE.intro},+
−
          rtac equiv_thm,+
−
          rtac rep_thm,+
−
          rtac rep_inv,+
−
          rtac abs_inv,+
−
          rtac @{thm exI}, +
−
          rtac @{thm refl},+
−
          rtac rep_inj]+
−
end+
−
+
−
(* proves the QUOT_TYPE theorem *)+
−
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 *)+
−
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 mk_typedef_main (((qty_name, mx), (rty, rel)), equiv_thm) lthy =+
−
let+
−
  (* generates the typedef *)+
−
  val ((_, typedef_info), lthy1) = typedef_make (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 (abs_name, rep_ty --> abs_ty)+
−
  val rep = Const (rep_name, abs_ty --> rep_ty)+
−
+
−
  (* more abstract 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)+
−
  val REP_trm = Syntax.check_term lthy1 (REP_const $ rep)+
−
  val ABS_name = Binding.prefix_name "abs_" qty_name+
−
  val REP_name = Binding.prefix_name "rep_" qty_name+
−
  val (((ABS, ABS_def), (REP, REP_def)), lthy2) =+
−
         lthy1 |> define (ABS_name, NoSyn, ABS_trm)+
−
               ||>> define (REP_name, NoSyn, REP_trm)+
−
+
−
  (* quot_type theorem *)+
−
  val quot_thm = typedef_quot_type_thm (rel, abs, rep, equiv_thm, typedef_info) lthy2+
−
  val quot_thm_name = Binding.prefix_name "QUOT_TYPE_" qty_name+
−
+
−
  (* quotient theorem *)+
−
  val quotient_thm = typedef_quotient_thm (rel, ABS, REP, ABS_def, REP_def, quot_thm) lthy2+
−
  val quotient_thm_name = Binding.prefix_name "Quotient_" qty_name+
−
+
−
  (* storing the quot-info *)+
−
  val qty_str = fst (Term.dest_Type abs_ty)+
−
  val lthy3 = quotdata_update qty_str +
−
               (Logic.varifyT abs_ty, Logic.varifyT rty, rel, equiv_thm) lthy2  +
−
  (* FIXME: varifyT should not be used *)+
−
  (* FIXME: the relation can be any term, that later maybe needs to be given *)+
−
  (* FIXME: a different type (in regularize_trm); how should tis be done?    *)+
−
+
−
in+
−
  lthy3+
−
  |> note (quot_thm_name, quot_thm, [])+
−
  ||>> note (quotient_thm_name, quotient_thm, [intern_attr quotient_rules_add])+
−
  ||>> note (Binding.suffix_name "_equivp" qty_name, equiv_thm, [intern_attr equiv_rules_add])+
−
end+
−
+
−
+
−
+
−
+
−
(* interface and syntax setup *)+
−
+
−
(* the ML-interface takes a list of 4-tuples consisting of  *)+
−
(*                                                          *)+
−
(* - the name of the quotient type                          *)+
−
(* - its mixfix annotation                                  *)+
−
(* - the type to be quotient                                *)+
−
(* - the relation according to which the type is quotient   *)+
−
+
−
fun quotient_type quot_list lthy = +
−
let+
−
  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 mk_typedef_main (quot_list ~~ thms) lthy |> snd+
−
in+
−
  theorem after_qed goals lthy+
−
end+
−
           +
−
fun quotient_type_cmd spec lthy = +
−
let+
−
  fun parse_spec (((qty_str, mx), rty_str), rel_str) =+
−
  let+
−
    val qty_name = Binding.name qty_str+
−
    val rty = Syntax.read_typ lthy rty_str+
−
    val rel = Syntax.read_term lthy rel_str +
−
  in+
−
    ((qty_name, mx), (rty, rel))+
−
  end+
−
in+
−
  quotient_type (map parse_spec spec) lthy+
−
end+
−
+
−
val quotspec_parser = +
−
    OuterParse.and_list1+
−
     (OuterParse.short_ident -- OuterParse.opt_infix -- +
−
       (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 *)+
−
+
−
+
−