85 |
85 |
86 datatype Univ = |
86 datatype Univ = |
87 Constr of string*(Univ list) (* Named Constructors *) |
87 Constr of string*(Univ list) (* Named Constructors *) |
88 | Var of string*(Univ list) (* Free variables *) |
88 | Var of string*(Univ list) (* Free variables *) |
89 | BVar of int*(Univ list) (* Bound named variables *) |
89 | BVar of int*(Univ list) (* Bound named variables *) |
90 | Fun of (Univ list -> Univ) * (Univ list) * int * (unit -> nterm); |
90 | Fun of (Univ list -> Univ) * (Univ list) * int; |
91 |
|
92 fun to_term (Constr(name, args)) = apps (C name) (map to_term args) |
|
93 | to_term (Var (name, args)) = apps (V name) (map to_term args) |
|
94 | to_term (BVar (name, args)) = apps (B name) (map to_term args) |
|
95 | to_term (Fun(_,args,_,name_thunk)) = apps (name_thunk ()) (map to_term args); |
|
96 |
91 |
97 (* |
92 (* |
98 A typical operation, why functions might be good for, is |
93 A typical operation, why functions might be good for, is |
99 application. Moreover, functions are the only values that can |
94 application. Moreover, functions are the only values that can |
100 reasonably we applied in a semantical way. |
95 reasonably we applied in a semantical way. |
101 *) |
96 *) |
102 |
97 |
103 fun apply (Fun(f,xs,1,name)) x = f (x::xs) |
98 fun apply (Fun(f,xs,1)) x = f (x::xs) |
104 | apply (Fun(f,xs,n,name)) x = Fun(f,x::xs,n-1,name) |
99 | apply (Fun(f,xs,n)) x = Fun(f,x::xs,n-1) |
105 | apply (Constr(name,args)) x = Constr(name,x::args) |
100 | apply (Constr(name,args)) x = Constr(name,x::args) |
106 | apply (Var(name,args)) x = Var(name,x::args) |
101 | apply (Var(name,args)) x = Var(name,x::args) |
107 | apply (BVar(name,args)) x = BVar(name,x::args); |
102 | apply (BVar(name,args)) x = BVar(name,x::args); |
108 |
103 |
109 fun mk_Fun(name,v,0) = (name,v []) |
104 fun mk_Fun(name,v,0) = (name,v []) |
110 | mk_Fun(name,v,n) = (name,Fun(v,[],n, fn () => C name)); |
105 | mk_Fun(name,v,n) = (name,Fun(v,[],n)); |
111 |
106 |
112 |
107 |
113 (* ------------------ evaluation with greetings to Tarski ------------------ *) |
108 (* ------------------ evaluation with greetings to Tarski ------------------ *) |
114 |
109 |
115 fun prep_term thy (Const c) = Const (CodegenNames.const thy |
110 fun prep_term thy (Const c) = Const (CodegenNames.const thy |
116 (CodegenConsts.const_of_cexpr thy c), dummyT) |
111 (CodegenConsts.const_of_cexpr thy c), dummyT) |
117 | prep_term thy (Free v_ty) = Free v_ty |
112 | prep_term thy (Free v_ty) = Free v_ty |
118 | prep_term thy (s $ t) = prep_term thy s $ prep_term thy t |
113 | prep_term thy (s $ t) = prep_term thy s $ prep_term thy t |
119 | prep_term thy (Abs (raw_v, ty, raw_t)) = |
114 | prep_term thy (Abs (raw_v, ty, raw_t)) = |
120 let |
115 let val (v,t) = Syntax.variant_abs (raw_v, ty, raw_t); |
121 val (v, t) = Syntax.variant_abs (raw_v, ty, raw_t); |
|
122 in Abs (v, ty, prep_term thy t) end; |
116 in Abs (v, ty, prep_term thy t) end; |
123 |
117 |
124 |
118 |
125 (* generation of fresh names *) |
119 (* generation of fresh names *) |
126 |
120 |
127 val counter = ref 0; |
121 val counter = ref 0; |
128 fun new_name () = (counter := !counter +1; !counter); |
122 fun new_name () = (counter := !counter +1; !counter); |
|
123 |
|
124 fun to_term (Constr(name, args)) = apps (C name) (map to_term args) |
|
125 | to_term (Var (name, args)) = apps (V name) (map to_term args) |
|
126 | to_term (BVar (name, args)) = apps (B name) (map to_term args) |
|
127 | to_term (F as Fun _) = |
|
128 let val var = new_name() |
|
129 in AbsN(var, to_term (apply F (BVar(var,[])))) end; |
129 |
130 |
130 |
131 |
131 (* greetings to Tarski *) |
132 (* greetings to Tarski *) |
132 |
133 |
133 fun eval thy tab t = |
134 fun eval thy tab t = |
137 | evl vars (Free (v, _)) = |
138 | evl vars (Free (v, _)) = |
138 the_default (Var (v, [])) (AList.lookup (op =) vars v) |
139 the_default (Var (v, [])) (AList.lookup (op =) vars v) |
139 | evl vars (s $ t) = |
140 | evl vars (s $ t) = |
140 apply (evl vars s) (evl vars t) |
141 apply (evl vars s) (evl vars t) |
141 | evl vars (Abs (v, _, t)) = |
142 | evl vars (Abs (v, _, t)) = |
142 Fun (fn [x] => evl (AList.update (op =) (v, x) vars) t, [], 1, |
143 Fun (fn [x] => evl (AList.update (op =) (v, x) vars) t, [], 1) |
143 fn () => let val var = new_name() in |
|
144 AbsN (var, to_term (evl (AList.update (op =) (v, BVar (var, [])) vars) t)) end) |
|
145 in (counter := 0; to_term (evl [] (prep_term thy t))) end; |
144 in (counter := 0; to_term (evl [] (prep_term thy t))) end; |
146 |
145 |
147 end; |
146 end; |