/****************************************************************
**
**	File		: system.clpr
**	Module		: system
**	Language	: clpr version 1.2
**	Purpose		: System predicate extension for CLP(R)
**	Revision	: 2.0a 07/07/93
**	Copyright	: (C) 1991-1993 K J Dryllerakis
**			   Permission is granted to copy, use and
**			   modify this file as long as the header 
**			   and copyright notice remains in place
**
******************************************************************/

/*	Startup Messages	*/

?-printf("\nCLP(R) System Extension (Module system):\n ",[]).

/*	Run time definitions	*/

?-dynamic('  find all',1), dynamic('  all found3',3).

?-op(37,xfx,\==).	% Not unifiable
?-op(900,xfx,--).	% for difference lists

/****************************************************************
**
**	writesq/2: write on the same line
**
******************************************************************/

?-printf("\r writeseq/2",[]).
writeseq(X,Y):-
	printf("\r                                          \r",[]),
	printf(X,Y).
::-prot(writeseq,2).

/****************************************************************
**
**	find_all/3: all solutions predicate
**
******************************************************************/

?-writeseq("findall/3",[]).
find_all(Te,En,Li):-
	asserta('  find all'([])),
	call(En),
	asserta('  find all'('  wrap'(Te))),
	fail;
	'  all found'([],Li).

'  all found'(SoFar,List):-
	'  ##get retract'(Item),
	!,
	'  all found3'(Item,SoFar,List).

'  all found3'([],List,List).

'  all found3'('  wrap'(Te),SoFar,List):-
	'  all found'([Te|SoFar],List).

'  ##get retract'('  wrap'(X)):-
	retract('  find all'('  wrap'(X)):-W),
	realterm(X), % Do we really want to restrict X? If this retract works
		 % it means that X has constraints W i.e. it should be real
		 % in that case the returned variable in find_all should be
		 % real as well.
	call(eval(W)).
'  ##get retract'(X):-
	retract('  find all'(X)).
/****************************************************************
**
**	real_term/1: Check if all the variables in a term are real
**
******************************************************************/

::-writeseq("realterm/1",[]).
realterm(X):-
	varsin(X,W),
	'  ##all real'(W),!.

realterm(X):-
	real(X).
'  ##all real'([X]):-
	real(X).
'  ##all real'([X|Xs]):-
	real(X),
	'  ##all real'(Xs).

::-prot(find_all,3).
%::-prot('  find all',1).
::-prot('  all found3',3), prot('  all found',2). 
::-prot('  ##get retract',1).
::-prot('  ##all real',1),prot(realterm,1).

/****************************************************************
**
**	\==/2: check if two terms are not unifiable
**
******************************************************************/

::-writeseq("\\==/2",[]).
A \== A:-
	!,
	fail.

_ \== _.
::-prot('\==',2).

/****************************************************************
**
**	varsin/2: standard varsin predicate
**
******************************************************************/

::-writeseq("varsin/2",[]).

varsin(Term,Vars):-
        '  ##varsin'(Term,Vs,[]),
        '  ##removedoubles'(Vs,Vars),!.

'  ##varsin'(Term,[Term|Rest],Rest):-
        var(Term),!.

'  ##varsin'(Term,List,Rest):-
        (functor(Term,_,N);
	 atomic(Term),
	 N=0),
        '  ##varsin'(N,Term,List,Rest).

'  ##varsin'(N,_,S,S):-
        N=0,!.

'  ##varsin'(N,Term,S0,S):-
        arg(N,Term,Arg),
        '  ##varsin'(Arg,S0,S1),
        M=N-1,
        '  ##varsin'(M,Term,S1,S).
'  ##removedoubles'(X,Y):-'  ###removedoubles'(X,Y,[]).

'  ###removedoubles'([],Y,Y).
'  ###removedoubles'([X|Rest],List,Built):-
        ('  ##inlist'(X,Built) ->
        '  ###removedoubles'(Rest,List,Built);
        '  ###removedoubles'(Rest,List,[X|Built])
        ).

'  ##inlist'(X,[Y|_]):- X == Y.
'  ##inlist'(X,[_|Z]):-
        '  ##inlist'(X,Z).
::-prot(varsin,2).
::-prot('  ##varsin',3).
::-prot('  ##varsin',4).
::-prot('  ##removedoubles',2).
::-prot('  ###removedoubles',3).
::-prot('  ##inlist',2).

/****************************************************************
**
**	unify/2 : simple unificatio predicate
**
******************************************************************/

?-writeseq("unify/2",[]).
unify(X,X).

::-prot(unify,2).

/****************************************************************
**
**	<>/2 : two numbers are not equal
**
******************************************************************/

?-writeseq("<>/2",[]).

?-op(40,xfx,<>).

X <> Y :-
	(X<Y;
	Y<X).

::-prot('<>',2).

/****************************************************************
**
**	copy/2 : term copying
**
******************************************************************/

?-dynamic('  ##????',1).
/*?-prot('  ##????',1).*/

:-writeseq("copy/2",[]).

copy(Term1,Term2):-
	assert('  ##????'(Term1)),
	(retract('  ##????'(Term2):-_);
	retract('  ##????'(Term2))).
::-prot(copy,2).

/****************************************************************
**
**	copy_replace/2 : term copying
**
******************************************************************/

?-writeseq("copy_replace",[]).

copy_replace(X,Term1,Y,Term2):-
	varsin(Term1,Vars1),
	copy(Term1,Term2),
	varsin(Term2,Vars2),
	'  ##bind special list'(X,Vars1,Y,Vars2).

'  ##bind special list'(_,[],_,[]).
'  ##bind special list'(X,[V1|V1s],Y,[V2|V2s]):-
	('  ##in list ret'(X,V1,Y,RetY) ->
		unify(RetY,V2);
		unify(V1,V2)),
	'  ##bind special list'(X,V1s,Y,V2s).

'  ##in list ret'([X|_],V1,[Y|_],Y):- X == V1.
'  ##in list ret'([_|Xs],V1,[_|Ys],RetY):-
	'  ##in list ret'(Xs,V1,Ys,RetY).

::-prot(copy_replace,4).
::-prot('  ##in list ret',4),prot('  ##bind special list',4).

/****************************************************************
**
**	Identification of this file
**
******************************************************************/
'  ##system loaded'.
::-prot('  ##system loaded',0).
::-writeseq("done.\n",[]).