src/HOL/Tools/inductive_realizer.ML
changeset 22790 e1cff9268177
parent 22606 962f824c2df9
child 23577 c5b93c69afd3
equal deleted inserted replaced
22789:4d03dc1cad04 22790:e1cff9268177
    18 (* FIXME: LocalTheory.note should return theorems with proper names! *)
    18 (* FIXME: LocalTheory.note should return theorems with proper names! *)
    19 fun name_of_thm thm =
    19 fun name_of_thm thm =
    20   (case Symtab.dest (Proofterm.thms_of_proof' (proof_of thm) Symtab.empty) of
    20   (case Symtab.dest (Proofterm.thms_of_proof' (proof_of thm) Symtab.empty) of
    21      [(name, _)] => name
    21      [(name, _)] => name
    22    | _ => error ("name_of_thm: bad proof of theorem\n" ^ string_of_thm thm));
    22    | _ => error ("name_of_thm: bad proof of theorem\n" ^ string_of_thm thm));
    23 
       
    24 (* infer order of variables in intro rules from order of quantifiers in elim rule *)
       
    25 fun infer_intro_vars elim arity intros =
       
    26   let
       
    27     val thy = theory_of_thm elim;
       
    28     val _ :: cases = prems_of elim;
       
    29     val used = map (fst o fst) (Term.add_vars (prop_of elim) []);
       
    30     fun mtch (t, u) =
       
    31       let
       
    32         val params = Logic.strip_params t;
       
    33         val vars = map (Var o apfst (rpair 0))
       
    34           (Name.variant_list used (map fst params) ~~ map snd params);
       
    35         val ts = map (curry subst_bounds (rev vars))
       
    36           (List.drop (Logic.strip_assums_hyp t, arity));
       
    37         val us = Logic.strip_imp_prems u;
       
    38         val tab = fold (Pattern.first_order_match thy) (ts ~~ us)
       
    39           (Vartab.empty, Vartab.empty);
       
    40       in
       
    41         map (Envir.subst_vars tab) vars
       
    42       end
       
    43   in
       
    44     map (mtch o apsnd prop_of) (cases ~~ intros)
       
    45   end;
       
    46 
       
    47 (* read off arities of inductive predicates from raw induction rule *)
       
    48 fun arities_of induct =
       
    49   map (fn (_ $ t $ u) =>
       
    50       (fst (dest_Const (head_of t)), length (snd (strip_comb u))))
       
    51     (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
       
    52 
       
    53 (* read off parameters of inductive predicate from raw induction rule *)
       
    54 fun params_of induct =
       
    55   let
       
    56     val (_ $ t $ u :: _) =
       
    57       HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct));
       
    58     val (_, ts) = strip_comb t;
       
    59     val (_, us) = strip_comb u
       
    60   in
       
    61     List.take (ts, length ts - length us)
       
    62   end;
       
    63 
    23 
    64 val all_simps = map (symmetric o mk_meta_eq) (thms "HOL.all_simps");
    24 val all_simps = map (symmetric o mk_meta_eq) (thms "HOL.all_simps");
    65 
    25 
    66 fun prf_of thm =
    26 fun prf_of thm =
    67   let val {thy, prop, der = (_, prf), ...} = rep_thm thm
    27   let val {thy, prop, der = (_, prf), ...} = rep_thm thm
   309       foldr (uncurry lambda) rt vs1,
   269       foldr (uncurry lambda) rt vs1,
   310     ProofRewriteRules.un_hhf_proof rlz' rlz''
   270     ProofRewriteRules.un_hhf_proof rlz' rlz''
   311       (foldr forall_intr_prf (prf_of rrule) (vs2 @ rs))))
   271       (foldr forall_intr_prf (prf_of rrule) (vs2 @ rs))))
   312   end;
   272   end;
   313 
   273 
   314 fun partition_rules induct intrs =
       
   315   let
       
   316     fun name_of t = fst (dest_Const (head_of t));
       
   317     val ts = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct));
       
   318     val sets = map (name_of o fst o HOLogic.dest_imp) ts;
       
   319   in
       
   320     map (fn s => (s, filter
       
   321       (equal s o name_of o HOLogic.dest_Trueprop o concl_of) intrs)) sets
       
   322   end;
       
   323 
       
   324 fun add_ind_realizer rsets intrs induct raw_induct elims (thy, vs) =
   274 fun add_ind_realizer rsets intrs induct raw_induct elims (thy, vs) =
   325   let
   275   let
   326     val qualifier = NameSpace.qualifier (name_of_thm induct);
   276     val qualifier = NameSpace.qualifier (name_of_thm induct);
   327     val inducts = PureThy.get_thms thy (Name
   277     val inducts = PureThy.get_thms thy (Name
   328       (NameSpace.qualified qualifier "inducts"));
   278       (NameSpace.qualified qualifier "inducts"));
   329     val iTs = term_tvars (prop_of (hd intrs));
   279     val iTs = term_tvars (prop_of (hd intrs));
   330     val ar = length vs + length iTs;
   280     val ar = length vs + length iTs;
   331     val params = params_of raw_induct;
   281     val params = InductivePackage.params_of raw_induct;
   332     val arities = arities_of raw_induct;
   282     val arities = InductivePackage.arities_of raw_induct;
   333     val nparms = length params;
   283     val nparms = length params;
   334     val params' = map dest_Var params;
   284     val params' = map dest_Var params;
   335     val rss = partition_rules raw_induct intrs;
   285     val rss = InductivePackage.partition_rules raw_induct intrs;
   336     val rss' = map (fn (((s, rs), (_, arity)), elim) =>
   286     val rss' = map (fn (((s, rs), (_, arity)), elim) =>
   337       (s, (infer_intro_vars elim arity rs ~~ rs))) (rss ~~ arities ~~ elims);
   287       (s, (InductivePackage.infer_intro_vars elim arity rs ~~ rs)))
       
   288         (rss ~~ arities ~~ elims);
   338     val (prfx, _) = split_last (NameSpace.explode (fst (hd rss)));
   289     val (prfx, _) = split_last (NameSpace.explode (fst (hd rss)));
   339     val tnames = map (fn s => space_implode "_" (s ^ "T" :: vs)) rsets;
   290     val tnames = map (fn s => space_implode "_" (s ^ "T" :: vs)) rsets;
   340 
   291 
   341     val thy1 = thy |>
   292     val thy1 = thy |>
   342       Theory.root_path |>
   293       Theory.root_path |>