signature SIMPLE_INDUCTIVE_PACKAGE =

sig

  val add_inductive_i:

    ((binding * typ) * mixfix) list ->

    (binding * typ) list ->

    (Attrib.binding * term) list ->

    local_theory -> (thm list * thm list) * local_theory

  val add_inductive:

    (binding * string option * mixfix) list ->

    (binding * string option * mixfix) list ->

    (Attrib.binding * string) list ->

    local_theory -> (thm list * thm list) * local_theory

end;

structure SimpleInductivePackage: SIMPLE_INDUCTIVE_PACKAGE =

struct

fun add_inductive_i preds_syn params intrs lthy =

  let

    val params' = map (fn (p, T) => Free (Binding.name_of p, T)) params;

    val preds = map (fn ((R, T), _) =>

      list_comb (Free (Binding.name_of R, T), params')) preds_syn;

    val Tss = map (binder_types o fastype_of) preds;

    (* making the definition *)

    val intrs' = map

      (ObjectLogic.atomize_term (ProofContext.theory_of lthy) o snd) intrs;

    fun mk_all x P = HOLogic.all_const (fastype_of x) $ lambda x P;

    val (defs, lthy1) = fold_map (fn ((((R, _), syn), pred), Ts) =>

      let val zs = map Free (Variable.variant_frees lthy intrs'

        (map (pair "z") Ts))

      in

        LocalTheory.define Thm.internalK

          ((R, syn), (Attrib.empty_binding, fold_rev lambda (params' @ zs)

            (fold_rev mk_all preds (fold_rev (curry HOLogic.mk_imp)

               intrs' (list_comb (pred, zs)))))) #>> snd #>> snd

       end) (preds_syn ~~ preds ~~ Tss) lthy;

    val (_, lthy2) = Variable.add_fixes (map (Binding.name_of o fst) params) lthy1;

    (* proving the induction rules *)

    val (Pnames, lthy3) =

      Variable.variant_fixes (replicate (length preds) "P") lthy2;

    val Ps = map (fn (s, Ts) => Free (s, Ts ---> HOLogic.boolT))

      (Pnames ~~ Tss);

    val cPs = map (cterm_of (ProofContext.theory_of lthy3)) Ps;

    val intrs'' = map (subst_free (preds ~~ Ps) o snd) intrs;

    fun inst_spec ct = Drule.instantiate'

      [SOME (ctyp_of_term ct)] [NONE, SOME ct] spec;

    fun prove_indrule ((R, P), Ts) =

      let

        val (znames, lthy4) =

          Variable.variant_fixes (replicate (length Ts) "z") lthy3;

        val zs = map Free (znames ~~ Ts)

      in

        Goal.prove lthy4 []

          [HOLogic.mk_Trueprop (list_comb (R, zs))]

          (Logic.list_implies (intrs'',

             HOLogic.mk_Trueprop (list_comb (P, zs))))

          (fn {prems, ...} => EVERY

             ([ObjectLogic.full_atomize_tac 1,

               cut_facts_tac prems 1,

               rewrite_goals_tac defs] @

              map (fn ct => dtac (inst_spec ct) 1) cPs @

              [assume_tac 1])) |>

        singleton (ProofContext.export lthy4 lthy1)

      end;

    val indrules = map prove_indrule (preds ~~ Ps ~~ Tss);

    (* proving the introduction rules *)

    val all_elims = fold (fn ct => fn th => th RS inst_spec ct);

    val imp_elims = fold (fn th => fn th' => [th', th] MRS mp);

    fun prove_intr (i, (_, r)) =

      Goal.prove lthy2 [] [] r

        (fn {prems, context = ctxt} => EVERY

           [ObjectLogic.rulify_tac 1,

            rewrite_goals_tac defs,

            REPEAT (resolve_tac [allI, impI] 1),

            SUBPROOF (fn {params, prems, context = ctxt', ...} =>

              let

                val (prems1, prems2) =

                  chop (length prems - length intrs) prems;

                val (params1, params2) =

                  chop (length params - length preds) (map snd params)

              in

                rtac (ObjectLogic.rulify

                  (all_elims params1 (nth prems2 i))) 1 THEN

                EVERY (map (fn prem =>

                  SUBPROOF (fn {prems = prems', concl, ...} =>

                    let

                      val prem' = prems' MRS prem;

                      val prem'' = case prop_of prem' of

                          _ $ (Const (@{const_name All}, _) $ _) =>

                            prem' |> all_elims params2 |>

                            imp_elims prems2

                        | _ => prem'

                    in rtac prem'' 1 end) ctxt' 1) prems1)

              end) ctxt 1]) |>

      singleton (ProofContext.export lthy2 lthy1);

    val intr_ths = map_index prove_intr intrs;

    (* storing the theorems *)

    val mut_name = space_implode "_" (map (Binding.name_of o fst o fst) preds_syn);

    val case_names = map (Binding.name_of o fst o fst) intrs

  in

    lthy1 |>

    LocalTheory.notes Thm.theoremK (map (fn (((a, atts), _), th) =>

      ((Binding.qualify false mut_name a, atts), [([th], [])]))

        (intrs ~~ intr_ths)) |->

    (fn intr_thss => LocalTheory.note Thm.theoremK

       ((Binding.qualify false mut_name (Binding.name "intros"), []), maps snd intr_thss)) |>>

    snd ||>>

    (LocalTheory.notes Thm.theoremK (map (fn (((R, _), _), th) =>

       ((Binding.qualify false (Binding.name_of R) (Binding.name "induct"),

         [Attrib.internal (K (RuleCases.case_names case_names)),

          Attrib.internal (K (RuleCases.consumes 1)),

          Attrib.internal (K (Induct.induct_pred ""))]), [([th], [])]))

         (preds_syn ~~ indrules)) #>> maps snd)

  end;

fun add_inductive preds_syn params_syn intro_srcs lthy =

  let

    val ((vars, intrs), _) = Specification.read_spec

      (preds_syn @ params_syn) intro_srcs lthy;

    val (preds_syn', params_syn') = chop (length preds_syn) vars

  in

    add_inductive_i preds_syn' (map fst params_syn') intrs lthy

  end;

(* outer syntax *)

local structure P = OuterParse and K = OuterKeyword in

val ind_decl =

  P.fixes -- P.for_fixes --

  Scan.optional (P.$$$ "where" |--

    P.!!! (P.enum1 "|" (SpecParse.opt_thm_name ":" -- P.prop))) [] >>

  (fn ((preds, params), specs) =>

    add_inductive preds params specs #> snd);

val _ = OuterSyntax.local_theory "simple_inductive" "define inductive predicates"

  K.thy_decl ind_decl;

end;

end;