Mercurial > hg > Applications > Tokio

comparison tp.pl @ 0:cfb7c6b24319

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Initial revision
author kono
date Thu, 30 Aug 2007 14:57:44 +0900
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:cfb7c6b24319
1 /*
2 Copyright (C) 1988,2005, Shinji Kono
3 Everyone is permitted to copy and distribute verbatim copies
4 of this license, but changing it is not allowed. You can also
5 use this wording to make the terms for other programs.
6
7 send your comments to kono@ie.u-ryukyu.ac.jp
8 */
9
10 /*
11 Tokio preprosessor
12 Thu Aug 22 15:52:08 JST 1985
13 Wed Sep 4 16:07:39 JST 1985
14 $Header$
15
16 use 'r_prepr' record to generate new predicate
17
18 */
19
20 read_macro( (A '$clause' B) ) :- !,recordz('r_prepr',(A,B),_).
21 read_macro( A ) :- recordz('r_prepr',(A,true),_).
22
23 read_function( (A '$clause' B ) ) :- !,recordz('r_func',(A,B),_).
24 read_function( A ) :- recordz('r_func',(A,true),_).
25
26 reset_macro :- recorda('r_tmp',0,_),fail.
27 reset_macro :- recorded('r_prepr', X, R), check_init(X),
28 erase(R), fail.
29 reset_macro :- recorded('r_func', X, R), check_init(X),
30 erase(R), fail.
31 reset_macro.
32
33 check_init(('r_initr_',true)) :- !,recorded('r_tmp',_,Ref),erase(Ref),fail.
34 check_init(_) :- recorded('r_tmp',_,_),!,fail.
35 check_init(_).
36
37
38 preprocess((X,Y),(XX,YY)) :- !,preprocess(X,XX),preprocess(Y,YY).
39 % preprosess(( :- X),( :- X) ) :- !.
40 preprocess((H :- B), OUT) :- !,
41 functor(H,HH,NN),
42 (recorded('$mnum',(HH,NN,N),R),erase(R) ; N = 0),!,
43 functor(H1,HH,NN),
44 develop_args(0, NN, N, N1, H, H, H1, OUT1, (H1 :- B0),B0,BB),
45 develop(B, BB, H, N1, N2, OUT, OUT1),
46 recordz('$mnum',(HH,NN,N2),_).
47 preprocess(H,H1) :- preprocess((H :- true),H1).
48
49 /*
50 develop(Original, Head, Base, NextBase, Qhead, Qtail).
51
52 */
53
54
55 develop(A,'tokio_call'(A),_H,N,N,Q,Q) :- var(A),!.
56 develop((A,B),(AA,BB),H,N,N1,Q,Q1) :- !,
57 develop(A,AA,H,N,N2,Q,Q2),
58 develop(B,BB,H,N2,N1,Q2,Q1).
59 develop(@(A),@(AA),H,N,N1,Q,Q1) :- !,
60 develop(A,AA,H,N,N1,Q,Q1).
61 develop(next(A),next(AA),H,N,N1,Q,Q1) :- !,
62 develop(A,AA,H,N,N1,Q,Q1).
63 develop(ifEmpty(A),ifEmpty(AA),H,N,N1,Q,Q1) :- !,
64 develop(A,AA,H,N,N1,Q,Q1).
65 develop(ifNotEmpty(A),ifNotEmpty(AA),H,N,N1,Q,Q1) :- !,
66 develop(A,AA,H,N,N1,Q,Q1).
67 develop((A & B),'$chop'(AA,BBB),H,N,N1,Q3,Q1) :- !,
68 copyv(A,Acopy,V,Vcopy),(
69 V = [],
70 develop(A,AA,H,N,N2,Q,Q2),!
71 ;
72 length(V,VN),VN>8,!,
73 develop(( 'r_eq'(V,Vcopy),Acopy ) ,AA,H,N,N2,Q,Q2)
74 ;
75 V=[V1],Vcopy=[Vc1],!,
76 develop(( 'r_eq'(V1,Vc1),Acopy ) ,AA,H,N,N2,Q,Q2)
77 ;
78 V=[V1,V2],Vcopy=[Vc1,Vc2],!,
79 develop(( 'r_eq'(V1,Vc1),'r_eq'(V2,Vc2),Acopy ) ,AA,H,N,N2,Q,Q2)
80 ;
81 V=[V1,V2,V3],Vcopy=[Vc1,Vc2,Vc3],!,
82 develop(( 'r_eq'(V1,Vc1),'r_eq'(V2,Vc2),'r_eq'(V3,Vc3),
83 Acopy ) ,AA,H,N,N2,Q,Q2)
84 ;
85 develop(( #(V=Vcopy),Acopy ) ,AA,H,N,N2,Q,Q2)),!,
86 develop(B,BB,H,N2,N3,Q2,Q1),!,
87 ( var(BB), !, Q3 = Q, BBB = B, N1 = N3
88 ; get_variable(BB,Vlist,[],_,0,_Vcount),
89 new_head(H,BBB,N3,Vlist), % necessary to reduce variable copy..
90 N1 is N3+1,
91 Q3 = ((BBB :- BB),Q)),!.
92 % single time funcitons
93 develop(A:=B, true, _Root, M, M, Q, Q) :-
94 (A \= *('$CNT'(_)),A \= *(_); var(A)) ,!,
95 c_error((write('assign to non static:'),write(A:=B),nl)).
96 % <= use current value for addressing
97 develop(A<==B, true, _Root, M, M, Q, Q) :-
98 (A \= *_,A \= [_|_]; var(A)) ,!,
99 c_error((write('assign to non static:'),write(A<==B),nl)).
100 develop(*A<==B, C, Root, M, M1, Q, Q1) :- !,
101 d_function(A, AA, M, M2, Root, Q, Q2, C, C2),
102 d_function(B, BB, M2,M1, Root, Q2,Q1, C2,
103 ('$CNT'(YY)=AA,'$CNT'(VV)=BB, 'r_assign'('$CNT'(YY),'$CNT'(VV)))).
104 % develop(*A<=B, C, Root, M, M1, Q, Q1) :- atomic(A),!,
105 % d_function(B, BB, M,M1, Root, Q,Q1, C, 'r_assign'(A,'$CNT'(BB))).
106 develop(*('$CNT'(A)):=B, C, Root, M, M1, Q, Q1) :- !,
107 d_function(A, AA, M, M2, Root, Q, Q2, C2, *('$CNT'(AA)):=BB),!,
108 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
109 develop(*A:=B, C, Root, M, M1, Q, Q1) :- !,
110 d_function(A, AA, M, M2, Root, Q, Q2, C2, *AA:=BB),!,
111 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
112 develop(A=B, C, Root, M, M1, Q, Q1) :- !,
113 d_function(A, AA, M, M2, Root, Q, Q2, C2, AA=BB),!,
114 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
115 develop(A<B, C, Root, M, M1, Q, Q1) :- !,
116 d_function(A, AA, M, M2, Root, Q, Q2, C2, AA<BB),!,
117 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
118 develop(A>B, C, Root, M, M1, Q, Q1) :- !,
119 d_function(A, AA, M, M2, Root, Q, Q2, C2, AA>BB),!,
120 d_function(B, BB, M2,M1, Root, Q2,Q1, C, C2).
121 % full time functions
122 develop(A,AAA,Root,N,N1,Q,Q1) :-
123 recorded('r_prepr', ((A :- AA),Body),_),!,
124 develop_macro(Body,A,AA,AAA,Root,N,N1,Q,Q1).
125 develop(A, C, Root, M, M1, Q, Q1) :- functor(A,H,N),functor(AA,H,N),
126 develop_args(0, N, M, M1, Root, A, AA, Q, Q1, C, AA).
127
128 develop_args(N , N, M, M , _Root, _A, _AA, Q, Q, C, C) :- !.
129 develop_args(N1, N, M, M1, Root, A, AA, Q, Q1, C, C1) :-
130 N2 is N1+1, arg(N2,A,B), arg(N2,AA,BB),
131 d_function(B, BB, M, M2, Root, Q, Q2, C, C2),!, %%% check full time here?
132 develop_args(N2, N, M2, M1, Root, A, AA, Q2, Q1, C2, C1).
133
134 develop_macro(true,_A,AA,AAA,Root,N,N1,Q,Q1) :- !,
135 develop(AA,AAA,Root,N,N1,Q,Q1).
136 develop_macro(Body,A,AA,AAA,Root,N,N1,Q,Q2) :-
137 get_variable(A,Vlist,[],_,0,_Vcount),
138 macro(Body, Root, N, N2, Vlist, Q, Q1),
139 develop(AA,AAA,Root,N2,N1,Q1,Q2),!.
140
141 /* make original head
142
143 Root head
144 New head
145 uniq Id
146 variable list
147 */
148
149 new_head(Root,New,No,Vlist) :-
150 new_head(Root,New,No,Vlist,_,T,T).
151
152 new_head(Root,New,No,Vlist,large,T,T1) :-
153 length(Vlist,N),N>10,!,
154 [A,B,C|T] = Vlist,
155 functor(Root,HH,Arity),
156 name(HH,HL),name(No,NL),name(Arity,NAL),
157 concatenate(["r_",NL,HL,NAL],NewL),
158 name(NewH,NewL),
159 New =.. [NewH,A,B,C,T1].
160 new_head(Root,New,No,Vlist,small,_,_) :- functor(Root,HH,A),
161 name(HH,HL),name(No,NL),name(A,NAL),
162 concatenate(["r_",NL,HL,NAL],NewL),
163 name(NewH,NewL),
164 New =.. [NewH|Vlist].
165
166 /* make variable list */
167
168 get_variable(H,V,V1,VL,N,N1) :-
169 var(H),!,
170 not_vmember(H,V,V1,VL,N,N1).
171 get_variable(H,V,V1,VL,N,N1) :-
172 H = '$CNT'(_),!, % inherit constant
173 not_vmember(H,V,V1,VL,N,N1).
174 get_variable(F,V,V1,VL,N,N1) :-
175 functor(F,_,A),
176 get_variable_arg(0,A,F,V, V1, VL, N,N1).
177
178 get_variable_arg(A,A,_F,V,V,_VL, N,N) :- !.
179 get_variable_arg(A,A1,F,V,V1,VL,N,N1) :-
180 A2 is A+1, arg(A2, F, Arg),
181 get_variable(Arg,V,V2,VL,N, N2),
182 get_variable_arg(A2,A1,F,V2,V1,VL,N2,N1).
183
184 not_vmember(H,[H|T],T,VL,N,N1) :- var(VL),!,VL = [H|_],N1 is N+1.
185 not_vmember(H, T,T,[H1|_VL],N,N) :- H == H1,!.
186 not_vmember(H, T,T,[H1|_VL],N,N) :- H == '$CNT'(H1),!.
187 not_vmember(H, T, T1,[_|VL], N, N1) :- not_vmember(H,T,T1,VL,N,N1).
188
189 /* copyv
190 make copy with new variables
191 and its old variable list and new variable list
192
193 copyv(Old, New, OldVariable, NewVariable)
194
195 a little dum algorithm
196 */
197
198 copyv(O,N,OV,NV) :-
199 get_variable(O,OV,[],_,0,_Vcount),!,
200 copy((O,OV),(N,NV)).
201
202 /*
203 macro
204
205 */
206
207
208 macro((A '$clause' B), Root, N, N1, Vs, Q, Q2) :- !,
209 single_macro(A, Root, N, N2, Vs, Q, Q1),
210 macro(B, Root, N2, N1, Vs, Q1, Q2).
211 macro(A, Root, N, N1, Vs, Q, Q1) :-
212 single_macro(A, Root, N, N1, Vs, Q, Q1).
213
214
215 single_macro(A , Root, N, N1, Vlist, (A,Q), Q) :- var(A),!,
216 new_head(Root,A,N,Vlist),
217 N1 is N+1.
218 single_macro((A :- B), Root, N, N2, Vlist, Q, Q2) :- !,
219 head_optimize(BB,A,Root,Vlist,N,N1,Q,Q1),!,
220 develop(B,BB,Root,N1,N2,Q1,Q2),!.
221 single_macro(A, _Root, N, N, _Vlist, (A,Q), Q).
222
223 head_optimize(BB,A,Root,Vlist,N,N2,((A:-BB),Q),Q) :-
224 var(A),
225 !,
226 new_head(Root,A,N,Vlist),
227 N2 is N+1.
228 head_optimize(BB,A,_Root,_Vlist,N,N,((A:-BB),Q),Q).
229
230 /*
231 functions
232 should be seprated full time function and
233 now only function
234 */
235
236 d_function(A,AA,N,N,_Root,Q,Q,C,C) :- var(A),!, A = AA. % not interval constant
237 d_function(A,R1,N,N1,Root,Q,Q1,(AAA,C1),C) :- % not interval constant
238 recorded('r_func', ((A = R :- AA),Body) ,_),!,
239 d_function(R,R1,N,N2,Root,Q2,Q1,C1,C),
240 d_f_dev(Body,A,AA,AAA,Root,N2,N1,Q,Q2).
241 d_function(cputime, '$CNT'(Value), N,N,_R,Q, Q, ('r_cputime'(Value),C),C) :- !.
242 d_function(A,AA,N,N,_Root,Q,Q,C,C) :- atomic(A),!, A = AA.
243 d_function(@A,@AA,N,N2,Root,Q,Q1,Next,C) :- !, % not interval constant
244 d_function(A,AA,N,N2,Root,Q,Q1,CN,true),
245 d_next_check(CN,Next,C).
246 d_function(*Name,'$CNT'(V),N,N2,Root,Q,Q1,C,C1) :- !, % not interval constant
247 d_function(Name,Name1,N,N2,Root,Q,Q1,C,('r_read_value'(Name1,'$CNT'(V)),C1)).
248 d_function(binary(B), Value, N,N,_R,Q, Q, C,C) :- !,
249 c_binary(B,Value),!.
250 d_function(hex(H), Value, N,N,_R,Q, Q, C,C) :- !,
251 c_hex(H,Value),!.
252 d_function(Exp, '$CNT'(Value), N,N1,R,Q, Q1, C,C1) :- % not interval constant
253 n_function(Exp,A,B,Exp1,AA,BB),!,
254 d_function_exp(A, AA, N,N2,R,Q, Q2,C, C2),
255 d_function_exp(B, BB, N2,N1,R,Q2,Q1,C2,('$CNT'(Value) is Exp1,C1)).
256 d_function(A,AA,N,N1,Root,Q,Q1,C,C1) :- functor(A,H,M),functor(AA,H,M),
257 d_function_args(0,M,A,AA,N,N1,Root,Q,Q1,C,C1),!.
258
259 d_next_check(true,C,C):-!.
260 d_next_check(CN,(next(CN),C),C):-!.
261
262 d_function_args(M,M,_A,_AA,N,N,_Root,Q,Q,C,C) :- !.
263 d_function_args(M1,M,A,AA,N,N1,Root,Q,Q1,C,C1) :-
264 M2 is M1+1, arg(M2,A,B), arg(M2,AA,BB),
265 d_function(B,BB,N,N2,Root,Q,Q2,C,C2),!,
266 d_function_args(M2,M,A,AA,N2,N1,Root,Q2,Q1,C2,C1),!.
267
268 d_function_exp(Exp, Exp1, N,N1,R,Q, Q1, C,C1) :- nonvar(Exp),
269 n_function(Exp,A,B,Exp1,AA,BB),!,
270 d_function_exp(A, AA, N,N2,R,Q, Q2, C,C2),
271 d_function_exp(B, BB, N2,N1,R,Q2, Q1, C2,C1).
272 d_function_exp(Exp, Exp1, N,N1,R,Q, Q1, C,C1) :-
273 d_function(Exp, Exp1, N,N1,R,Q, Q1, C,C1).
274
275 d_f_dev(true,_A,AA,AAA,Root,N,N1,Q,Q1) :-!,
276 develop(AA, AAA, Root, N, N1, Q, Q1).
277 d_f_dev(Body,A,AA,AAA,Root,N,N1,Q,Q1) :-
278 get_variable(A,Vs,[],_,0,_Vcount),!,
279 develop(AA, AAA, Root, N, N2, Q, Q2),!,
280 macro(Body, Root, N2, N1, Vs, Q2, Q1),!.
281
282 /* */