src/HOL/Tools/Qelim/langford_data.ML

adaptions due to rearrangment of power operation

signature LANGFORD_DATA =
sig
  type entry
  val get: Proof.context -> simpset * (thm * entry) list
  val add: entry -> attribute 
  val del: attribute
  val setup: theory -> theory
  val match: Proof.context -> cterm -> entry option
end;

structure Langford_Data: LANGFORD_DATA = 
struct

(* data *)
type entry = {qe_bnds: thm, qe_nolb : thm , qe_noub: thm, 
              gs : thm list, gst : thm, atoms: cterm list};
val eq_key = Thm.eq_thm;
fun eq_data arg = eq_fst eq_key arg;

structure Data = GenericDataFun
( type T = simpset * (thm * entry) list;
  val empty = (HOL_basic_ss, []);
  val extend = I;
  fun merge _ ((ss1,es1), (ss2,es2)) = 
       (merge_ss (ss1,ss2), AList.merge eq_key (K true) (es1,es2));;
);

val get = Data.get o Context.Proof;

fun del_data key = apsnd (remove eq_data (key, []));

val del = Thm.declaration_attribute (Data.map o del_data);

fun add entry = 
    Thm.declaration_attribute (fn key => fn context => context |> Data.map 
      (del_data key #> apsnd (cons (key, entry))));

val add_simp = Thm.declaration_attribute (fn th => fn context => 
  context |> Data.map (fn (ss,ts') => (ss addsimps [th], ts'))) 

val del_simp = Thm.declaration_attribute (fn th => fn context => 
  context |> Data.map (fn (ss,ts') => (ss delsimps [th], ts'))) 

fun match ctxt tm =
  let
    fun match_inst
        {qe_bnds, qe_nolb, qe_noub, gs, gst, atoms} pat =
       let
        fun h instT =
          let
            val substT = Thm.instantiate (instT, []);
            val substT_cterm = Drule.cterm_rule substT;

            val qe_bnds' = substT qe_bnds
            val qe_nolb' = substT qe_nolb
            val qe_noub' = substT qe_noub
            val gs' = map substT gs
            val gst' = substT gst
            val atoms' = map substT_cterm atoms
            val result = {qe_bnds = qe_bnds', qe_nolb = qe_nolb', 
                          qe_noub = qe_noub', gs = gs', gst = gst', 
                          atoms = atoms'}
          in SOME result end
      in (case try Thm.match (pat, tm) of
           NONE => NONE
         | SOME (instT, _) => h instT)
      end;

    fun match_struct (_,
        entry as ({atoms = atoms, ...}): entry) =
      get_first (match_inst entry) atoms;
  in get_first match_struct (snd (get ctxt)) end;

(* concrete syntax *)

local
val qeN = "qe";
val gatherN = "gather";
val atomsN = "atoms"
fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ();
val any_keyword =
  keyword qeN || keyword gatherN || keyword atomsN;

val thms = Scan.repeat (Scan.unless any_keyword Attrib.multi_thm) >> flat;
val terms = thms >> map Drule.dest_term;
in

val langford_setup =
  Attrib.setup @{binding langford}
    ((keyword qeN |-- thms)
     -- (keyword gatherN |-- thms)
     -- (keyword atomsN |-- terms) >>
       (fn ((qes,gs), atoms) => 
       if length qes = 3 andalso length gs > 1 then
         let 
           val [q1,q2,q3] = qes
           val gst::gss = gs
           val entry = {qe_bnds = q1, qe_nolb = q2,
                        qe_noub = q3, gs = gss, gst = gst, atoms = atoms}
         in add entry end
       else error "Need 3 theorems for qe and at least one for gs"))
    "Langford data";

end;

(* theory setup *)

val setup =
  langford_setup #>
  Attrib.setup @{binding langfordsimp} (Attrib.add_del add_simp del_simp) "Langford simpset";

end;