90 |
90 |
91 (* tactics *) |
91 (* tactics *) |
92 |
92 |
93 fun simp_all_tac ss simps = ALLGOALS (Simplifier.asm_full_simp_tac (ss addsimps simps)); |
93 fun simp_all_tac ss simps = ALLGOALS (Simplifier.asm_full_simp_tac (ss addsimps simps)); |
94 |
94 |
95 fun try_param_tac x s rule i st = |
95 (* do case analysis / induction on last parameter of ith subgoal (or s) *) |
96 res_inst_tac [(x, (case Tactic.innermost_params i st of [] => s | (p, _) :: _ => p))] rule i st; |
96 |
|
97 fun try_param_tac s rule i st = |
|
98 let |
|
99 val cert = cterm_of (#sign (rep_thm st)); |
|
100 val g = nth_elem (i - 1, prems_of st); |
|
101 val params = Logic.strip_params g; |
|
102 val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl g); |
|
103 val rule' = Thm.lift_rule (st, i) rule; |
|
104 val (P, ys) = strip_comb (HOLogic.dest_Trueprop |
|
105 (Logic.strip_assums_concl (prop_of rule'))); |
|
106 val (x, ca) = (case rev (drop (length params, ys)) of |
|
107 [] => (head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop |
|
108 (hd (rev (Logic.strip_assums_hyp (hd (prems_of rule')))))))), true) |
|
109 | [x] => (head_of x, false)); |
|
110 val rule'' = cterm_instantiate (map (pairself cert) (case (rev params) of |
|
111 [] => (case assoc (map dest_Free (term_frees (prop_of st)), s) of |
|
112 None => sys_error "try_param_tac: no such variable" |
|
113 | Some T => [(P, if ca then concl else lambda (Free (s, T)) concl), |
|
114 (x, Free (s, T))]) |
|
115 | (_, T) :: _ => [(P, list_abs (params, if ca then concl |
|
116 else incr_boundvars 1 (Abs (s, T, concl)))), |
|
117 (x, list_abs (params, Bound 0))])) rule' |
|
118 in compose_tac (false, rule'', nprems_of rule) i st end; |
97 |
119 |
98 |
120 |
99 |
121 |
100 (*** code generator data ***) |
122 (*** code generator data ***) |
101 |
123 |
857 val update_convs = map (prove_simp (parent_simps @ update_defs @ sel_convs)) update_props; |
879 val update_convs = map (prove_simp (parent_simps @ update_defs @ sel_convs)) update_props; |
858 |
880 |
859 fun induct_scheme n = |
881 fun induct_scheme n = |
860 let val (assm, concl) = induct_scheme_prop n in |
882 let val (assm, concl) = induct_scheme_prop n in |
861 prove_standard [] [assm] concl (fn prems => |
883 prove_standard [] [assm] concl (fn prems => |
862 EVERY (map (fn rule => try_param_tac "p" rN rule 1) (prune n all_field_inducts)) |
884 EVERY (map (fn rule => try_param_tac rN rule 1) (prune n all_field_inducts)) |
863 THEN resolve_tac prems 1) |
885 THEN resolve_tac prems 1) |
864 end; |
886 end; |
865 |
887 |
866 fun cases_scheme n = |
888 fun cases_scheme n = |
867 prove_standard [] [] (cases_scheme_prop n) (fn _ => |
889 prove_standard [] [] (cases_scheme_prop n) (fn _ => |
868 EVERY (map (fn rule => try_param_tac "p" rN rule 1) (prune n all_field_cases)) |
890 EVERY (map (fn rule => try_param_tac rN rule 1) (prune n all_field_cases)) |
869 THEN simp_all_tac HOL_basic_ss []); |
891 THEN simp_all_tac HOL_basic_ss []); |
870 |
892 |
871 val induct_scheme0 = induct_scheme 0; |
893 val induct_scheme0 = induct_scheme 0; |
872 val cases_scheme0 = cases_scheme 0; |
894 val cases_scheme0 = cases_scheme 0; |
873 val more_induct_scheme = map induct_scheme ancestry; |
895 val more_induct_scheme = map induct_scheme ancestry; |
896 |
918 |
897 fun induct (n, scheme) = |
919 fun induct (n, scheme) = |
898 let val (assm, concl) = induct_prop n in |
920 let val (assm, concl) = induct_prop n in |
899 prove_standard [] [assm] concl (fn prems => |
921 prove_standard [] [assm] concl (fn prems => |
900 res_inst_tac [(rN, rN)] scheme 1 |
922 res_inst_tac [(rN, rN)] scheme 1 |
901 THEN try_param_tac "x" "more" unit_induct 1 |
923 THEN try_param_tac "more" unit_induct 1 |
902 THEN resolve_tac prems 1) |
924 THEN resolve_tac prems 1) |
903 end; |
925 end; |
904 |
926 |
905 fun cases (n, scheme) = |
927 fun cases (n, scheme) = |
906 prove_standard [] [] (cases_prop n) (fn _ => |
928 prove_standard [] [] (cases_prop n) (fn _ => |