src/HOL/Tools/Predicate_Compile/core_data.ML
changeset 59582 0fbed69ff081
parent 59501 38c6cba073f4
child 59621 291934bac95e
equal deleted inserted replaced
59580:cbc38731d42f 59582:0fbed69ff081
   233     fun instantiate i n ({context = ctxt2, prems, ...}: Subgoal.focus) =
   233     fun instantiate i n ({context = ctxt2, prems, ...}: Subgoal.focus) =
   234       let
   234       let
   235         fun term_pair_of (ix, (ty, t)) = (Var (ix, ty), t)
   235         fun term_pair_of (ix, (ty, t)) = (Var (ix, ty), t)
   236         fun inst_of_matches tts =
   236         fun inst_of_matches tts =
   237           fold (Pattern.match thy) tts (Vartab.empty, Vartab.empty)
   237           fold (Pattern.match thy) tts (Vartab.empty, Vartab.empty)
   238           |> snd |> Vartab.dest |> map (apply2 (cterm_of thy) o term_pair_of)
   238           |> snd |> Vartab.dest |> map (apply2 (Thm.cterm_of thy) o term_pair_of)
   239         val (cases, (eqs, prems1)) = apsnd (chop (nargs - nparams)) (chop n prems)
   239         val (cases, (eqs, prems1)) = apsnd (chop (nargs - nparams)) (chop n prems)
   240         val case_th =
   240         val case_th =
   241           rewrite_rule ctxt2 (@{thm Predicate.eq_is_eq} :: map meta_eq_of eqs) (nth cases (i - 1))
   241           rewrite_rule ctxt2 (@{thm Predicate.eq_is_eq} :: map meta_eq_of eqs) (nth cases (i - 1))
   242         val prems2 = maps (dest_conjunct_prem o rewrite_rule ctxt2 tuple_rew_rules) prems1
   242         val prems2 = maps (dest_conjunct_prem o rewrite_rule ctxt2 tuple_rew_rules) prems1
   243         val pats =
   243         val pats =
   245             (take nargs (Thm.prems_of case_th))
   245             (take nargs (Thm.prems_of case_th))
   246         val case_th' =
   246         val case_th' =
   247           Thm.instantiate ([], inst_of_matches pats) case_th
   247           Thm.instantiate ([], inst_of_matches pats) case_th
   248             OF replicate nargs @{thm refl}
   248             OF replicate nargs @{thm refl}
   249         val thesis =
   249         val thesis =
   250           Thm.instantiate ([], inst_of_matches (prems_of case_th' ~~ map prop_of prems2)) case_th'
   250           Thm.instantiate ([], inst_of_matches (Thm.prems_of case_th' ~~ map Thm.prop_of prems2))
   251             OF prems2
   251             case_th' OF prems2
   252       in rtac thesis 1 end
   252       in rtac thesis 1 end
   253   in
   253   in
   254     Goal.prove ctxt (Term.add_free_names cases_rule []) [] cases_rule
   254     Goal.prove ctxt (Term.add_free_names cases_rule []) [] cases_rule
   255       (fn {context = ctxt1, ...} =>
   255       (fn {context = ctxt1, ...} =>
   256         eresolve_tac ctxt1 [pre_cases_rule] 1 THEN (fn st =>
   256         eresolve_tac ctxt1 [pre_cases_rule] 1 THEN (fn st =>
   275         val thy = Proof_Context.theory_of ctxt
   275         val thy = Proof_Context.theory_of ctxt
   276 
   276 
   277         val pos = Position.thread_data ()
   277         val pos = Position.thread_data ()
   278         fun is_intro_of intro =
   278         fun is_intro_of intro =
   279           let
   279           let
   280             val (const, _) = strip_comb (HOLogic.dest_Trueprop (concl_of intro))
   280             val (const, _) = strip_comb (HOLogic.dest_Trueprop (Thm.concl_of intro))
   281           in (fst (dest_Const const) = name) end;
   281           in (fst (dest_Const const) = name) end;
   282         val intros = map (preprocess_intro thy) (filter is_intro_of (#intrs result))
   282         val intros = map (preprocess_intro thy) (filter is_intro_of (#intrs result))
   283         val index = find_index (fn s => s = name) (#names (fst info))
   283         val index = find_index (fn s => s = name) (#names (fst info))
   284         val pre_elim = nth (#elims result) index
   284         val pre_elim = nth (#elims result) index
   285         val pred = nth (#preds result) index
   285         val pred = nth (#preds result) index
   328   in PredData.map cons_intro thy end
   328   in PredData.map cons_intro thy end
   329 
   329 
   330 fun set_elim thm =
   330 fun set_elim thm =
   331   let
   331   let
   332     val (name, _) =
   332     val (name, _) =
   333       dest_Const (fst (strip_comb (HOLogic.dest_Trueprop (hd (prems_of thm)))))
   333       dest_Const (fst (strip_comb (HOLogic.dest_Trueprop (hd (Thm.prems_of thm)))))
   334   in
   334   in
   335     PredData.map (Graph.map_node name (map_pred_data (apsnd (apfst (apfst (apsnd (K (SOME thm))))))))
   335     PredData.map (Graph.map_node name (map_pred_data (apsnd (apfst (apfst (apsnd (K (SOME thm))))))))
   336   end
   336   end
   337 
   337 
   338 fun register_predicate (constname, intros, elim) thy =
   338 fun register_predicate (constname, intros, elim) thy =