signature QUOTIENT =

sig

  type maps_info = {mapfun: string, relfun: string}

  type quotient_info = {qtyp: typ, rtyp: typ, rel: term, equiv_thm: thm}

  val mk_quotient_type: ((binding * mixfix) * (typ * term)) list -> Proof.context -> Proof.state

  val mk_quotient_type_cmd: (((bstring * mixfix) * string) * string) list -> Proof.context -> Proof.state

  val define: binding * mixfix * term -> local_theory -> (term * thm) * local_theory

  val note: binding * thm -> local_theory -> thm * local_theory

  val maps_lookup: theory -> string -> maps_info option

  val maps_update_thy: string -> maps_info -> theory -> theory    

  val maps_update: string -> maps_info -> Proof.context -> Proof.context                           

  val print_quotdata: Proof.context -> unit

  val quotdata_lookup_thy: theory -> quotient_info list

  val quotdata_lookup: Proof.context -> quotient_info list

  val quotdata_update_thy: (typ * typ * term * thm) -> theory -> theory

  val quotdata_update: (typ * typ * term * thm) -> Proof.context -> Proof.context

end;

structure Quotient: QUOTIENT =

struct

(* data containers *)

(*******************)

(* info about map- and rel-functions *)

type maps_info = {mapfun: string, relfun: string}

structure MapsData = TheoryDataFun

  (type T = maps_info Symtab.table

   val empty = Symtab.empty

   val copy = I

   val extend = I

   fun merge _ = Symtab.merge (K true))

val maps_lookup = Symtab.lookup o MapsData.get

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 thm => 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

in

  maps_attribute_aux tyname {mapfun = mapname, relfun = 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"))

(* info about the quotient types *)

type quotient_info = {qtyp: typ, rtyp: typ, rel: term, equiv_thm: thm}

structure QuotData = TheoryDataFun

  (type T = quotient_info list

   val empty = []

   val copy = I

   val extend = I

   fun merge _ = (op @)) (* FIXME: is this the correct merging function for the list? *)

val quotdata_lookup_thy = QuotData.get

val quotdata_lookup = QuotData.get o ProofContext.theory_of

fun quotdata_update_thy (qty, rty, rel, equiv_thm) thy = 

      QuotData.map (fn ls => {qtyp = qty, rtyp = rty, rel = rel, equiv_thm = equiv_thm}::ls) thy

fun quotdata_update (qty, rty, rel, equiv_thm) ctxt = 

      ProofContext.theory (quotdata_update_thy (qty, rty, rel, equiv_thm)) ctxt

fun print_quotdata ctxt =

let

  fun prt_quot {qtyp, rtyp, 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 rel,

           Pretty.str ("equiv. thm:"), 

           Syntax.pretty_term ctxt (prop_of equiv_thm)])

in

  QuotData.get (ProofContext.theory_of ctxt)

  |> map prt_quot

  |> Pretty.big_list "quotients:" 

  |> Pretty.writeln

end

val _ = 

  OuterSyntax.improper_command "print_quotients" "print out all quotients" 

    OuterKeyword.diag (Scan.succeed (Toplevel.keep (print_quotdata o Toplevel.context_of)))

(* wrappers for define, note and theorem_i *)

fun define (name, mx, rhs) lthy =

let

  val ((rhs, (_ , thm)), lthy') =

     LocalTheory.define Thm.internalK ((name, mx), (Attrib.empty_binding, rhs)) lthy

in

  ((rhs, thm), lthy')

end

fun note (name, thm) lthy =

let

  val ((_,[thm']), lthy') = LocalTheory.note Thm.theoremK ((name, []), [thm]) lthy

in

  (thm', lthy')

end

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 the quotient type *)

(***********************************)

(* 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

  LocalTheory.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 lthy3 = quotdata_update (abs_ty, rty, rel, equiv_thm) lthy2

  (* interpretation *)

  val bindd = ((Binding.make ("", Position.none)), ([]: Attrib.src list))

  val ((_, [eqn1pre]), lthy4) = Variable.import true [ABS_def] lthy3;

  val eqn1i = Thm.prop_of (symmetric eqn1pre)

  val ((_, [eqn2pre]), lthy5) = Variable.import true [REP_def] lthy4;

  val eqn2i = Thm.prop_of (symmetric eqn2pre)

  val exp_morphism = ProofContext.export_morphism lthy5 (ProofContext.init (ProofContext.theory_of lthy5));

  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

  lthy5

  |> note (quot_thm_name, quot_thm)

  ||>> note (quotient_thm_name, quotient_thm)

  ||> LocalTheory.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, lthy6) = Variable.import_terms true global_eqns lthy5;

        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 mk_quotient_type quot_list lthy = 

let

  fun mk_goal (rty, rel) =

  let

    val EQUIV_ty = ([rty, rty] ---> @{typ bool}) --> @{typ bool}

  in 

    HOLogic.mk_Trueprop (Const (@{const_name EQUIV}, EQUIV_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 mk_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.parse_typ lthy rty_str |> Syntax.check_typ lthy

    val rel = Syntax.parse_term lthy rel_str |> Syntax.check_term lthy

  in

    ((qty_name, mx), (rty, rel))

  end

in

  mk_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 >> mk_quotient_type_cmd)

end; (* structure *)

open Quotient