--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tp.pl	Thu Aug 30 14:57:44 2007 +0900
@@ -0,0 +1,282 @@
+/*
+ Copyright (C) 1988,2005, Shinji Kono 
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license, but changing it is not allowed.  You can also
+ use this wording to make the terms for other programs.
+
+ send your comments to kono@ie.u-ryukyu.ac.jp
+*/
+
+/*
+	Tokio preprosessor
+					Thu Aug 22 15:52:08 JST 1985
+					Wed Sep  4 16:07:39 JST 1985
+					$Header$
+
+	use 'r_prepr' record to generate new predicate
+
+*/
+
+read_macro( (A '$clause' B) ) :- !,recordz('r_prepr',(A,B),_).
+read_macro( A ) :- recordz('r_prepr',(A,true),_).
+
+read_function( (A '$clause' B ) ) :- !,recordz('r_func',(A,B),_).
+read_function( A ) :- recordz('r_func',(A,true),_).
+
+reset_macro :- recorda('r_tmp',0,_),fail.
+reset_macro :- recorded('r_prepr', X, R), check_init(X),
+    erase(R), fail.
+reset_macro :- recorded('r_func', X, R), check_init(X),
+    erase(R), fail.
+reset_macro.
+
+check_init(('r_initr_',true)) :- !,recorded('r_tmp',_,Ref),erase(Ref),fail.
+check_init(_) :- recorded('r_tmp',_,_),!,fail.
+check_init(_).
+
+
+preprocess((X,Y),(XX,YY)) :- !,preprocess(X,XX),preprocess(Y,YY).
+% preprosess(( :- X),( :- X) ) :- !.
+preprocess((H :- B), OUT) :- !,
+    functor(H,HH,NN),
+    (recorded('$mnum',(HH,NN,N),R),erase(R) ; N = 0),!,
+    functor(H1,HH,NN),
+    develop_args(0, NN, N, N1, H, H, H1, OUT1, (H1 :- B0),B0,BB),
+    develop(B, BB, H, N1, N2, OUT, OUT1),
+    recordz('$mnum',(HH,NN,N2),_).
+preprocess(H,H1) :- preprocess((H :- true),H1).
+
+/*
+	develop(Original, Head, Base, NextBase, Qhead, Qtail).
+
+*/
+
+
+develop(A,'tokio_call'(A),_H,N,N,Q,Q) :- var(A),!.
+develop((A,B),(AA,BB),H,N,N1,Q,Q1) :- !,
+    develop(A,AA,H,N,N2,Q,Q2),
+    develop(B,BB,H,N2,N1,Q2,Q1).
+develop(@(A),@(AA),H,N,N1,Q,Q1) :- !,
+    develop(A,AA,H,N,N1,Q,Q1).
+develop(next(A),next(AA),H,N,N1,Q,Q1) :- !,
+    develop(A,AA,H,N,N1,Q,Q1).
+develop(ifEmpty(A),ifEmpty(AA),H,N,N1,Q,Q1) :- !,
+    develop(A,AA,H,N,N1,Q,Q1).
+develop(ifNotEmpty(A),ifNotEmpty(AA),H,N,N1,Q,Q1) :- !,
+    develop(A,AA,H,N,N1,Q,Q1).
+develop((A & B),'$chop'(AA,BBB),H,N,N1,Q3,Q1) :- !,
+    copyv(A,Acopy,V,Vcopy),(
+	V = [],
+	develop(A,AA,H,N,N2,Q,Q2),!
+	;
+	length(V,VN),VN>8,!,
+	develop(( 'r_eq'(V,Vcopy),Acopy ) ,AA,H,N,N2,Q,Q2)
+        ;
+	V=[V1],Vcopy=[Vc1],!,
+	develop(( 'r_eq'(V1,Vc1),Acopy ) ,AA,H,N,N2,Q,Q2)
+        ;
+	V=[V1,V2],Vcopy=[Vc1,Vc2],!,
+	develop(( 'r_eq'(V1,Vc1),'r_eq'(V2,Vc2),Acopy ) ,AA,H,N,N2,Q,Q2)
+        ;
+	V=[V1,V2,V3],Vcopy=[Vc1,Vc2,Vc3],!,
+	develop(( 'r_eq'(V1,Vc1),'r_eq'(V2,Vc2),'r_eq'(V3,Vc3),
+	          Acopy ) ,AA,H,N,N2,Q,Q2)
+	;
+	develop(( #(V=Vcopy),Acopy ) ,AA,H,N,N2,Q,Q2)),!,
+    develop(B,BB,H,N2,N3,Q2,Q1),!,
+    (	var(BB), !, Q3 = Q, BBB = B, N1 = N3
+    ;	get_variable(BB,Vlist,[],_,0,_Vcount),
+    	new_head(H,BBB,N3,Vlist),       % necessary to reduce variable copy..
+	N1 is N3+1,
+	Q3 = ((BBB :- BB),Q)),!.
+% single time funcitons
+develop(A:=B, true, _Root, M, M, Q, Q) :- 
+	(A \= *('$CNT'(_)),A \= *(_); var(A)) ,!,
+	c_error((write('assign to non static:'),write(A:=B),nl)).
+% <= use current value for addressing
+develop(A<==B, true, _Root, M, M, Q, Q) :- 
+	(A \= *_,A \= [_|_]; var(A)) ,!,
+	c_error((write('assign to non static:'),write(A<==B),nl)).
+develop(*A<==B, C, Root, M, M1, Q, Q1) :- !,
+    d_function(A, AA, M, M2, Root, Q, Q2, C, C2),
+    d_function(B, BB, M2,M1, Root, Q2,Q1, C2, 
+	('$CNT'(YY)=AA,'$CNT'(VV)=BB, 'r_assign'('$CNT'(YY),'$CNT'(VV)))).
+% develop(*A<=B, C, Root, M, M1, Q, Q1) :- atomic(A),!,
+%    d_function(B, BB, M,M1, Root, Q,Q1, C, 'r_assign'(A,'$CNT'(BB))).
+develop(*('$CNT'(A)):=B, C, Root, M, M1, Q, Q1) :- !,
+    d_function(A, AA, M, M2, Root, Q, Q2, C2, *('$CNT'(AA)):=BB),!,
+    d_function(B, BB, M2,M1, Root, Q2,Q1, C,  C2).
+develop(*A:=B, C, Root, M, M1, Q, Q1) :- !,
+    d_function(A, AA, M, M2, Root, Q, Q2, C2, *AA:=BB),!,
+    d_function(B, BB, M2,M1, Root, Q2,Q1, C,  C2).
+develop(A=B, C, Root, M, M1, Q, Q1) :- !,
+    d_function(A, AA, M, M2, Root, Q, Q2, C2, AA=BB),!,
+    d_function(B, BB, M2,M1, Root, Q2,Q1, C,  C2).
+develop(A<B, C, Root, M, M1, Q, Q1) :- !,
+    d_function(A, AA, M, M2, Root, Q, Q2, C2, AA<BB),!,
+    d_function(B, BB, M2,M1, Root, Q2,Q1, C,  C2).
+develop(A>B, C, Root, M, M1, Q, Q1) :- !,
+    d_function(A, AA, M, M2, Root, Q, Q2, C2, AA>BB),!,
+    d_function(B, BB, M2,M1, Root, Q2,Q1, C,  C2).
+% full time functions
+develop(A,AAA,Root,N,N1,Q,Q1) :- 
+    recorded('r_prepr', ((A :- AA),Body),_),!,
+    develop_macro(Body,A,AA,AAA,Root,N,N1,Q,Q1).
+develop(A, C, Root, M, M1, Q, Q1) :- functor(A,H,N),functor(AA,H,N),
+    develop_args(0, N, M, M1, Root, A, AA, Q, Q1, C, AA).
+
+develop_args(N , N, M, M , _Root, _A, _AA, Q, Q,  C, C) :- !.
+develop_args(N1, N, M, M1, Root, A, AA, Q, Q1, C, C1) :-
+    N2 is N1+1, arg(N2,A,B), arg(N2,AA,BB),
+    d_function(B, BB, M, M2, Root, Q, Q2, C, C2),!,   %%% check full time here?
+    develop_args(N2, N, M2, M1, Root, A, AA, Q2, Q1, C2, C1).
+
+develop_macro(true,_A,AA,AAA,Root,N,N1,Q,Q1) :- !,
+    develop(AA,AAA,Root,N,N1,Q,Q1).
+develop_macro(Body,A,AA,AAA,Root,N,N1,Q,Q2) :- 
+    get_variable(A,Vlist,[],_,0,_Vcount),
+    macro(Body, Root, N, N2, Vlist, Q, Q1),
+    develop(AA,AAA,Root,N2,N1,Q1,Q2),!.
+
+/* make original head
+
+	Root head
+	New head
+	uniq Id
+	variable list
+*/
+
+new_head(Root,New,No,Vlist) :- 
+    new_head(Root,New,No,Vlist,_,T,T).
+
+new_head(Root,New,No,Vlist,large,T,T1) :- 
+    length(Vlist,N),N>10,!,
+    [A,B,C|T] = Vlist,
+    functor(Root,HH,Arity),
+    name(HH,HL),name(No,NL),name(Arity,NAL),
+    concatenate(["r_",NL,HL,NAL],NewL),
+    name(NewH,NewL),
+    New =.. [NewH,A,B,C,T1].
+new_head(Root,New,No,Vlist,small,_,_) :- functor(Root,HH,A),
+    name(HH,HL),name(No,NL),name(A,NAL),
+    concatenate(["r_",NL,HL,NAL],NewL),
+    name(NewH,NewL),
+    New =.. [NewH|Vlist].
+
+/* make variable list */
+
+get_variable(H,V,V1,VL,N,N1) :- 
+    var(H),!,
+    not_vmember(H,V,V1,VL,N,N1).
+get_variable(H,V,V1,VL,N,N1) :- 
+    H = '$CNT'(_),!,			% inherit constant
+    not_vmember(H,V,V1,VL,N,N1).
+get_variable(F,V,V1,VL,N,N1) :-
+    functor(F,_,A),
+    get_variable_arg(0,A,F,V, V1, VL, N,N1).
+
+get_variable_arg(A,A,_F,V,V,_VL, N,N) :- !.
+get_variable_arg(A,A1,F,V,V1,VL,N,N1) :-
+    A2 is A+1, arg(A2, F, Arg),
+    get_variable(Arg,V,V2,VL,N, N2),
+    get_variable_arg(A2,A1,F,V2,V1,VL,N2,N1).
+
+not_vmember(H,[H|T],T,VL,N,N1) :- var(VL),!,VL = [H|_],N1 is N+1.
+not_vmember(H, T,T,[H1|_VL],N,N) :- H == H1,!.
+not_vmember(H, T,T,[H1|_VL],N,N) :- H == '$CNT'(H1),!.
+not_vmember(H, T, T1,[_|VL], N, N1) :- not_vmember(H,T,T1,VL,N,N1).
+
+/* copyv
+	make copy with new variables
+	  and its old variable list and new variable list 
+
+	copyv(Old, New, OldVariable, NewVariable)
+
+	a little dum algorithm
+*/
+
+copyv(O,N,OV,NV) :- 
+    get_variable(O,OV,[],_,0,_Vcount),!,
+    copy((O,OV),(N,NV)).   
+
+/*
+	macro
+
+*/
+
+
+macro((A '$clause' B), Root, N, N1, Vs, Q, Q2) :- !,
+    single_macro(A, Root, N, N2, Vs, Q, Q1),
+    macro(B, Root, N2, N1, Vs, Q1, Q2).
+macro(A, Root, N, N1, Vs, Q, Q1) :-
+    single_macro(A, Root, N, N1, Vs, Q, Q1).
+    
+
+single_macro(A , Root, N, N1, Vlist, (A,Q), Q) :- var(A),!,
+    new_head(Root,A,N,Vlist),
+    N1 is N+1.
+single_macro((A :- B), Root, N, N2, Vlist, Q, Q2) :- !,
+    head_optimize(BB,A,Root,Vlist,N,N1,Q,Q1),!,
+    develop(B,BB,Root,N1,N2,Q1,Q2),!.
+single_macro(A, _Root, N, N, _Vlist, (A,Q), Q).
+
+head_optimize(BB,A,Root,Vlist,N,N2,((A:-BB),Q),Q) :-
+    var(A), 
+    !,
+    new_head(Root,A,N,Vlist),
+    N2 is N+1.
+head_optimize(BB,A,_Root,_Vlist,N,N,((A:-BB),Q),Q).
+
+/*
+	functions	
+		should be seprated full time function and
+			now only function
+*/
+
+d_function(A,AA,N,N,_Root,Q,Q,C,C) :- var(A),!, A = AA. % not interval constant
+d_function(A,R1,N,N1,Root,Q,Q1,(AAA,C1),C) :- 	       % not interval constant
+    recorded('r_func', ((A = R :-  AA),Body) ,_),!,
+    d_function(R,R1,N,N2,Root,Q2,Q1,C1,C),
+    d_f_dev(Body,A,AA,AAA,Root,N2,N1,Q,Q2).
+d_function(cputime, '$CNT'(Value), N,N,_R,Q, Q, ('r_cputime'(Value),C),C) :- !.
+d_function(A,AA,N,N,_Root,Q,Q,C,C) :- atomic(A),!, A = AA.
+d_function(@A,@AA,N,N2,Root,Q,Q1,Next,C) :- !, % not interval constant
+    d_function(A,AA,N,N2,Root,Q,Q1,CN,true),
+    d_next_check(CN,Next,C).
+d_function(*Name,'$CNT'(V),N,N2,Root,Q,Q1,C,C1) :- !,  % not interval constant
+    d_function(Name,Name1,N,N2,Root,Q,Q1,C,('r_read_value'(Name1,'$CNT'(V)),C1)).
+d_function(binary(B), Value, N,N,_R,Q, Q, C,C) :- !,
+    c_binary(B,Value),!.
+d_function(hex(H), Value, N,N,_R,Q, Q, C,C) :- !,
+    c_hex(H,Value),!.
+d_function(Exp, '$CNT'(Value), N,N1,R,Q, Q1, C,C1) :-  % not interval constant
+    n_function(Exp,A,B,Exp1,AA,BB),!,
+    d_function_exp(A, AA, N,N2,R,Q, Q2,C, C2),
+    d_function_exp(B, BB, N2,N1,R,Q2,Q1,C2,('$CNT'(Value) is Exp1,C1)).
+d_function(A,AA,N,N1,Root,Q,Q1,C,C1) :- functor(A,H,M),functor(AA,H,M),
+    d_function_args(0,M,A,AA,N,N1,Root,Q,Q1,C,C1),!.
+
+d_next_check(true,C,C):-!.
+d_next_check(CN,(next(CN),C),C):-!.
+
+d_function_args(M,M,_A,_AA,N,N,_Root,Q,Q,C,C) :- !.
+d_function_args(M1,M,A,AA,N,N1,Root,Q,Q1,C,C1) :-
+    M2 is M1+1, arg(M2,A,B), arg(M2,AA,BB),
+    d_function(B,BB,N,N2,Root,Q,Q2,C,C2),!,
+    d_function_args(M2,M,A,AA,N2,N1,Root,Q2,Q1,C2,C1),!.
+
+d_function_exp(Exp, Exp1, N,N1,R,Q, Q1, C,C1) :- nonvar(Exp),
+    n_function(Exp,A,B,Exp1,AA,BB),!,
+    d_function_exp(A, AA, N,N2,R,Q,  Q2, C,C2),
+    d_function_exp(B, BB, N2,N1,R,Q2, Q1, C2,C1).
+d_function_exp(Exp, Exp1, N,N1,R,Q, Q1, C,C1) :- 
+    d_function(Exp, Exp1, N,N1,R,Q, Q1, C,C1).
+
+d_f_dev(true,_A,AA,AAA,Root,N,N1,Q,Q1) :-!,
+    develop(AA, AAA, Root, N, N1, Q, Q1).
+d_f_dev(Body,A,AA,AAA,Root,N,N1,Q,Q1) :-
+    get_variable(A,Vs,[],_,0,_Vcount),!,
+    develop(AA, AAA, Root, N, N2, Q, Q2),!,
+    macro(Body, Root, N2, N1, Vs, Q2, Q1),!.
+
+/* */