diff -r aec7073d4645 -r daf404920ab9 ProgTutorial/Package/simple_inductive_package.ML --- a/ProgTutorial/Package/simple_inductive_package.ML Fri Jun 03 15:15:17 2016 +0100 +++ b/ProgTutorial/Package/simple_inductive_package.ML Tue May 14 11:10:53 2019 +0200 @@ -49,8 +49,7 @@ (* @chunk definitions *) fun definitions rules params preds prednames syns arg_typess lthy = let - val thy = Proof_Context.theory_of lthy - val orules = map (Object_Logic.atomize_term thy) rules + val orules = map (Object_Logic.atomize_term lthy) rules val defs = map (defs_aux lthy orules preds params) (preds ~~ arg_typess) in @@ -59,15 +58,18 @@ (* @end *) fun inst_spec ct = - Drule.instantiate' [SOME (ctyp_of_term ct)] [NONE, SOME ct] @{thm spec}; + Thm.instantiate' [SOME (Thm.ctyp_of_cterm ct)] [NONE, SOME ct] @{thm spec}; + +fun dtac ctxt thm = dresolve_tac ctxt [thm] +fun rtac ctxt thm = resolve_tac ctxt [thm] (* @chunk induction_tac *) fun induction_tac ctxt defs prems insts = EVERY1 [Object_Logic.full_atomize_tac ctxt, cut_facts_tac prems, rewrite_goal_tac ctxt defs, - EVERY' (map (dtac o inst_spec) insts), - assume_tac] + EVERY' (map (dtac ctxt o inst_spec) insts), + assume_tac ctxt] (* @end *) (* @chunk induction_rules *) @@ -77,12 +79,10 @@ val Ps = replicate (length preds) "P" val (newprednames, lthy3) = Variable.variant_fixes Ps lthy2 - - val thy = Proof_Context.theory_of lthy3 - + val Tss' = map (fn Ts => Ts ---> HOLogic.boolT) Tss val newpreds = map Free (newprednames ~~ Tss') - val cnewpreds = map (cterm_of thy) newpreds + val cnewpreds = map (Thm.cterm_of lthy3) newpreds val rules' = map (subst_free (preds ~~ newpreds)) rules fun prove_induction ((pred, newpred), Ts) = @@ -110,17 +110,17 @@ (* @chunk subproof1 *) fun subproof2 prem params2 prems2 = - SUBPROOF (fn {prems, ...} => + SUBPROOF (fn {prems, context, ...} => let val prem' = prems MRS prem; val prem'' = - case prop_of prem' of + case Thm.prop_of prem' of _ $ (Const (@{const_name All}, _) $ _) => prem' |> all_elims params2 |> imp_elims prems2 | _ => prem'; in - rtac prem'' 1 + rtac context prem'' 1 end) (* @end *) @@ -131,7 +131,7 @@ val (prems1, prems2) = chop (length prems - length rules) prems; val (params1, params2) = chop (length params - length preds) (map snd params); in - rtac (Object_Logic.rulify ctxt' (all_elims params1 (nth prems2 i))) 1 + rtac ctxt' (Object_Logic.rulify ctxt' (all_elims params1 (nth prems2 i))) 1 THEN EVERY1 (map (fn prem => subproof2 prem params2 prems2 ctxt') prems1) end) @@ -140,7 +140,7 @@ fun introductions_tac defs rules preds i ctxt = EVERY1 [Object_Logic.rulify_tac ctxt, rewrite_goal_tac ctxt defs, - REPEAT o (resolve_tac [@{thm allI},@{thm impI}]), + REPEAT o (resolve_tac ctxt [@{thm allI},@{thm impI}]), subproof1 rules preds i ctxt] @@ -194,16 +194,15 @@ |> snd end (* @end *) - +val _ = Proof_Context.read_stmt (* @chunk read_specification *) fun read_specification' vars specs lthy = let - val specs' = map (fn (a, s) => (a, [s])) specs - val ((varst, specst), _) = - Specification.read_specification vars specs' lthy - val specst' = map (apsnd the_single) specst + val specs' = map (fn (a, s) => ((a, s), [],[])) specs + val ((varst, specst),_) = + Specification.read_multi_specs vars specs' lthy in - (varst, specst') + (varst, specst) end (* @end *) @@ -221,7 +220,7 @@ (* @chunk parser *) val spec_parser = Parse.opt_target -- - Parse.fixes -- + Parse.vars -- Parse.for_fixes -- Scan.optional (Parse.$$$ "where" |-- @@ -234,10 +233,11 @@ val specification = spec_parser >> (fn (((loc, preds), params), specs) => - Toplevel.local_theory loc (add_inductive preds params specs)) + Toplevel.local_theory NONE loc (add_inductive preds params specs)) -val _ = Outer_Syntax.command @{command_spec "simple_inductive"} "define inductive predicates" +val _ = Outer_Syntax.command @{command_keyword "simple_inductive"} "define inductive predicates" specification + (* @end *) end;