26 fixes term_of :: "'a \<Rightarrow> term" |
26 fixes term_of :: "'a \<Rightarrow> term" |
27 |
27 |
28 lemma term_of_anything: "term_of x \<equiv> t" |
28 lemma term_of_anything: "term_of x \<equiv> t" |
29 by (rule eq_reflection) (cases "term_of x", cases t, simp) |
29 by (rule eq_reflection) (cases "term_of x", cases t, simp) |
30 |
30 |
31 definition app :: "('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term) |
31 definition valapp :: "('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term) |
32 \<Rightarrow> 'a \<times> (unit \<Rightarrow> term) \<Rightarrow> 'b \<times> (unit \<Rightarrow> term)" where |
32 \<Rightarrow> 'a \<times> (unit \<Rightarrow> term) \<Rightarrow> 'b \<times> (unit \<Rightarrow> term)" where |
33 "app f x = (fst f (fst x), \<lambda>u. Code_Eval.App (snd f ()) (snd x ()))" |
33 "valapp f x = (fst f (fst x), \<lambda>u. App (snd f ()) (snd x ()))" |
34 |
34 |
35 lemma app_code [code, code inline]: |
35 lemma valapp_code [code, code inline]: |
36 "app (f, tf) (x, tx) = (f x, \<lambda>u. Code_Eval.App (tf ()) (tx ()))" |
36 "valapp (f, tf) (x, tx) = (f x, \<lambda>u. App (tf ()) (tx ()))" |
37 by (simp only: app_def fst_conv snd_conv) |
37 by (simp only: valapp_def fst_conv snd_conv) |
38 |
38 |
39 |
39 |
40 subsubsection {* @{text term_of} instances *} |
40 subsubsection {* @{text term_of} instances *} |
41 |
41 |
42 setup {* |
42 setup {* |
143 code_reserved Eval HOLogic |
143 code_reserved Eval HOLogic |
144 |
144 |
145 |
145 |
146 subsubsection {* Syntax *} |
146 subsubsection {* Syntax *} |
147 |
147 |
148 definition termify :: "'a \<Rightarrow> 'a \<times> (unit \<Rightarrow> term)" where |
148 definition termify :: "'a \<Rightarrow> term" where |
149 [code del]: "termify x = (x, \<lambda>u. dummy_term)" |
149 [code del]: "termify x = dummy_term" |
|
150 |
|
151 abbreviation valtermify :: "'a \<Rightarrow> 'a \<times> (unit \<Rightarrow> term)" where |
|
152 "valtermify x \<equiv> (x, \<lambda>u. termify x)" |
150 |
153 |
151 setup {* |
154 setup {* |
152 let |
155 let |
153 fun map_default f xs = |
156 fun map_default f xs = |
154 let val ys = map f xs |
157 let val ys = map f xs |
157 else NONE |
160 else NONE |
158 end; |
161 end; |
159 fun subst_termify_app (Const (@{const_name termify}, T), [t]) = |
162 fun subst_termify_app (Const (@{const_name termify}, T), [t]) = |
160 if not (Term.has_abs t) |
163 if not (Term.has_abs t) |
161 then if fold_aterms (fn Const _ => I | _ => K false) t true |
164 then if fold_aterms (fn Const _ => I | _ => K false) t true |
162 then SOME (HOLogic.mk_prod |
165 then SOME (HOLogic.reflect_term t) |
163 (t, Abs ("u", HOLogic.unitT, HOLogic.reflect_term t))) |
|
164 else error "Cannot termify expression containing variables" |
166 else error "Cannot termify expression containing variables" |
165 else error "Cannot termify expression containing abstraction" |
167 else error "Cannot termify expression containing abstraction" |
166 | subst_termify_app (t, ts) = case map_default subst_termify ts |
168 | subst_termify_app (t, ts) = case map_default subst_termify ts |
167 of SOME ts' => SOME (list_comb (t, ts')) |
169 of SOME ts' => SOME (list_comb (t, ts')) |
168 | NONE => NONE |
170 | NONE => NONE |
178 *} |
180 *} |
179 |
181 |
180 locale term_syntax |
182 locale term_syntax |
181 begin |
183 begin |
182 |
184 |
183 notation app (infixl "<\<cdot>>" 70) and termify ("termify") |
185 notation App (infixl "<\<cdot>>" 70) |
|
186 and valapp (infixl "{\<cdot>}" 70) |
184 |
187 |
185 end |
188 end |
186 |
189 |
187 interpretation term_syntax . |
190 interpretation term_syntax . |
188 |
191 |
189 no_notation app (infixl "<\<cdot>>" 70) and termify ("termify") |
192 no_notation App (infixl "<\<cdot>>" 70) |
|
193 and valapp (infixl "{\<cdot>}" 70) |
|
194 |
|
195 |
|
196 subsection {* Numeric types *} |
|
197 |
|
198 definition term_of_num :: "'a\<Colon>{semiring_div} \<Rightarrow> 'a\<Colon>{semiring_div} \<Rightarrow> term" where |
|
199 "term_of_num two = (\<lambda>_. dummy_term)" |
|
200 |
|
201 lemma (in term_syntax) term_of_num_code [code]: |
|
202 "term_of_num two k = (if k = 0 then termify Int.Pls |
|
203 else (if k mod two = 0 |
|
204 then termify Int.Bit0 <\<cdot>> term_of_num two (k div two) |
|
205 else termify Int.Bit1 <\<cdot>> term_of_num two (k div two)))" |
|
206 by (auto simp add: term_of_anything Const_def App_def term_of_num_def Let_def) |
|
207 |
|
208 lemma (in term_syntax) term_of_nat_code [code]: |
|
209 "term_of (n::nat) = termify (number_of :: int \<Rightarrow> nat) <\<cdot>> term_of_num (2::nat) n" |
|
210 by (simp only: term_of_anything) |
|
211 |
|
212 lemma (in term_syntax) term_of_int_code [code]: |
|
213 "term_of (k::int) = (if k = 0 then termify (0 :: int) |
|
214 else if k > 0 then termify (number_of :: int \<Rightarrow> int) <\<cdot>> term_of_num (2::int) k |
|
215 else termify (uminus :: int \<Rightarrow> int) <\<cdot>> (termify (number_of :: int \<Rightarrow> int) <\<cdot>> term_of_num (2::int) (- k)))" |
|
216 by (simp only: term_of_anything) |
|
217 |
|
218 |
|
219 subsection {* Obfuscate *} |
190 |
220 |
191 print_translation {* |
221 print_translation {* |
192 let |
222 let |
193 val term = Const ("<TERM>", dummyT); |
223 val term = Const ("<TERM>", dummyT); |
194 fun tr1' [_, _] = term; |
224 fun tr1' [_, _] = term; |
198 (@{const_syntax App}, tr1'), |
228 (@{const_syntax App}, tr1'), |
199 (@{const_syntax dummy_term}, tr2')] |
229 (@{const_syntax dummy_term}, tr2')] |
200 end |
230 end |
201 *} |
231 *} |
202 |
232 |
203 hide const dummy_term termify app |
233 hide const dummy_term App valapp |
204 hide (open) const Const App term_of |
234 hide (open) const Const termify valtermify term_of term_of_num |
205 |
|
206 |
235 |
207 |
236 |
208 subsection {* Evaluation setup *} |
237 subsection {* Evaluation setup *} |
209 |
238 |
210 ML {* |
239 ML {* |