/*
 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),!.

/* */