Mercurial > hg > Applications > Tokio

comparison tc.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
12 Tokio compiler to prolog
13 Thu Aug 15 12:17:04 JST 1985
14 Fri Jan 10 16:11:31 JST 1986
15 Fri Sep 5 09:51:36 JST 1986 for 1.2a
16 Thu Mar 26 16:19:10 JST 1987
17 Wed Oct 14 13:35:54 JST 1987 full time F
18 Fri Oct 16 11:28:26 JST 1987 Sicstus
19 $Header$
20 body-compiler
21 */
22
23 c_clause((Head :- Body), (H :- B)) :- !,
24 c_opt(Body, NBody, _), % delete true
25 c_body(NBody, Control,
26 ['$t'(B1,_,_,_)|Q] , ['$t'(true,_,_,_)|T1], before_cut-_),
27 % make queue structure
28 c_head(Head, H0, B2, B1,Control,Q), % inline unification
29 c_opt(B2, B, _), % off tailing true
30 c_make_pred(H0, H, Q, T1).
31 c_clause(Head, H) :- % fact
32 c_head(Head, H0, B2, true,_,_),
33 c_make_pred(H0, H1, Q, Q),
34 c_opt(B2, B, _), % off tailing true
35 (B = true, H = H1,! ; H = (H1 :- B)).
36
37 c_error(A) :-
38 telling(Old),tell(user),
39 call(A),
40 tell(Old).
41
42 /*
43
44 c_head(Head, ModfiedHead, Qhead, Qtail)
45
46 */
47
48 c_head(H,Mh,Qh0,Qt,Control,Q) :-
49 c_control_reference(Control,Qh0,Qh,Q),
50 functor(H,F,A),functor(Mh,F,A),
51 c_args(0,A, H, Mh, Qh, Qt).
52
53 c_args(N, N, _, _, Q, Q) :- !.
54 c_args(K, N, Head, H, Q, Q1) :-
55 K1 is K+1, arg(K1, Head, AK), arg(K1, H, HK),
56 c_unify(AK, HK, Q, Q2, 8),
57 c_args(K1, N, Head, H, Q2, Q1).
58
59 % We needs NOW value however sometines is is hiden in Next time Queue
60 c_control_reference(Control,(Q=['$t'(_N,_F,_K,'$'(_,NowTime,_))|_],Qh),Qh,Q) :-
61 Control = '$'(_Fin,Now,_Empty),nonvar(Now),var(Q),
62 Now = '$REF'(NowTime),!.
63 c_control_reference(_Control,Qh,Qh,_Q).
64
65 /*
66
67 Tokio compiler Queue structure
68
69 [Qnow,Qnext1,Qnext2,......|_],[QnowTail,Qnext1Tail,Qnext2Tail,.....|_]
70 D-list
71 Qnow = '$t'(Next,Fin,Keep,'$'(Fin,Now,Empty))
72
73 predicate(A):- p,q.
74 ---> predicate(A,Q,Q1) :-
75 p(Q,Q2),q(Q2,Q1).
76 */
77
78 c_body(E=E1, Control,
79 ['$t'(N1,F,K,C)|Q],
80 ['$t'(N,F,K,C)|Q], before_cut-before_cut) :- !,
81 c_eval(E, EE, N1, N2, Control), c_eval(E1, EE1, N2, N, Control),
82 c_equate(EE,EE1).
83 c_body(E=E1, Control,
84 ['$t'(N1,F,K,C)|Q],
85 ['$t'(N,F,K,C)|Q], after_cut-after_cut) :- !,
86 c_eval(E, EE, N1, N2, Control), c_eval(E1, EE1, N2, (EE = EE1,N), Control).
87 c_body(E is E1, Control,
88 ['$t'(N1,F,K,C)|Q],
89 ['$t'(N,F,K,C)|Q], Cut-Cut) :- !,
90 c_eval(E, EE, N1, N2, Control), c_eval(E1, EE1, N2, (EE is EE1,N), Control).
91 c_body('$chop'(Former,Later), Control, % later must be atomic
92 ['$t'(('r_subBegin'(Q,QF,QF1,_Sfin),FF),F,K,Control)|Q],
93 ['$t'(FF1,F,K,Control)|Q1],Cut) :- !,
94 Control = '$'(_CFin,CNow,_CEmpty), NC = '$'(_,CNow,_), % subtle code
95 c_body(Former,NC,['$t'(FF,_,_,NC)|QF1],['$t'((L1,FF1),_,_,NC)|QF2],Cut),
96 c_chop_later(Later, L1, Q, Q1, QF, QF2).
97 c_body((A,B), Control, Q, Q1, Cut-Cut1) :- !,
98 c_body(A, Control, Q, Q2, Cut-Cut2),
99 c_body(B, Control, Q2, Q1, Cut2-Cut1).
100 %c_body(empty, '$'(Fin,Now,empty),
101 % [Now,'$t'(N,F,K,'$'(Fin,Now,empty))|Q1],
102 % [Now,'$t'(N,F,K,'$'(Fin,Now,empty))|Q1], Cut) :- !, % strong next
103 c_body(empty, Control,
104 ['$t'(('r_empty'(Q),N),F,K,Control)|Q],
105 ['$t'(N,F,K,Control)|Q],Cut-Cut) :- !.
106 c_body(notEmpty, Control,
107 ['$t'(('r_notEmpty'(Q),N),F,K,Control)|Q],
108 ['$t'(N,F,K,Control)|Q],Cut-Cut) :- !.
109 c_body(length(L), Control,
110 ['$t'(N2,F,K,Control)|Q],
111 ['$t'(N,F,K,Control)|Q],Cut-Cut) :- !,
112 c_eval(L, LL, N2, ('r_length'(LL,Q),N), Control).
113 %% c_body(@true, C, Q, Q, Cut-Cut) :-!. % special optimize
114 c_body(next(true), _C, Q, Q, Cut-Cut) :-!.
115 c_body(@A, '$'(Fin,NowTime,notEmpty),
116 [Now|Q],
117 [Now,'$t'(N,F,K,'$'(Fin,NowTime,notEmpty))|Q1], Cut) :- !, % strong next
118 c_seperate_next(A, NextA),
119 c_body(NextA, _Control,
120 Q,
121 ['$t'(N,F,K,'$'(Fin,NowTime,notEmpty))|Q1], Cut).
122 c_body(next(A), _Control,
123 [Now|Q], [Now|Q1], Cut) :- !, % weak next
124 c_seperate_next(A, NextA),
125 c_body(NextA, _Control1, Q, Q1, Cut).
126 c_body(ifEmpty(A), Control, % fin don't care queue
127 [Now,'$t'(N,F,K,Control)|Q],[Now,'$t'(N,F1,K,Control)|Q],
128 Cut-Cut) :- !,
129 c_body(A, Control,
130 ['$t'(F,F2,_,Control)|_],
131 ['$t'(F2,F1,_,Control)|_] , after_cut-_).
132 c_body(ifNotEmpty(A), Control,
133 [Now,'$t'(N,F,K,Control)|Q],[Now,'$t'(N1,F,K1,Control1)|Q1],
134 Cut-Cut) :- !,
135 c_body(A, Control,
136 ['$t'(K ,_,_,Control),'$t'(N, _,K2,Control) |Q],
137 ['$t'(K2,_,_,Control),'$t'(N1,_,K1,Control1)|Q1] , after_cut-_).
138 c_body(A, Control, ['$t'(System,F,K,Control)|Q],
139 ['$t'(System1,F,K,Control)|Q], Cut) :-
140 c_system(A, System, System1, Control, Cut), !.
141 c_body(A, Control,
142 ['$t'((A1,Now),F,K,Control)|Q],
143 ['$t'(Now,F,K,Control)|Q1], Cut-Cut) :- !,
144 c_make_pred(A,A1,Q,Q1).
145
146 c_make_pred(X, XX, Q, T) :-
147 functor(X, F, A),
148 A1 is A+1, A2 is A+2,
149 functor(XX, F, A2),
150 c_copy_args(A, X, XX),
151 arg(A1, XX, Q), arg(A2, XX, T).
152
153 c_copy_args(0, _, _) :- !.
154 c_copy_args(K, X, XX) :-
155 arg(K, X, XK), arg(K, XX, XK), K1 is K-1, c_copy_args(K1, X, XX).
156
157 c_system(true,Q, Q, _, Cut-Cut) :- !.
158 c_system('r_read_value'(A,B),('r_read_value'(A1,B),Q), Q, _, Cut-Cut) :- !,
159 c_seperate_now(A,A1).
160 c_system(!, (!,Q), Q, _, _Cut-after_cut) :- !.
161 c_system(prolog(A), (call(A1),Q), Q, _, Cut-Cut) :- !, c_seperate_now(A,A1).
162 %% c_system(A<--B, Q, Q1, Control, Cut-Cut) :- !,
163 %% c_eval(B, V, Q, Q2, Control),
164 %% (A = '$CNT'(V),!,Q1=Q2 ; Q2 = (unifyAll(A,V),Q1)).
165 c_system(*A:=B, Q, Q1, Control, Cut-Cut) :- !,
166 '$'(_Fin,'$REF'(NowTime),_Empty)=Control,
167 c_eval(A, Name, Q, Q2, Control),
168 c_eval(B, Value, Q2, ('r_set_value'(Name,Value,NowTime),Q1), Control).
169 c_system(Op, Q, Q1, Control, Cut-Cut) :- n_predicate(Op,A,B,Op2,AA,BB),!,
170 c_eval(A, AA, Q, Q2, Control), c_eval(B, BB, Q2, (Op2,Q1), Control).
171 c_system(System,(System1,Q), Q, _, Cut-Cut) :- systemp(System),
172 c_seperate_now(System,System1).
173
174 % compile chop operator
175 %
176 % c_chop_later(Later, GenerateLater, Q, Q1, QF, QF1).
177
178 c_chop_later(Later, GenerateLater, Q, Q1, QF, QF1) :-
179
180 % 0r(X, '$'(Q,Q1,QF,QF1))
181
182 functor(Later, LH1, A),
183 A1 is A+1,
184 functor(GenerateLater, LH1, A1),
185 arg(A1, GenerateLater, '$'(Q,Q1,QF,QF1)),
186 c_skel_copy_arg(0, 0, A, Later, GenerateLater),
187
188 % 0r(X, '$'(Q, Q1, QF, QF1)) :- 'r_subFin'(QF, QF1),r(X, Q, Q1).
189
190 functor(Later0, LH1, A),
191 c_make_pred(Later0, Later1, QQ, QQ1),
192 functor(L2, LH1, A1),
193 arg(A1, L2, '$'(QQ,QQ1,QQF,QQF1)),
194 c_skel_copy_arg(0, 0, A, Later0, L2),
195 write_clause( (L2 :- 'r_subFin'(QQF,QQF1), Later1)),
196
197 % 0r(X, '$'(Q, Q1, QF, QF1)) :-
198 % 'r_subNotFin'(
199 % 0r(Xn,'$'(NQ,NQ1,NQF,NQF1)), '$'(NQ,NQ1,NQF,NQF1),
200 % '$'(Q, Q1, QF, QF1)).
201
202 functor(Later00, LH1, A),
203 functor(L3, LH1, A1),
204 arg(A1, L3, '$'(QQ,QQ1,QQF,QQF1)),
205 functor(L4, LH1, A1),
206 arg(A1, L4, '$'(NQQ,NQQ1,NQQF,NQQF1)),
207 c_seperate_next(Later00,Later00Next),
208 c_skel_copy_arg(0, 0, A, Later00Next, L4),
209 c_args(0,A,Later00, L3, Body,
210 'r_subNotFin'( L4, '$'(NQQ,NQQ1,NQQF,NQQF1),
211 QQ, QQ1, QQF, QQF1)),
212 write_clause(( L3 :- Body )).
213
214 %%