--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Nominal/activities/tphols09/IDW/InductiveInternals.thy	Wed Mar 30 17:27:34 2016 +0100
@@ -0,0 +1,189 @@
+theory InductiveInternals
+imports Main
+begin
+
+section {* Parsing *}
+
+ML {*
+fun parse p s =
+  Scan.finite OuterLex.stopper (Scan.error (OuterParse.!!! p))
+    (filter OuterLex.is_proper (OuterSyntax.scan Position.none s));
+*}
+
+ML {*
+local structure P = OuterParse and K = OuterKeyword in
+
+val ind_parser =
+  P.fixes -- P.for_fixes --
+  Scan.optional (P.$$$ "where" |--
+    P.!!! (P.enum1 "|" (SpecParse.opt_thm_name ":" -- P.prop))) [];
+
+end;
+*}
+
+ML {*
+parse ind_parser
+"even and odd \
+\where\
+\  even0: \"even 0\"\
+\| evenS: \"odd n \<Longrightarrow> even (Suc n)\"\
+\| oddS: \"even n \<Longrightarrow> odd (Suc n)\""
+*}
+
+ML {*
+val (((preds_syn, params_syn), intro_srcs), []) =
+parse ind_parser
+"accpart for r :: \"'a \<Rightarrow> 'a \<Rightarrow> bool\"\
+\where\
+\  accpartI: \"(\<And>y. r y x \<Longrightarrow> accpart r y) \<Longrightarrow> accpart r x\""
+*}
+
+
+section {* Reading the Specification *}
+
+ML {*
+val lthy = TheoryTarget.context "-" @{theory}
+*}
+
+ML {*
+val ((vars, intrs), _) = Specification.read_spec
+  (preds_syn @ params_syn) intro_srcs lthy;
+val (preds_syn, params_syn') = chop (length preds_syn) vars
+val params = map fst params_syn';
+*}
+
+
+section {* Making the definition *}
+
+ML {*
+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;
+
+val intrs' = map
+  (ObjectLogic.atomize_term (ProofContext.theory_of lthy) o snd) intrs;
+*}
+
+ML {*
+fun mk_all x P = HOLogic.all_const (fastype_of x) $ lambda x P;
+*}
+
+ML {*
+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;
+*}
+
+ML {*
+val (_, lthy2) = Variable.add_fixes
+  (map (Binding.name_of o fst) params) lthy1;
+*}
+
+
+section {* Proving the induction rules *}
+
+ML {*
+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;
+*}
+
+ML {*
+fun inst_spec ct = Drule.instantiate'
+  [SOME (ctyp_of_term ct)] [NONE, SOME ct] spec;
+*}
+
+ML {*
+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;
+*}
+
+ML {*
+val indrules = map prove_indrule (preds ~~ Ps ~~ Tss);
+*}
+
+
+section {* Proving the introduction rules *}
+
+ML {*
+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);
+*}
+
+ML {*
+fun show_thms ctxt s ths = warning (s ^ ":\n" ^
+  Pretty.string_of (Pretty.chunks (map (Display.pretty_thm ctxt) ths)));
+
+fun show_cterms ctxt s cts = warning (s ^ ":\n" ^
+  Pretty.string_of (Pretty.list "[" "]"
+    (map (Syntax.pretty_term ctxt o term_of) cts)));
+*}
+
+ML {*
+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 _ = show_thms ctxt' "prems1" prems1;
+            val _ = show_thms ctxt' "prems2" prems2;
+            val (params1, params2) =
+              chop (length params - length preds) (map snd params)
+            val _ = show_cterms ctxt' "params1" params1;
+            val _ = show_cterms ctxt' "params2" params2;
+          in
+            rtac (ObjectLogic.rulify
+              (all_elims params1 (nth prems2 i))) 1 THEN
+            EVERY (map (fn prem =>
+              SUBPROOF (fn {prems = prems', concl, context = ctxt'', ...} =>
+                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'
+                  val _ = show_thms ctxt'' "prem" [prem];
+                  val _ = show_thms ctxt'' "prem'" [prem'];
+                  val _ = show_thms ctxt'' "prem''" [prem''];
+                in rtac prem'' 1 end) ctxt' 1) prems1)
+          end) ctxt 1]) |>
+  singleton (ProofContext.export lthy2 lthy1);
+*}
+
+ML {*
+val intr_ths = map_index prove_intr intrs;
+*}
+
+end