--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/th.pl	Thu Aug 30 14:57:44 2007 +0900
@@ -0,0 +1,192 @@
+/*
+ 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 to Prolog compiler
+%%
+%%    variable classification and head compile
+%%
+%%
+%% Sat Jan 11 11:31:10 JST 1986
+%% $Header$
+
+c_equate(EE,EE) :-!.
+c_equate('$CNT'(EE),EE) :-!.
+c_equate(EE,'$CNT'(EE)) :-!.
+
+%% variable separation for temporality
+
+c_seperate(Var,Now,Next) :- Var = '$TMP'(_,Now,Next),!.
+c_seperate(Var,Var,'$CNT'(Var1)) :- Var = '$CNT'(Var1),!.
+c_seperate(Var,Now,Next) :- Var = '$NOW'(Var1,Now),!,
+    c_seperate(Var1,Now,Next).
+c_seperate(Var,Now,Next) :- Var = '$NXT'(Var1,Next),!,
+    c_seperate(Var1,Now,Next).
+c_seperate(Atomic,Atomic,Atomic) :- atomic(Atomic),!.
+c_seperate(Op, Op1, Op2) :- 
+    functor(Op, H, N),functor(Op1, H, N),functor(Op2, H, N),
+    c_seperate_arg(0, N, Op, Op1, Op2).
+
+c_seperate_arg(N, N, _, _, _) :- !.
+c_seperate_arg(M, N, Op, Op1, Op2) :-
+    M1 is M+1,arg(M1, Op, A), arg(M1, Op1, A1),arg(M1, Op2, A2),
+    c_seperate(A,A1,A2),
+    c_seperate_arg(M1, N, Op, Op1, Op2).
+
+
+c_seperate_now(Var,Now) :- Var = '$NOW'(_,Now),!.
+c_seperate_now(Var,Var) :- Var = '$CNT'(_Var1),!.
+c_seperate_now(Var,Now) :- Var = '$TMP'(_,Now,_Next),!.
+c_seperate_now(Var,Now) :- Var = '$NXT'(Var1,Next),!,
+    c_seperate(Var1,Now,Next).
+c_seperate_now(Atomic,Atomic) :- atomic(Atomic),!.
+c_seperate_now(Op, Op1) :- 
+    functor(Op, H, N),functor(Op1, H, N),
+    c_seperate_now_arg(0, N, Op, Op1).
+
+c_seperate_now_arg(N, N, _, _) :- !.
+c_seperate_now_arg(M, N, Op, Op1) :-
+    M1 is M+1,arg(M1, Op, A), arg(M1, Op1, A1),
+    c_seperate_now(A,A1),
+    c_seperate_now_arg(M1, N, Op, Op1).
+
+c_seperate_next(Var,Next) :- Var = '$NXT'(_,Next),!.
+c_seperate_next(Var,'$CNT'(Var1)) :- Var = '$CNT'(Var1),!.
+c_seperate_next(Var,Next) :- Var = '$TMP'(_,_Now,Next),!.
+c_seperate_next(Var,Next) :- Var = '$NOW'(Var1,Now),!,
+    c_seperate(Var1,Now,Next).
+c_seperate_next(Atomic,Atomic) :- atomic(Atomic),!.
+c_seperate_next(Op, Op1) :- 
+    functor(Op, H, N),functor(Op1, H, N),
+    c_seperate_next_arg(0, N, Op, Op1).
+
+c_seperate_next_arg(N, N, _, _) :- !.
+c_seperate_next_arg(M, N, Op, Op1) :-
+    M1 is M+1,arg(M1, Op, A), arg(M1, Op1, A1),
+    c_seperate_next(A,A1),
+    c_seperate_next_arg(M1, N, Op, Op1).
+
+% c_unify(Original_argument, Generated_argument, Unification_code, ItsBase, 
+%         Level). 
+%	Tokio has same problem as ghc. f(X,X) must be comipled into
+%	f(X, Y) :- unify(X, Y).
+c_unify(X, Y, Q, Q, _) :-  
+     var(X), !, X= '$REF'(Y).   % mark X as "used!" 
+c_unify('$REF'(X), Y, (unifyAll(X, Y),Q), Q, _) :- !. 
+% c_unify('$CNT'(X), X, Q, Q, _) :- !. 
+c_unify('$CNT'(X), Y, (uconst(Y,X),Q), Q, _) :- !. 
+c_unify('$TMP'(Org,Now,Next), Org1, Q1, Q, L) :- !,
+    c_nownext(Org, Org1, Now, Next, Q1, Q, L).
+c_unify('$NOW'(Org,Now), Org1, Q1, Q, L) :- !,
+    c_now(Org, Org1, Now, Q1, Q, L).
+c_unify('$NXT'(Org,Next), Org1, Q1, Q, L) :- !,
+    c_next(Org, Org1, Next, Q1, Q, L).
+c_unify([], X, (unil(X),Q), Q, _) :- !. 
+c_unify(A, X, (uatom(X, A),Q), Q, _) :- atomic(A), !. 
+c_unify(X, Y, (unifyAll(X, Y),Q), Q, 0) :- !. % Stop expansion at given level 
+c_unify([H|T], X, (ulist(X, H0, T0), Q1), Q, L) :- !, 
+    L1 is L-1, c_unify(H, H0, Q1, Q2, L1),  
+    c_unify(T, T0, Q2, Q, L1). 
+c_unify(S, X, Q1, Q, L) :-  		% compile unification
+    functor(S, F, A), A < 4, !, functor(S0, F, A), 
+    make_skel_name(F, Us, A),
+    c_skel(Us, S0, X, F, A, Q1, Q2, L), 
+    L1 is L-1,
+    c_unify_args(0, A, S, S0, Q2, Q, L1). 
+c_unify(S, X, (uskel(X, S0), Q1), Q, L) :- !, 
+    L1 is L-1, functor(S, F, A), functor(S0, F, A), 
+    c_unify_args(0, A, S, S0, Q1, Q, L1). 
+ 
+c_unify_args(N, N, _, _, Q, Q, _) :- !. 
+c_unify_args(K, N, S, X, Q1, Q, L) :- 
+    K1 is K+1, arg(K1, S, SK), arg(K1, X, XK),  
+    c_unify(SK, XK, Q1, Q2, L), 
+    c_unify_args(K1, N, S, X, Q2, Q, L). 
+
+% compile skelton unifications
+%
+%	f(_,_,_) ---> 'r_f3'
+
+make_skel_name(F, U, A) :-
+    name(A, AL), name(F, FL), 
+%    concatenate(["'r_",FL,AL,"'"], UL),
+    concatenate(["r_",FL,AL], UL),		%%%%%%%%%%%%%%%%%
+    name(U, UL).
+
+concatenate([],[]).
+concatenate([H|T],X) :- concatenate(T,X1),append(H,X1,X).
+
+c_skel(U, S, X, _F, A, (Uc,Q), Q, _L) :- recorded('$uskel',U,_),!,
+    A1 is A+1, functor(Uc, U, A1), 
+    arg(1, Uc, X),
+    c_skel_copy_arg(0, 1, A1, S, Uc).
+c_skel(U, S, X, F, A, (Uc,Q), Q, _L) :- recordz('$uskel',U,_),!,
+    A1 is A+1, functor(Uc, U, A1),
+    arg(1, Uc, X),
+    c_skel_copy_arg(0, 1, A1, S, Uc),
+    functor(U1, U, A1), functor(Us, F, A),
+    c_skel_copy_arg(0, 1, A1, Us, U1),
+    arg(1, U1, Us),
+    write_clause((U1 :- !)),
+    functor(U2, U, A1), functor(Us2, F, A), functor(Un, U, A1),
+    c_skel_copy_arg_tmp(0, 1, A1, Us2, U2, Un),
+    arg(1, U2, '$t'(Us2, N)),
+    arg(1, Un, N),
+    write_clause((U2 :- Un)).
+
+
+c_skel_copy_arg(_L, N, N, _A, _B) :- !.
+c_skel_copy_arg(L, N, M, A, B) :-
+    L1 is L+1, N1 is N+1,
+    arg(L1, A, Arg), arg(N1, B, Arg),
+    c_skel_copy_arg(L1, N1, M, A, B).
+
+c_skel_copy_arg_tmp(_L, N, N, _A, _B, _C) :- !.
+c_skel_copy_arg_tmp(L, N, M, A, B, C) :-
+    L1 is L+1, N1 is N+1,
+    arg(L1, A, Now), arg(N1, B, '$t'(Now,Next)), arg(N1, C, Next),
+    c_skel_copy_arg_tmp(L1, N1, M, A, B, C).
+% optimiser check variables
+%	now only referenced	unifyNow
+%	next only referenced	unifyNext
+%	both referenced		unifyNowNext
+%
+%	if already referenced then product unifyAll code
+%
+%    c_now/next(Org, Modyfied, Now/Next, Q1, Q),
+
+c_nownext(Org, Org1, Now, Next, (unifyNowNext(Org1,Now,Next1),Q1), Q, L) :- 
+    var(Org),!,Org = '$REF'(Org1),
+    c_unify(Next,Next1, Q1, Q, L).
+c_nownext('$REF'(O2), O, _Now, _Next, (unifyAll(O2,O),Q), Q, _L).
+
+c_now(Var, Var1, Now, (unifyNow(Var1,Now), Q), Q, _L) :- var(Var),!,
+    Var = '$REF'(Var1).
+c_now('$REF'(O2), O, _Now, (unifyAll(O2,O),Q), Q, _L) :- !.
+c_now('$TMP'(O,Now,Next), O1, Now, Q, Q1, L) :- 
+    c_nownext(O, O1, Now, Next, Q, Q1, L).
+
+c_next(Var, Var, Next, (unifyNext(Var1,Next1), Q), Q1, L) :- var(Var),!,
+    Var = '$REF'(Var1),
+    c_unify(Next,Next1, Q, Q1, L).
+c_next('$REF'(O2), O, _Next, (unifyAll(O2,O),Q), Q, _L) :- !.
+c_next('$TMP'(O,Now,Next), O1, Next, Q, Q1, L) :-
+    c_nownext(O, O1, Now, Next, Q, Q1, L).
+
+
+% c_opt(Before, After, Optimized_or_not) 
+c_opt(X,X,0) :- var(X),!.
+c_opt((true, X), Y, 1) :- !, c_opt(X, Y, _). 
+c_opt((X0, true), X, 1) :- !, c_opt(X0, X, _). 
+c_opt((X0, Y0), R, C) :- !, 
+    c_opt(X0, X1, CX), c_opt(Y0, Y1, CY), C0 is CX\/CY, 
+  ( C0 =:= 0, !, C is C0, R = (X1, Y1);  
+    c_opt((X1, Y1), R, C) ).            % X1/Y1 may be optimized to 'true' 
+c_opt(X, X, 0). 
+ 
+/* end of compiler */