/*
 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 compiler to prolog
			Thu Aug 15 12:17:04 JST 1985
			Fri Jan 10 16:11:31 JST 1986
			Fri Sep  5 09:51:36 JST 1986 for 1.2a
			Thu Mar 26 16:19:10 JST 1987
			Wed Oct 14 13:35:54 JST 1987 full time F
			Fri Oct 16 11:28:26 JST 1987 Sicstus
			$Header$
	compiler main routine 
*/

com(X) :- reset_macro,tokiocompile(X). 
com(X,Y) :- reset_macro,tokiocompile(X, Y),
	(Y = user,!;reconsult(Y)). 
 
tokiocompile(S) :-
    tokiocompile(S, '#temp.tokio'),
%   reconsult('#temp.tokio'). 
    compile0('#temp.tokio'). 

tokiocompile(S, O) :- 
    cputime(Time),
    init_tokiocomp,
    tell(O), 
    tokiocomp(S, [], _L), told, 
    cputime(Time1),Time0 is Time1-Time, 
    c_error((write('END '), nl, write(Time0), write(' sec.'),nl)).
 
init_tokiocomp :- recorded('$uskel', _X, R), erase(R), fail.
init_tokiocomp :- recorded('$mnum', _X, R), erase(R), fail.
init_tokiocomp.

tokiocomp([], L, L) :- !. 
tokiocomp([H|T], L0, L) :- !, tokiocomp(H, L0, L1), tokiocomp(T, L1, L). 
tokiocomp(F, _L0, _L) :- 
    seeing(O), nofileerrors, tokiofile(F,F1),see(F1), !, 
    tokiocomp1('$$$$'), seen, see(O), !. 
tokiocomp(F, _, _) :- 
    fileerrors, 
    c_error((write('Cannot open file: '), write(F), nl)), !, fail. 
 
tokiofile(F,F).
tokiofile(F,F1) :- name(F,FL),concatenate([FL,".tokio"],NewL),name(F1,NewL).
tokiofile(F,F1) :- name(F,FL),concatenate([FL,".t"],NewL),name(F1,NewL).


/* tokiocomp1
	read loop (fail loop)
*/

tokiocomp1(X) :- tokiocomp2(X).
tokiocomp1(_) :-
    read(Next), !, tokiocomp1(Next). 
tokiocomp1(_) :- c_error((nl,write('read error'),nl)).

/* tokocomp2
	compiler directive 
	this predicate never success except file end.
*/

tokiocomp2(end_of_file) :- !. 
tokiocomp2('$$$$') :- !,fail. 
tokiocomp2('$define'(Macro)) :- 
     read_macro(Macro),!,fail.
tokiocomp2('$function'(Function)) :-
     read_function(Function),!,fail.
tokiocomp2((:- X)) :- 		
    call(X), write_clause((:- X)),!,fail.
tokiocomp2((?- X)) :- 		
    call(X), write_clause((:- X)),!,fail.
tokiocomp2(Head) :- compiling_message(Head),fail.
tokiocomp2(X) :- preprocess(X,X1),!,tokiocomp3(X1).

compiling_message((Head :- _Body)) :- !,compiling_message(Head).
compiling_message(Head) :- 
    (systemp(Head);Head = (_,_);Head = [_|_];functor(Head,'{}',_)),!,
    functor(Head,H,A),
    c_error((
    write('Compiling System Predicate: '), 
    write(H/A),nl)),!.
compiling_message(Head) :- 
    functor(Head,H,A),
    c_error((
    write('Compiling: '), 
    write(H/A),nl)),!,!.

/* tokiocomp3
	if end_of_file then success otherwise fail
*/

tokiocomp3((X,_Y)) :- tokiocomp3(X),fail.	% fail and fall into next line
tokiocomp3((_X,Y)) :- !,tokiocomp3(Y).
tokiocomp3(X) :- 
    c_clause(X, C), write_clause(C),!, fail. % to reduce stack
tokiocomp3(X) :- 
    c_error((nl,write('compiler error on '),write(X),nl)),fail.
 
% preprocess(X,X).			% no development

display_fa(F/A) :- display(F), display('/'), display(A), display(','). 
 
writel([]) :- !. 
writel([X|L]) :- writel(L), write(X), write(', '). 
 
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%   varialble type
%
%	'$REF'       full referenced variable
%	'$TMP'	   both now and next are referenced
%	'$NOW','$NXT'  either now or next is referenced
%	'$CNT'	   this variable is constnat in time transition
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

variable(X) :- var(X), !. 
variable('$REF'(_)) :- !. 
variable('$CNT'(_)) :- !. 
variable('$NOW'(_,_)) :- !.
variable('$NXT'(_,_)) :- !.
variable('$TMP'(_,_,_)).
 

% c_post(Vname, Vname, V0, V) :- 
%  	var(Vname),!, V is V0+1,name(V0,Lv),name(Vname,[95|Lv]).  %%% _001
c_post(Vname, Vname, V0, V) :- 
 	var(Vname),!, V is V0+1,Vname = '$VAR'(V0).		%%% _001
