diff -r 8a1c8dc72b5c -r ae254a6d685c quotient.ML
--- a/quotient.ML	Mon Dec 07 14:09:50 2009 +0100
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,253 +0,0 @@
-signature QUOTIENT =
-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: QUOTIENT =
-struct
-
-exception LIFT_MATCH of string
-
-(* wrappers for define, note 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 internal_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 the quotient type *)
-fun mk_typedef_main (((qty_name, mx), (rty, rel)), equiv_thm) lthy =
-let
-  (* generates typedef *)
-  val ((_, typedef_info), lthy1) = typedef_make (qty_name, mx, rel, rty) lthy
-
-  (* abs and rep functions *)
-  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)
-
-  (* 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 needs to be a string, since its type needs *)
-  (* FIXME: to recalculated in for example REGULARIZE *)
-
-  (* storing of the equiv_thm under a name *)
-  val (_, lthy4) = note (Binding.suffix_name "_equivp" qty_name, equiv_thm, 
-                           [internal_attr equiv_rules_add]) lthy3
-
-  (* interpretation *)
-  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) ]))]
-in
-  lthy6
-  |> note (quot_thm_name, quot_thm, [])
-  ||>> note (quotient_thm_name, quotient_thm, [internal_attr quotient_rules_add])
-  ||> 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)
-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" 
-      "quotient type definitions (requires equivalence proofs)"
-         OuterKeyword.thy_goal (quotspec_parser >> quotient_type_cmd)
-
-end; (* structure *)
-
-open Quotient