src/Tools/induct.ML
changeset 37525 a5ac274798fc
parent 37524 a9e38cdbfe07
child 38715 6513ea67d95d
equal deleted inserted replaced
37524:a9e38cdbfe07 37525:a5ac274798fc
   116 fun swap_params_conv ctxt i j cv =
   116 fun swap_params_conv ctxt i j cv =
   117   let
   117   let
   118     fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt
   118     fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt
   119       | conv1 k ctxt =
   119       | conv1 k ctxt =
   120           Conv.rewr_conv @{thm swap_params} then_conv
   120           Conv.rewr_conv @{thm swap_params} then_conv
   121           Conv.forall_conv (conv1 (k-1) o snd) ctxt
   121           Conv.forall_conv (conv1 (k - 1) o snd) ctxt
   122     fun conv2 0 ctxt = conv1 j ctxt
   122     fun conv2 0 ctxt = conv1 j ctxt
   123       | conv2 k ctxt = Conv.forall_conv (conv2 (k-1) o snd) ctxt
   123       | conv2 k ctxt = Conv.forall_conv (conv2 (k - 1) o snd) ctxt
   124   in conv2 i ctxt end;
   124   in conv2 i ctxt end;
   125 
   125 
   126 fun swap_prems_conv 0 = Conv.all_conv
   126 fun swap_prems_conv 0 = Conv.all_conv
   127   | swap_prems_conv i =
   127   | swap_prems_conv i =
   128       Conv.implies_concl_conv (swap_prems_conv (i-1)) then_conv
   128       Conv.implies_concl_conv (swap_prems_conv (i - 1)) then_conv
   129       Conv.rewr_conv Drule.swap_prems_eq
   129       Conv.rewr_conv Drule.swap_prems_eq
   130 
   130 
   131 fun drop_judgment ctxt = Object_Logic.drop_judgment (ProofContext.theory_of ctxt);
   131 fun drop_judgment ctxt = Object_Logic.drop_judgment (ProofContext.theory_of ctxt);
   132 
   132 
   133 fun find_eq ctxt t =
   133 fun find_eq ctxt t =
   134   let
   134   let
   135     val l = length (Logic.strip_params t);
   135     val l = length (Logic.strip_params t);
   136     val Hs = Logic.strip_assums_hyp t;
   136     val Hs = Logic.strip_assums_hyp t;
   137     fun find (i, t) =
   137     fun find (i, t) =
   138       case Induct_Args.dest_def (drop_judgment ctxt t) of
   138       (case Induct_Args.dest_def (drop_judgment ctxt t) of
   139         SOME (Bound j, _) => SOME (i, j)
   139         SOME (Bound j, _) => SOME (i, j)
   140       | SOME (_, Bound j) => SOME (i, j)
   140       | SOME (_, Bound j) => SOME (i, j)
   141       | _ => NONE
   141       | _ => NONE);
   142   in
   142   in
   143     case get_first find (map_index I Hs) of
   143     (case get_first find (map_index I Hs) of
   144       NONE => NONE
   144       NONE => NONE
   145     | SOME (0, 0) => NONE
   145     | SOME (0, 0) => NONE
   146     | SOME (i, j) => SOME (i, l-j-1, j)
   146     | SOME (i, j) => SOME (i, l - j - 1, j))
   147   end;
   147   end;
   148 
   148 
   149 fun mk_swap_rrule ctxt ct = case find_eq ctxt (term_of ct) of
   149 fun mk_swap_rrule ctxt ct =
       
   150   (case find_eq ctxt (term_of ct) of
   150     NONE => NONE
   151     NONE => NONE
   151   | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct);
   152   | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct));
   152 
   153 
   153 val rearrange_eqs_simproc = Simplifier.simproc
   154 val rearrange_eqs_simproc =
   154   (Thm.theory_of_thm Drule.swap_prems_eq) "rearrange_eqs" ["all t"]
   155   Simplifier.simproc
   155   (fn thy => fn ss => fn t =>
   156     (Thm.theory_of_thm Drule.swap_prems_eq) "rearrange_eqs" ["all t"]
   156      mk_swap_rrule (Simplifier.the_context ss) (cterm_of thy t))
   157     (fn thy => fn ss => fn t =>
       
   158       mk_swap_rrule (Simplifier.the_context ss) (cterm_of thy t));
       
   159 
   157 
   160 
   158 (* rotate k premises to the left by j, skipping over first j premises *)
   161 (* rotate k premises to the left by j, skipping over first j premises *)
   159 
   162 
   160 fun rotate_conv 0 j 0 = Conv.all_conv
   163 fun rotate_conv 0 j 0 = Conv.all_conv
   161   | rotate_conv 0 j k = swap_prems_conv j then_conv rotate_conv 1 j (k-1)
   164   | rotate_conv 0 j k = swap_prems_conv j then_conv rotate_conv 1 j (k - 1)
   162   | rotate_conv i j k = Conv.implies_concl_conv (rotate_conv (i-1) j k);
   165   | rotate_conv i j k = Conv.implies_concl_conv (rotate_conv (i - 1) j k);
   163 
   166 
   164 fun rotate_tac j 0 = K all_tac
   167 fun rotate_tac j 0 = K all_tac
   165   | rotate_tac j k = SUBGOAL (fn (goal, i) => CONVERSION (rotate_conv
   168   | rotate_tac j k = SUBGOAL (fn (goal, i) =>
   166       j (length (Logic.strip_assums_hyp goal) - j - k) k) i);
   169       CONVERSION (rotate_conv
       
   170         j (length (Logic.strip_assums_hyp goal) - j - k) k) i);
       
   171 
   167 
   172 
   168 (* rulify operators around definition *)
   173 (* rulify operators around definition *)
   169 
   174 
   170 fun rulify_defs_conv ctxt ct =
   175 fun rulify_defs_conv ctxt ct =
   171   if exists_subterm (is_some o Induct_Args.dest_def) (term_of ct) andalso
   176   if exists_subterm (is_some o Induct_Args.dest_def) (term_of ct) andalso
   276 local
   281 local
   277 
   282 
   278 fun mk_att f g name arg =
   283 fun mk_att f g name arg =
   279   let val (x, thm) = g arg in (Data.map (f (name, thm)) x, thm) end;
   284   let val (x, thm) = g arg in (Data.map (f (name, thm)) x, thm) end;
   280 
   285 
   281 fun del_att which = Thm.declaration_attribute (fn th => Data.map (which (pairself (fn rs =>
   286 fun del_att which =
   282   fold Item_Net.remove (filter_rules rs th) rs))));
   287   Thm.declaration_attribute (fn th => Data.map (which (pairself (fn rs =>
       
   288     fold Item_Net.remove (filter_rules rs th) rs))));
   283 
   289 
   284 fun map1 f (x, y, z, s) = (f x, y, z, s);
   290 fun map1 f (x, y, z, s) = (f x, y, z, s);
   285 fun map2 f (x, y, z, s) = (x, f y, z, s);
   291 fun map2 f (x, y, z, s) = (x, f y, z, s);
   286 fun map3 f (x, y, z, s) = (x, y, f z, s);
   292 fun map3 f (x, y, z, s) = (x, y, f z, s);
   287 fun map4 f (x, y, z, s) = (x, y, z, f s);
   293 fun map4 f (x, y, z, s) = (x, y, z, f s);
   312 
   318 
   313 fun map_simpset f = Data.map (map4 f);
   319 fun map_simpset f = Data.map (map4 f);
   314 
   320 
   315 fun induct_simp f =
   321 fun induct_simp f =
   316   Thm.declaration_attribute (fn thm => fn context =>
   322   Thm.declaration_attribute (fn thm => fn context =>
   317       (map_simpset
   323       map_simpset
   318         (Simplifier.with_context (Context.proof_of context) (fn ss => f (ss, [thm]))) context));
   324         (Simplifier.with_context (Context.proof_of context) (fn ss => f (ss, [thm]))) context);
   319 
   325 
   320 val induct_simp_add = induct_simp (op addsimps);
   326 val induct_simp_add = induct_simp (op addsimps);
   321 val induct_simp_del = induct_simp (op delsimps);
   327 val induct_simp_del = induct_simp (op delsimps);
   322 
   328 
   323 end;
   329 end;
   416   (Conv.prems_conv (~1) (Conv.params_conv ~1 (K (Conv.prems_conv n
   422   (Conv.prems_conv (~1) (Conv.params_conv ~1 (K (Conv.prems_conv n
   417      (MetaSimplifier.rewrite false [equal_def']))) ctxt));
   423      (MetaSimplifier.rewrite false [equal_def']))) ctxt));
   418 
   424 
   419 val unmark_constraints = Conv.fconv_rule
   425 val unmark_constraints = Conv.fconv_rule
   420   (MetaSimplifier.rewrite true [Induct_Args.equal_def]);
   426   (MetaSimplifier.rewrite true [Induct_Args.equal_def]);
       
   427 
   421 
   428 
   422 (* simplify *)
   429 (* simplify *)
   423 
   430 
   424 fun simplify_conv' ctxt =
   431 fun simplify_conv' ctxt =
   425   Simplifier.full_rewrite (Simplifier.context ctxt (#4 (get_local ctxt)));
   432   Simplifier.full_rewrite (Simplifier.context ctxt (#4 (get_local ctxt)));