c_post('$VAR'(X), '$VAR'(X), V, V) :- !. 
c_post('$CNT'(X), XX, V0, V) :- !, c_post(X, XX, V0, V). 
c_post('$REF'(X), XX, V0, V) :- !, c_post(X, XX, V0, V). 
c_post('$TMP'(X,Now,Nxt), XX, V0, V) :- !, c_post_tvar(X,Now,Nxt, XX, V0, V).
c_post('$NOW'(X,Now), XX, V0, V) :- !, c_post_tvar(X,Now,_Nxt, XX, V0, V).
c_post('$NXT'(X,Nxt), XX, V0, V) :- !, c_post_tvar(X,_Now,Nxt, XX, V0, V).
c_post(Atomic,Qatomic,V,V) :- atomic(Atomic),!,
     c_post_atomic(Atomic,Qatomic).
c_post([A|B],[AA|BB], V0, V) :- !, 
	c_post(A,AA,V0,V1),c_post(B,BB,V1,V).
c_post((A,B),(AA,BB), V0, V) :- !, 
	c_post(A,AA,V0,V1),c_post(B,BB,V1,V).
% Special Hack.... ( nonvar for C-Prolog)
c_post('r_eq'(A,B,Q1,Q2), B1=A1, V0, V) :- nonvar(A),nonvar(B),
	functor(A,'$CNT',_),functor(B,'$CNT',_),!,
	c_post(A,A1,V0,V1),c_post(B,B1,V1,V2),
	c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V),Q11=Q12.
c_post('r_eq'(A,B,Q1,Q2), 'r_eqn'(B1,A1,Q11,Q12), V0, V) :- nonvar(A),
	functor(A,'$CNT',_),!,
	c_post(A,A1,V0,V1),c_post(B,B1,V1,V2),
	c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V).
c_post('r_eq'(A,B,Q1,Q2), 'r_eqn'(A1,B1,Q11,Q12), V0, V) :- nonvar(B),
	functor(B,'$CNT',_),!,
	c_post(A,A1,V0,V1),c_post(B,B1,V1,V2),
	c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V).
c_post('r_eq'(A,B,Q1,Q2), 'r_eq'(A1,B1,Q11,Q12), V0, V) :- !,
	c_post(A,A1,V0,V1),c_post(B,B1,V1,V2),
	c_post(Q1,Q11,V2,V3),c_post(Q2,Q12,V3,V).
c_post(X, XX, V0, V) :- 
    functor(X, F, A), c_post_atomic(F,F1),!, functor(XX, F1, A), 
    c_post_args(0, A, X, XX, V0, V). 

c_post_atomic(X,X).
% c_post_atomic([],[]) :- !.
% c_post_atomic(Number,Number) :- number(Number),!.
% c_post_atomic(Atomic,Qatomic):-
%     name(Atomic,La),La=[H|_],[H]\="'",[H]\="_",!,
%     concatenate(["'",La,"'"],Nla),name(Qatomic,Nla).
% c_post_atomic(Atomic,Atomic).

c_post_args(N, N, _, _, V, V) :- !. 
c_post_args(K, N, X, XX, V0, V) :- 
    K1 is K+1, arg(K1, X, XK), c_post(XK, XXK, V0, V1), arg(K1, XX, XXK), 
    c_post_args(K1, N, X, XX, V1, V). 
 
c_post_tvar(X, Now, Nxt, '$t'(Now1,Nxt1), V0, V) :- var(X),!,
    X='$TMP'(_,Now,Nxt),
    c_post(Now, Now1, V0, V1),
    c_post(Nxt, Nxt1, V1, V).
c_post_tvar('$REF'(X), _Now, _Nxt, XX, V0, V) :- !,
    c_post(X, XX, V0, V).
c_post_tvar('$CNT'(X), _Now, _Nxt, XX, V0, V) :- !,
    c_post(X, XX, V0, V).
c_post_tvar('$TMP'(X,Now,Nxt), Now, Nxt, XX, V0, V) :- !,
    c_post_tvar(X, Now, Nxt, XX, V0, V).

write_clause(X) :- recorded('r_assert',_,_),assert_clause0(X).
write_clause(_) :- recorded('r_assert',_,_).
write_clause(X) :- write_clause0(X).
write_clause(_).

write_clause0((X:-true)) :- 
    c_post(X, XX, 0, _), 
    write_term(XX,[numbervars(true),quoted(true)]),
    % writeq(XX), 
    put("."), nl,!,fail. %%% writeq --> write
write_clause0(X) :- 
    c_post(X, XX, 0, _), writeq1(XX), put("."), nl,!,fail. %%% writeq --> write

% a little pretty print
writeq1((A,B)) :- !,writeq1(A),put("."), nl,
    writeq1(B).
writeq1((H:-B)) :- !,
    % writeq(H),
    write_term(H,[numbervars(true),quoted(true)]),
    write((:-)),
    writeq2(B).
writeq1(X) :- 
    % writeq(X).
    write_term(X,[numbervars(true),quoted(true)]).
writeq2((A,B)) :- !,nl,tab(4),
    % writeq(A),
    write_term(A,[numbervars(true),quoted(true)]),
    put(","),writeq2(B).
writeq2(X) :- nl,tab(4),
    write_term(X,[numbervars(true),quoted(true)]).
    % writeq(X).


assert_clause(X) :- assert_clause0(X).
assert_clause(_).

%assert_clause0((X:-true)) :- 
%    c_post(X, XX, 0, _), c_melt(XX,XXX,_),
%    recorda('r_run',XXX,Ref),assertz(XXX), !,fail. 
assert_clause0(X) :- 
    c_post(X, XX, 0, _), c_melt(XX,((XXX:-Y)),_),
    recorda('r_run',((XXX:-_)),_Ref),assertz((XXX:-Y)), !,fail. 

/* end  */