src/HOL/Library/Code_Abstract_Nat.thy
author haftmann
Mon Jun 05 15:59:41 2017 +0200 (2017-06-05)
changeset 66010 2f7d39285a1a
parent 60801 7664e0916eec
child 69216 1a52baa70aed
permissions -rw-r--r--
executable domain membership checks
     1 (*  Title:      HOL/Library/Code_Abstract_Nat.thy
     2     Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
     3 *)
     4 
     5 section \<open>Avoidance of pattern matching on natural numbers\<close>
     6 
     7 theory Code_Abstract_Nat
     8 imports Main
     9 begin
    10 
    11 text \<open>
    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 \<close>
    18 
    19 subsection \<open>Case analysis\<close>
    20 
    21 text \<open>
    22   Case analysis on natural numbers is rephrased using a conditional
    23   expression:
    24 \<close>
    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 \<open>Preprocessors\<close>
    32 
    33 text \<open>
    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 \<close>
    40 
    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)
    46 
    47 text \<open>
    48   The rule above is built into a preprocessor that is plugged into
    49   the code generator.
    50 \<close>
    51 
    52 setup \<open>
    53 let
    54 
    55 val Suc_if_eq = Thm.incr_indexes 1 @{thm Suc_if_eq};
    56 
    57 fun remove_suc ctxt thms =
    58   let
    59     val vname = singleton (Name.variant_list (map fst
    60       (fold (Term.add_var_names o Thm.full_prop_of) thms []))) "n";
    61     val cv = Thm.cterm_of ctxt (Var ((vname, 0), HOLogic.natT));
    62     val lhs_of = snd o Thm.dest_comb o fst o Thm.dest_comb o Thm.cprop_of;
    63     val rhs_of = snd o Thm.dest_comb o Thm.cprop_of;
    64     fun find_vars ct = (case Thm.term_of ct of
    65         (Const (@{const_name Suc}, _) $ Var _) => [(cv, snd (Thm.dest_comb ct))]
    66       | _ $ _ =>
    67         let val (ct1, ct2) = Thm.dest_comb ct
    68         in 
    69           map (apfst (fn ct => Thm.apply ct ct2)) (find_vars ct1) @
    70           map (apfst (Thm.apply ct1)) (find_vars ct2)
    71         end
    72       | _ => []);
    73     val eqs = maps
    74       (fn thm => map (pair thm) (find_vars (lhs_of thm))) thms;
    75     fun mk_thms (thm, (ct, cv')) =
    76       let
    77         val thm' =
    78           Thm.implies_elim
    79            (Conv.fconv_rule (Thm.beta_conversion true)
    80              (Thm.instantiate'
    81                [SOME (Thm.ctyp_of_cterm ct)] [SOME (Thm.lambda cv ct),
    82                  SOME (Thm.lambda cv' (rhs_of thm)), NONE, SOME cv']
    83                Suc_if_eq)) (Thm.forall_intr cv' thm)
    84       in
    85         case map_filter (fn thm'' =>
    86             SOME (thm'', singleton
    87               (Variable.trade (K (fn [thm'''] => [thm''' RS thm']))
    88                 (Variable.declare_thm thm'' ctxt)) thm'')
    89           handle THM _ => NONE) thms of
    90             [] => NONE
    91           | thmps =>
    92               let val (thms1, thms2) = split_list thmps
    93               in SOME (subtract Thm.eq_thm (thm :: thms1) thms @ thms2) end
    94       end
    95   in get_first mk_thms eqs end;
    96 
    97 fun eqn_suc_base_preproc ctxt thms =
    98   let
    99     val dest = fst o Logic.dest_equals o Thm.prop_of;
   100     val contains_suc = exists_Const (fn (c, _) => c = @{const_name Suc});
   101   in
   102     if forall (can dest) thms andalso exists (contains_suc o dest) thms
   103       then thms |> perhaps_loop (remove_suc ctxt) |> (Option.map o map) Drule.zero_var_indexes
   104        else NONE
   105   end;
   106 
   107 val eqn_suc_preproc = Code_Preproc.simple_functrans eqn_suc_base_preproc;
   108 
   109 in
   110 
   111   Code_Preproc.add_functrans ("eqn_Suc", eqn_suc_preproc)
   112 
   113 end;
   114 \<close>
   115 
   116 end