haftmann@31771
|
1 |
(* Title: HOL/Tools/Function/sum_tree.ML
|
krauss@25555
|
2 |
Author: Alexander Krauss, TU Muenchen
|
krauss@25555
|
3 |
|
krauss@25555
|
4 |
Some common tools for working with sum types in balanced tree form.
|
krauss@25555
|
5 |
*)
|
krauss@25555
|
6 |
|
krauss@25555
|
7 |
structure SumTree =
|
krauss@25555
|
8 |
struct
|
krauss@25555
|
9 |
|
krauss@25555
|
10 |
(* Theory dependencies *)
|
krauss@34232
|
11 |
val sumcase_split_ss =
|
krauss@34232
|
12 |
HOL_basic_ss addsimps (@{thm Product_Type.split} :: @{thms sum.cases})
|
krauss@25555
|
13 |
|
krauss@25555
|
14 |
(* top-down access in balanced tree *)
|
krauss@25555
|
15 |
fun access_top_down {left, right, init} len i =
|
krauss@34232
|
16 |
Balanced_Tree.access
|
krauss@34232
|
17 |
{left = (fn f => f o left), right = (fn f => f o right), init = I} len i init
|
krauss@25555
|
18 |
|
krauss@25555
|
19 |
(* Sum types *)
|
haftmann@37678
|
20 |
fun mk_sumT LT RT = Type (@{type_name Sum_Type.sum}, [LT, RT])
|
krauss@34232
|
21 |
fun mk_sumcase TL TR T l r =
|
krauss@34232
|
22 |
Const (@{const_name sum.sum_case},
|
krauss@34232
|
23 |
(TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
|
krauss@25555
|
24 |
|
krauss@25555
|
25 |
val App = curry op $
|
krauss@25555
|
26 |
|
krauss@34232
|
27 |
fun mk_inj ST n i =
|
krauss@34232
|
28 |
access_top_down
|
krauss@34232
|
29 |
{ init = (ST, I : term -> term),
|
haftmann@37678
|
30 |
left = (fn (T as Type (@{type_name Sum_Type.sum}, [LT, RT]), inj) =>
|
krauss@34232
|
31 |
(LT, inj o App (Const (@{const_name Inl}, LT --> T)))),
|
haftmann@37678
|
32 |
right =(fn (T as Type (@{type_name Sum_Type.sum}, [LT, RT]), inj) =>
|
krauss@34232
|
33 |
(RT, inj o App (Const (@{const_name Inr}, RT --> T))))} n i
|
krauss@34232
|
34 |
|> snd
|
krauss@25555
|
35 |
|
krauss@34232
|
36 |
fun mk_proj ST n i =
|
krauss@34232
|
37 |
access_top_down
|
krauss@34232
|
38 |
{ init = (ST, I : term -> term),
|
haftmann@37678
|
39 |
left = (fn (T as Type (@{type_name Sum_Type.sum}, [LT, RT]), proj) =>
|
krauss@34232
|
40 |
(LT, App (Const (@{const_name Sum_Type.Projl}, T --> LT)) o proj)),
|
haftmann@37678
|
41 |
right =(fn (T as Type (@{type_name Sum_Type.sum}, [LT, RT]), proj) =>
|
krauss@34232
|
42 |
(RT, App (Const (@{const_name Sum_Type.Projr}, T --> RT)) o proj))} n i
|
krauss@34232
|
43 |
|> snd
|
krauss@25555
|
44 |
|
krauss@25555
|
45 |
fun mk_sumcases T fs =
|
krauss@34232
|
46 |
Balanced_Tree.make (fn ((f, fT), (g, gT)) => (mk_sumcase fT gT T f g, mk_sumT fT gT))
|
krauss@34232
|
47 |
(map (fn f => (f, domain_type (fastype_of f))) fs)
|
krauss@34232
|
48 |
|> fst
|
krauss@25555
|
49 |
|
krauss@25555
|
50 |
end
|