src/HOL/Library/Code_Abstract_Nat.thy
author haftmann
Wed Feb 26 11:57:52 2014 +0100 (2014-02-26)
changeset 55757 9fc71814b8c1
parent 55415 05f5fdb8d093
child 56790 f54097170704
permissions -rw-r--r--
prefer proof context over background theory
     1 (*  Title:      HOL/Library/Code_Abstract_Nat.thy
     2     Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
     3 *)
     4 
     5 header {* Avoidance of pattern matching on natural numbers *}
     6 
     7 theory Code_Abstract_Nat
     8 imports Main
     9 begin
    10 
    11 text {*
    12   When natural numbers are implemented in another than the
    13   conventional inductive @{term "0::nat"}/@{term Suc} representation,
    14   it is necessary to avoid all pattern matching on natural numbers
    15   altogether.  This is accomplished by this theory (up to a certain
    16   extent).
    17 *}
    18 
    19 subsection {* Case analysis *}
    20 
    21 text {*
    22   Case analysis on natural numbers is rephrased using a conditional
    23   expression:
    24 *}
    25 
    26 lemma [code, code_unfold]:
    27   "case_nat = (\<lambda>f g n. if n = 0 then f else g (n - 1))"
    28   by (auto simp add: fun_eq_iff dest!: gr0_implies_Suc)
    29 
    30 
    31 subsection {* Preprocessors *}
    32 
    33 text {*
    34   The term @{term "Suc n"} is no longer a valid pattern.  Therefore,
    35   all occurrences of this term in a position where a pattern is
    36   expected (i.e.~on the left-hand side of a code equation) must be
    37   eliminated.  This can be accomplished – as far as possible – by
    38   applying the following transformation rule:
    39 *}
    40 
    41 lemma Suc_if_eq: "(\<And>n. f (Suc n) \<equiv> h n) \<Longrightarrow> f 0 \<equiv> g \<Longrightarrow>
    42   f n \<equiv> if n = 0 then g else h (n - 1)"
    43   by (rule eq_reflection) (cases n, simp_all)
    44 
    45 text {*
    46   The rule above is built into a preprocessor that is plugged into
    47   the code generator.
    48 *}
    49 
    50 setup {*
    51 let
    52 
    53 fun remove_suc ctxt thms =
    54   let
    55     val thy = Proof_Context.theory_of ctxt;
    56     val vname = singleton (Name.variant_list (map fst
    57       (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
    58     val cv = cterm_of thy (Var ((vname, 0), HOLogic.natT));
    59     fun lhs_of th = snd (Thm.dest_comb
    60       (fst (Thm.dest_comb (cprop_of th))));
    61     fun rhs_of th = snd (Thm.dest_comb (cprop_of th));
    62     fun find_vars ct = (case term_of ct of
    63         (Const (@{const_name Suc}, _) $ Var _) => [(cv, snd (Thm.dest_comb ct))]
    64       | _ $ _ =>
    65         let val (ct1, ct2) = Thm.dest_comb ct
    66         in 
    67           map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
    68           map (apfst (Thm.apply ct1)) (find_vars ct2)
    69         end
    70       | _ => []);
    71     val eqs = maps
    72       (fn th => map (pair th) (find_vars (lhs_of th))) thms;
    73     fun mk_thms (th, (ct, cv')) =
    74       let
    75         val th' =
    76           Thm.implies_elim
    77            (Conv.fconv_rule (Thm.beta_conversion true)
    78              (Drule.instantiate'
    79                [SOME (ctyp_of_term ct)] [SOME (Thm.lambda cv ct),
    80                  SOME (Thm.lambda cv' (rhs_of th)), NONE, SOME cv']
    81                @{thm Suc_if_eq})) (Thm.forall_intr cv' th)
    82       in
    83         case map_filter (fn th'' =>
    84             SOME (th'', singleton
    85               (Variable.trade (K (fn [th'''] => [th''' RS th']))
    86                 (Variable.global_thm_context th'')) th'')
    87           handle THM _ => NONE) thms of
    88             [] => NONE
    89           | thps =>
    90               let val (ths1, ths2) = split_list thps
    91               in SOME (subtract Thm.eq_thm (th :: ths1) thms @ ths2) end
    92       end
    93   in get_first mk_thms eqs end;
    94 
    95 fun eqn_suc_base_preproc thy thms =
    96   let
    97     val dest = fst o Logic.dest_equals o prop_of;
    98     val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
    99   in
   100     if forall (can dest) thms andalso exists (contains_suc o dest) thms
   101       then thms |> perhaps_loop (remove_suc thy) |> (Option.map o map) Drule.zero_var_indexes
   102        else NONE
   103   end;
   104 
   105 val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
   106 
   107 in
   108 
   109   Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
   110 
   111 end;
   112 *}
   113 
   114 end