src/HOL/Library/Code_Abstract_Nat.thy
 author wenzelm Wed Mar 04 19:53:18 2015 +0100 (2015-03-04) changeset 59582 0fbed69ff081 parent 59169 ddc948e4ed09 child 59586 ddf6deaadfe8 permissions -rw-r--r--
tuned signature -- prefer qualified names;
1 (*  Title:      HOL/Library/Code_Abstract_Nat.thy
2     Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
3 *)
5 section {* Avoidance of pattern matching on natural numbers *}
7 theory Code_Abstract_Nat
8 imports Main
9 begin
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 *}
19 subsection {* Case analysis *}
21 text {*
22   Case analysis on natural numbers is rephrased using a conditional
23   expression:
24 *}
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)
31 subsection {* Preprocessors *}
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 *}
41 lemma Suc_if_eq:
42   assumes "\<And>n. f (Suc n) \<equiv> h n"
43   assumes "f 0 \<equiv> g"
44   shows "f n \<equiv> if n = 0 then g else h (n - 1)"
45   by (rule eq_reflection) (cases n, insert assms, simp_all)
47 text {*
48   The rule above is built into a preprocessor that is plugged into
49   the code generator.
50 *}
52 setup {*
53 let
55 val Suc_if_eq = Thm.incr_indexes 1 @{thm Suc_if_eq};
57 fun remove_suc ctxt thms =
58   let
59     val thy = Proof_Context.theory_of ctxt;
60     val vname = singleton (Name.variant_list (map fst
61       (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
62     val cv = Thm.cterm_of thy (Var ((vname, 0), HOLogic.natT));
63     val lhs_of = snd o Thm.dest_comb o fst o Thm.dest_comb o Thm.cprop_of;
64     val rhs_of = snd o Thm.dest_comb o Thm.cprop_of;
65     fun find_vars ct = (case Thm.term_of ct of
66         (Const (@{const_name Suc}, _) \$ Var _) => [(cv, snd (Thm.dest_comb ct))]
67       | _ \$ _ =>
68         let val (ct1, ct2) = Thm.dest_comb ct
69         in
70           map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
71           map (apfst (Thm.apply ct1)) (find_vars ct2)
72         end
73       | _ => []);
74     val eqs = maps
75       (fn thm => map (pair thm) (find_vars (lhs_of thm))) thms;
76     fun mk_thms (thm, (ct, cv')) =
77       let
78         val thm' =
79           Thm.implies_elim
80            (Conv.fconv_rule (Thm.beta_conversion true)
81              (Drule.instantiate'
82                [SOME (Thm.ctyp_of_term ct)] [SOME (Thm.lambda cv ct),
83                  SOME (Thm.lambda cv' (rhs_of thm)), NONE, SOME cv']
84                Suc_if_eq)) (Thm.forall_intr cv' thm)
85       in
86         case map_filter (fn thm'' =>
87             SOME (thm'', singleton
88               (Variable.trade (K (fn [thm'''] => [thm''' RS thm']))
89                 (Variable.declare_thm thm'' ctxt)) thm'')
90           handle THM _ => NONE) thms of
91             [] => NONE
92           | thmps =>
93               let val (thms1, thms2) = split_list thmps
94               in SOME (subtract Thm.eq_thm (thm :: thms1) thms @ thms2) end
95       end
96   in get_first mk_thms eqs end;
98 fun eqn_suc_base_preproc ctxt thms =
99   let
100     val dest = fst o Logic.dest_equals o Thm.prop_of;
101     val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
102   in
103     if forall (can dest) thms andalso exists (contains_suc o dest) thms
104       then thms |> perhaps_loop (remove_suc ctxt) |> (Option.map o map) Drule.zero_var_indexes
105        else NONE
106   end;
108 val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
110 in
112   Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
114 end;
115 *}
117 end