% prolog.boo/Initial boot file for building the Prolog Interp../Ahmed Aberkane

% Acknowledgement : This code is based on an interpreter developed at the 
% Department  of  Artificial  Intelligence, University of Edinburgh .


                         % Atoms that the code requires
[].
','.
'{}'.
end_of_file.
true.
user.
$live.
$break.
< .
= .
> .
$yes.
$no.
- .
; .

                         % Functors that the code requires
call(_).
','(_,_).
'{}'(_).
'.'(_,_).
':-'(_,_).
':-'(_).
$hidden_call(_).
$hidden_term(_).

			% Terms that the code requires

% The first term is List10 which must be constructed specially 

$ttynl,$csult(0,user).

                         % And now we start properly

         % Predicates are attached to evaluable predicates defined in the
         % code by one of two methods:
         %
         %       1) pred(....) :- N.
         %       2)  :- $sysp(pred(....),N).
         %
         %               where N is an integer specifying the evaluable 
         % predicate - N is the value of the switch label in "main.c".
         % The difference between these is that with the first method a
	 % (local) frame will be built which will contain the arguments to the
         % procedure; whereas in the second case no frame is built.

                         % Set up the Operators

 :-(op(P,T,A),76).

 :-(op(1200,fx,[ :- , ?- ])).
 :-op(1200,xfx,[ (:-) , --> ]).
 :-op(1100,xfy,';').
 :-op(1050,xfy,'->').
 :-op(1000,xfy,',').
 :-op(900,fy,[ \+ , not , spy , nospy ]).
 :-op(700,xfx,[ =, is, =.. , ==, \==, @<, @>, @=<, @>=, =:=, =\=, <, > , =<, >= ]).
 :-op(500,yfx,[+,-,/\,\/]).
 :-op(500,fx,[(+),(-),\]).
 :-op(400,yfx,[*,/,//,<<,>>]).
 :-op(300,xfx,[mod]).
 :-op(200,xfy,'^').


                         % And now all the evaluable predicates

 $sysp(F,N) :- 100.
 $sysflgs(F,N) :- 101.
 $hide_atom(A) :- 171.

 :-$sysp((A,B),6).
call(P) :- 1.
:-$sysp($hidden_call(P),121).
:-$sysp(!,2).
true.
 repeat :- 3.
 :-$sysp(abort,4).
 :-$sysp($call(_),5).

$not(X) :- $user_call(X), !, fail.
$not(X).

\+(X) :- $not(X).
not(X) :- $not(X).

(A -> B ; C) :- !, $cond(A,B,C).

         $cond(A,B,C) :- $user_call(A), !, $user_call(B).
         $cond(A,B,C) :- $user_call(C).

(A;B) :- $call(A).
(A;B) :- $call(B).
(A -> B) :- $user_call(A), !, $user_call(B).

 see(F) :- 10.
 seeing(F) :- 11.
 seen :- 12.
 tell(F) :- 13.
 append(F) :- 174.
 telling(F) :- 14.
 told :- 15.
 close(F) :- 16.
 read(T) :- 17.
 write(T) :- 18.	display(T) :- 274.	% + 256
 nl :- 19.		ttynl :- 275.		$ttynl :- 275.
 get0(C) :- 20.		ttyget0(C) :- 276.
 get(C) :- 21.		ttyget(C) :- 277.
 skip(C) :- 22.		ttyskip(C) :- 278.
 put(C) :- 23.		ttyput(C) :- 279.
 tab(C) :- 24.		ttytab(C) :- 280.
 fileerrors :- 25.
 nofileerrors :- 26.
 rename(F,F1) :- 27.
 writeq(T) :- 28.
 sh :- 29.
 system(S) :- 30.

print(V) :- var(V), !, write(V).

print(X) :- portray(X), !.

print(X) :- write(X).

			% define arithmetic operators

			% nullary ops

  :-$sysflgs(cputime,1).
  :-$sysflgs(heapused,2).
  :-$sysflgs(breaklevel,3).
				% unary operations

  :-$sysflgs([A|B],1).
  :-$sysflgs(+(A),1).
  :-$sysflgs(-(A),2).
  :-$sysflgs(\(A),3).
  :-$sysflgs(exp(A),4).
  :-$sysflgs(log(A),5).
  :-$sysflgs(log10(A),6).
  :-$sysflgs(sqrt(A),7).
  :-$sysflgs(sin(A),8).
  :-$sysflgs(cos(A),9).
  :-$sysflgs(tan(A),10).
  :-$sysflgs(asin(A),11).
  :-$sysflgs(acos(A),12).
  :-$sysflgs(atan(A),13).
  :-$sysflgs(floor(A),14).

				% binary operations
  :-$sysflgs(A+B,1).
  :-$sysflgs(A-B,2).
  :-$sysflgs(A*B,3).
  :-$sysflgs(A/B,4).
  :-$sysflgs(A mod B,5).
  :-$sysflgs(A /\ B,6).
  :-$sysflgs(A\/B,7).
  :-$sysflgs(A<<B,8).
  :-$sysflgs(A>>B,9).
  :-$sysflgs(A//B,10).
  :-$sysflgs(A^B,11).

% Unary predicates

'$+'(A,X) :- 131.
'$-'(A,X) :- 132.
'$\'(A,X) :- 133.
$exp(A,X) :- 134.
$log(A,X) :- 135.
$log10(A,X) :- 136.
$sqrt(A,X) :- 137.
$sin(A,X) :- 138.
$cos(A,X) :- 139.
tan(A,X) :- 140.
$asin(A,X) :- 141.
$acos(A,X) :- 142.
$atan(A,X) :- 143.
$floor(A,X) :- 144.

% Binary operations

'$+'(A,B,X) :- 151.
'$-'(A,B,X) :- 152.
'$*'(A,B,X) :- 153.
'$/'(A,B,X) :- 154.
$mod(A,B,X) :- 155.
'$/\'(A,B,X) :- 156.
'$\/'(A,B,X) :- 157.
'$<<'(A,B,X) :- 158.
'$>>'(A,B,X) :- 159.
'$//'(A,B,X) :- 160.
'$^'(A,B,X) :- 161.

X is Y :- 40.
X =:= Y :- 41.
X =\= Y :- 42.
X < Y :- 43.
X > Y :- 44.
X =< Y :- 45.
X >= Y :- 46.

var(X) :- 50.
nonvar(X) :- 51.
integer(X) :- 52.
number(X) :- 91.
atomic(X) :- 53.
atom(X) :- 59.
primitive(X) :- 118.
db_reference(X) :- 119.

statistics :- 93.

prompt(_,_) :- 31.
exists(user) :- !.
exists(_) :- 32.
$save(F,I) :- 33.

save(F) :- $save(F,_).
save(F,I) :- $save(F,I).

X=X.
functor(T,F,N) :- 56.
arg(N,T,A) :- 57.
X=..L :- 58.
name(X,L) :- 75.

A == B :- 54.
A \== B :- 55.
A @< B :- 86.
A @> B :- 87.
A @=< B :- 88.
A @>= B :- 89.

clause(P,Q) :-  !, $checkkey(P), $clause((P:-Q),R,P).
clause(P,Q,R) :- var(R), !, $checkkey(P), $clause((P:-Q),R,P).
clause(P,Q,R) :- instance(R,(P:-Q)).
assert(C) :- 61.     assertz(C) :- 61.
asserta(C) :- 62.
assert(C,R) :- 63.     assertz(C,R) :- 63.
asserta(C,R) :- 64.
$clause(_,_,_) :- 65.     $clause(_,_,_):-66.

retract(C) :- $retract(C).

$retract(V) :- var(V), !, fail.
$retract( (Head :- Body) ) :-
        !,
        clause(Head,Body,ID),
        erase(ID).
$retract( UnitClause ) :-
        clause(UnitClause,true,ID),
        erase(ID).

abolish(Pred,Arity) :- 173.

$recorded(_,_,_) :- 67.    $recorded(_,_,_):-68.
recorded(K,T,R) :- $checkkey(K), $recorded(T,R,K).
$checkkey(K) :- (var(K);primitive(K)),!,
      ttynl,display('! invalid key to data base'),ttynl,trace,fail.
$checkkey(_).
recorda(K,T,R) :- $checkkey(K), $recorda(K,T,R).
recordz(K,T,R) :- $checkkey(K), $recordz(K,T,R).
$recorda(_,_,_) :- 73.
$recordz(_,_,_) :- 74.
instance(R,T) :- 69.
erase(R) :- 60.
erased(R) :- 92.

$leash(P,N) :- 78.
$debug(P,N) :- 79.
current_atom(A) :- 80.
current_atom(A) :- 81.
$current_functor(A,N,K,M) :- 82.
$current_functor(A,N,K,M) :- 83.
current_functor(A,P) :- nonvar(P),!, functor(P,A,_).
current_functor(A,P) :-
        current_atom(A),
        $current_functor(A,N,0,0),
        functor(P,A,N).
current_predicate(A,P) :-
        current_atom(A),
        $current_functor(A,N,256,2'11100000),
        functor(P,A,N).

$flags(F,P,N) :- 84.
compare(Op,T1,T2) :- 85.
trace :- 72.

'NOLC'  :-  70.
'LC'  :-  71.

                         % Various hacky system predicates

 :-$sysp($break(_),102).
 :-$sysp($exit_break,103).
 $prompt(_) :- 104.
 $user_exec(_) :- 105.
 :-$sysp($save_read_vars,106).
 :-$sysp($reset_read_vars,107).
 :-$sysp($repply,108).
 $recons(_) :- 109.
 :-$sysp($break_start,110).
 :-$sysp($break_end,111).
 $assertr(_) :- 112.
 :-$sysp($rest_in_peace,113).
 $user_call(_) :- 114.
 $repeat :- 3.
 $read(X) :- 17.

                          % How to get out (various mnemonics)

  :- $sysp(halt,113).

%-----------------------------------------------------------------------

%    Interpreter control

$live:- $cycle(0), $rest_in_peace.     % this is the Prolog session goal

$cycle(0):-
      prompt(Old,'|    '),
      $repeat,
        $prompt('| ?- '), $read(C),
        $interpret(C,0),
      prompt(_,Old),
      !.

$cycle(Status):-
      prompt(Old,'| '),
      $repeat,
        $read(C),
        $interpret(C,Status),
      prompt(_,Old),
      !.

$interpret(C,Status) :-
      var(C),
      !,
      display('! Statement is a variable'), 
      ttynl,
      fail.

$interpret(end_of_file,_):-!.

$interpret(C,Status):-
      $directive(C,Status,D,T),
      !,
      prompt(Old,'|: '),
      $dogoal(T,D),
      prompt(_,Old),
      fail.

$interpret(C,Status):-
      expand_term(C,C1),
      $assert(C1),
      !,
      fail.

$assert(C):-$assertr(C),!.
$assert(C):-
      seeing(user),
      !.
$assert(C):-
      display('! clause: '),
      display(C).

$directive(:-(X),_,X,command) :- !.
$directive(?-(X),_,X,question) :- !.
$directive(X,0,X,question).

$dogoal(command,C) :-
      $user_exec(C),
      !.

$dogoal(command,_) :-
      !,
      ttynl, display('?'),
      ttynl.

$dogoal(question,Q) :-
      $save_read_vars,
      $user_exec(Q),
      $repply,
      ttynl,
      $show_break_level,
      display(yes),
      $reset_read_vars,
      ttynl,
      !.

$dogoal(question,_) :-
      ttynl,
      $show_break_level,
      display(no),
      $reset_read_vars,
      ttynl,
      !.


/*  consult and reconsult  */

consult(X):-!, $break($csult(0,X)).

reconsult(X) :- $break($csult(1,X)).

[X|Rest] :- $conlist([X|Rest]).

         $conlist([]) :- !.
         $conlist([-X|Rest]) :- !, reconsult(X), $conlist(Rest).
         $conlist([X|Rest]) :- !, consult(X), $conlist(Rest).


$csult(R,F) :-
      S0 is heapused,
      T0 is cputime,
      $recons(R),
      $checkfile(F),
      $read_file(F,consult),
      Tt is cputime-T0,
      Ts is heapused-S0,
      display(F), $dpr(R), display(Ts), display(' bytes '),
      display(Tt), display(' sec.'), ttynl,
      fail.
$csult(R,F) :- $exit_break.

$dpr(0) :- !, display(' consulted ').
$dpr(1) :- display(' reconsulted ').

$read_file(F,S) :-
      seeing(I),
      telling(O),
      see(F),
      $cycle(S),
      close(F),
      see(I),
      tell(O),
      fail.
$read_file(_,_).

$checkfile(F) :-
      (atom(F);
        ttynl, display('! Invalid file name: '),
        display(F), ttynl, fail
      ),
      !,
      (exists(F);
        ttynl, display('! The file '), display(F),
        display(' does not exist.'), ttynl, fail
      ),
      !.

/* break      */

break :- $break($break).

$break :-
      $break_start,
      $read_file(user,0),
      $break_end,
      $exit_break.
$break :- $exit_break.    % just to make sure

$show_break_level :-
   B is breaklevel,
   $shb(B).

$shb(0) :- !.
$shb(N) :- ttyput("["), display(N), ttyput("]"), ttyput(" ").

/* Arithmetic expansion */

expand_exprs(X,Y) :-
   $carith(X0,X0),
   $flag_code(X0,X),
   nonvar(Y),
   $flag_code(Y0,Y),
   $carith(_,Y0).

$carith(X,Y) :- 170.

$isop(A,P,M,L,R) :- 172.

current_op(Prio,Type,Atom) :-
   $gen_atom(Atom),
   $gen_pos(Type,Pos),
   $isop(Atom,Pos,Prio,Left,Right),
   $op_code(Type,Pos,Prio,Left,Right).

$gen_atom(Atom) :- atom(Atom), !.
$gen_atom(Atom) :- var(Atom), !, current_atom(Atom).

$gen_pos(Type,Pos) :-
   atom(Type), !,
   $type_to_pos(Type,Pos,_,_,_).
$gen_pos(_,Pos) :-
   $op_pos(Pos).

$op_code(Type,Pos,Prio,Left,Right) :-
   $type_to_pos(Type,Pos,Prio,LeftExpr,RightExpr),
   Left is LeftExpr, Right is RightExpr, !.

$op_pos(0).	% PREFIX (must be the same as in rewrite.c)
$op_pos(1).	% INFIX
$op_pos(2).	% POSTFIX

$type_to_pos(fx,0,Prio,Prio,Prio-1).
$type_to_pos(fy,0,Prio,Prio,Prio).
$type_to_pos(xfx,1,Prio,Prio-1,Prio-1).
$type_to_pos(xfy,1,Prio,Prio-1,Prio).
$type_to_pos(yfx,1,Prio,Prio,Prio-1).
$type_to_pos(yf,2,Prio,Prio,Prio).
$type_to_pos(xf,2,Prio,Prio-1,Prio).

all_float(X,Y) :-
   $all_float(X0,X0),
   $flag_code(X0,X),
   nonvar(Y),
   $flag_code(Y0,Y),
   $all_float(_,Y0).

$all_float(X,Y) :- 90.

$flag_code(1,on).
$flag_code(0,off).

expand_term(T0,T) :-
   term_expansion(T0,T1), !,
   $expand_term(T1,T).
expand_term(T0,T) :- $expand_term(T0,T).

$expand_term(T0,T) :- $translate_rule(T0,T), !.
$expand_term((H:-B0),(H:-B)) :- $compile_arith(B0,B), !.
$expand_term(T,T).




/* pl/arith: preprocess arithmetic expressions */

$compile_arith(P0,P) :-
   $carith(1,1), !,
   $expand_arith(P0,P).
$compile_arith(P,P).

$expand_arith(P,P) :- var(P), !.
$expand_arith(P0,P) :- $expand_arith0(P0,P).

$expand_arith0((P0,Q0),(P,Q)) :- !,
   $expand_arith(P0,P),
   $expand_arith(Q0,Q).
$expand_arith0((P0;Q0),(P;Q)) :- !,
   $expand_arith(P0,P),
   $expand_arith(Q0,Q).
$expand_arith0(X is Y, X is Y) :- var(Y), !.
$expand_arith0(X is Y, P) :- !,
   $expand_expression(Y,P0,X0),
   $drop_is(X0,X,P1),
   $and(P0,P1,P).
$expand_arith0(Comp0,R) :-
   functor(Comp0,Op,2),
   $comp_op(Op), !,
   arg(1,Comp0,E),
   arg(2,Comp0,F),
   functor(Comp,Op,2),
   arg(1,Comp,U),
   arg(2,Comp,V),
   $expand_expression(E,P,U),
   $expand_expression(F,Q,V),
   $and(P,Q,R0),
   $and(R0,Comp,R).
$expand_arith0(P,P).

$expand_expression(V,true,V) :- var(V), !.
$expand_expression(A,true,A) :- atomic(A), !.
$expand_expression(T,P,V) :-
   $op_to_pred(T,N,V,P0),
   $expand_expression_args(N,T,P0,true,Q),
   $and(Q,P0,P).

$expand_expression_args(0,_,_,P,P) :- !.
$expand_expression_args(N,T,G,P0,P) :-
   arg(N,T,E),
   arg(N,G,V),
   $expand_expression(E,Q,V),
   M is N-1,
   $and(P0,Q,P1),
   $expand_expression_args(M,T,G,P1,P).

$comp_op(<).
$comp_op(>).
$comp_op(=<).
$comp_op(>=).
$comp_op(=:=).
$comp_op(=\=).

$and(true,P,P) :- !.
$and(P,true,P) :- !.
$and(P,Q,(P,Q)).

$rename_op(Op0,N,Op) :-
   $rename_op0(Op0,N,Op), !.
$rename_op(Op,_,Op).

% Unary operations

$rename_op0(+,1,'$+').
$rename_op0(-,1,'$-').
$rename_op0(\,1,'$\').
$rename_op0(exp,1,$exp).
$rename_op0(log,1,$log).
$rename_op0(log10,1,$log10).
$rename_op0(sqrt,1,$sqrt).
$rename_op0(sin,1,$sin).
$rename_op0(cos,1,$cos).
$rename_op0(tan,1,$tan).
$rename_op0(asin,1,$asin).
$rename_op0(acos,1,$acos).
$rename_op0(atan,1,$atan).
$rename_op0(floor,1,$floor).

% Binary operations

$rename_op0(+,2,'$+').
$rename_op0(-,2,'$-').
$rename_op0(*,2,'$*').
$rename_op0(/,2,'$/').
$rename_op0(mod,2,$mod).
$rename_op0(/\,2,'$/\').
$rename_op0(\/,2,'$\/').
$rename_op0(<<,2,'$<<').
$rename_op0(>>,2,'$>>').
$rename_op0(//,2,'$//').
$rename_op0(^,2,'$^').

$op_to_pred(T,N,V,P) :-
   functor(T,Op0,N),
   $rename_op(Op0,N,Op),
   M is N+1,
   functor(P,Op,M),
   arg(M,P,V).

$drop_is(V,V,true) :- var(V), !.
$drop_is(V,X,X is V).



% grammar: translation of grammar rules - 

$translate_rule((LP-->[]),H) :- !, $t_lp(LP,S,S,H).
$translate_rule((LP-->RP),(H:-B)):-
   $t_lp(LP,S,SR,H),
   $t_rp(RP,S,SR,B1),
   $tidy(B1,B).

$t_lp((LP,List),S,SR,H):- !,
   $append(List,SR,List2),
   $add_extra_args([S,List2],LP,H).

$t_lp(LP,S,SR,H) :- $add_extra_args([S,SR],LP,H).

$t_rp(!,S,S,!) :- !.
$t_rp([],S,S1,S=S1) :- !.
$t_rp([X],S,SR,c(S,X,SR)) :- !.
$t_rp([X|R],S,SR,(c(S,X,SR1),RB)) :- !, $t_rp(R,SR1,SR,RB).
$t_rp({T0},S,S,T) :- !, $compile_arith(T0,T).
$t_rp((T,R),S,SR,(Tt,Rt)) :- !,
   $t_rp(T,S,SR1,Tt),
   $t_rp(R,SR1,SR,Rt).
$t_rp((T;R),S,SR,(Tt;Rt)) :- !,
   $t_or(T,S,SR,Tt),
   $t_or(R,S,SR,Rt).
$t_rp(T,S,SR,Tt) :- $add_extra_args([S,SR],T,Tt).

$t_or(X,S0,S,P) :-
   $t_rp(X,S0a,S,Pa),
 ( var(S0a), S0a \== S, !, S0=S0a, P=Pa;
   P=(S0=S0a,Pa) ).

$add_extra_args(L,T,T1) :-
   T=..Tl,
   $append(Tl,L,Tl1),
   T1=..Tl1.

$append([],L,L) :- !.
$append([X|R],L,[X|R1]) :- $append(R,L,R1).

$tidy((P1;P2),(Q1;Q2)) :- !,
   $tidy(P1,Q1),
   $tidy(P2,Q2).
$tidy(((P1,P2),P3),Q) :- $tidy((P1,(P2,P3)),Q).
$tidy((P1,P2),(Q1,Q2)) :- !,
   $tidy(P1,Q1),
   $tidy(P2,Q2).
$tidy(A,A) :- !.

c([X|S],X,S).


/* setof : 'setof', 'bagof' and sorting. */

:- op(200,xfy,^).

setof(X,P,Set) :-
   $setof(X,P,Set).

$setof(X,P,Set) :-
   $bagof(X,P,Bag),
   sort(Bag,Set0),
   Set=Set0.

bagof(X,P,Bag) :-
   $bagof(X,P,Bag).

$bagof(X,P,Bag) :-
   $excess_vars(P,X,[],L), $nonempty(L), !,
   Key =.. [$|L],
   $bagof(X,P,Key,Bag).
$bagof(X,P,Bag) :-
   $tag('$bag','$bag'),
   $user_call(P),
   $tag('$bag',X),
   fail.
$bagof(X,P,Bag) :- $reap([],Bag), $nonempty(Bag).

$bagof(X,P,Key,Bag) :-
   $tag('$bag','$bag'),
   $user_call(P),
   $tag('$bag',Key-X),
   fail.
$bagof(X,P,Key,Bag) :-
   $reap([],Bags0),
   keysort(Bags0,Bags),
   $pick(Bags,Key,Bag).

$nonempty([_|_]).

$reap(L0,L) :-
   $untag('$bag',X), !,
   $reap1(X,L0,L).

$reap1(X,L0,L) :- X \== '$bag', !, $reap([X|L0],L).
$reap1(_,L,L).

$pick(Bags,Key,Bag) :-
   $nonempty(Bags),
   $parade(Bags,Key1,Bag1,Bags1),
   $decide(Key1,Bag1,Bags1,Key,Bag).

$parade([Item|L1],K,[X|B],L) :- $item(Item,K,X), !,
   $parade(L1,K,B,L).
$parade(L,K,[],L).

$item(K-X,K,X).

$decide(Key,Bag,Bags,Key,Bag) :- (Bags=[], ! ; true).
$decide(_,_,Bags,Key,Bag) :- $pick(Bags,Key,Bag).

$excess_vars(T,X,L0,L) :- var(T), !,
   ( $no_occurrence(T,X), !, $introduce(T,L0,L)
   ; L = L0 ).
$excess_vars(X^P,Y,L0,L) :- !, $excess_vars(P,(X,Y),L0,L).
$excess_vars(setof(X,P,S),Y,L0,L) :- !, $excess_vars((P,S),(X,Y),L0,L).
$excess_vars(bagof(X,P,S),Y,L0,L) :- !, $excess_vars((P,S),(X,Y),L0,L).
$excess_vars(T,X,L0,L) :- functor(T,_,N), $rem_excess_vars(N,T,X,L0,L).

$rem_excess_vars(0,_,_,L,L) :- !.
$rem_excess_vars(N,T,X,L0,L) :-
   arg(N,T,T1),
   $excess_vars(T1,X,L0,L1),
   N1 is N-1,
   $rem_excess_vars(N1,T,X,L1,L).

$introduce(X,L,L) :- $included(X,L), !.
$introduce(X,L,[X|L]).

$included(X,L) :- $doesnt_include(L,X), !, fail.
$included(X,L).

$doesnt_include([],X).
$doesnt_include([Y|L],X) :- Y \== X, $doesnt_include(L,X).

$no_occurrence(X,Term) :- $contains(Term,X), !, fail.
$no_occurrence(X,Term).

$contains(T,X) :- var(T), !, T == X.
$contains(T,X) :- functor(T,_,N), $upto(N,I), arg(I,T,T1), $contains(T1,X).

$upto(N,N) :- N > 0.
$upto(N,I) :- N > 0, N1 is N-1, $upto(N1,I).

/*----------------------------------- */
/* Sorting by bisecting and merging. */

sort(L,R) :- length(L,N), $sort(N,L,_,R1), R=R1.

$sort(2,[X1|L1],L,R) :- !, $comprises(L1,X2,L),
    compare(Delta,X1,X2),
  (Delta = (<) , !, R = [X1,X2]
   ; Delta = (>) , !, R = [X2,X1]
   ; R = [X2]
  ).
$sort(1,[X|L],L,[X]) :- !.
$sort(0,L,L,[]) :- !.
$sort(N,L1,L3,R) :-
   N1 is N//2, N2 is N-N1,
   $sort(N1,L1,L2,R1),
   $sort(N2,L2,L3,R2),
   $merge(R1,R2,R).

$merge([],R,R) :- !.
$merge(R,[],R) :- !.
$merge(R1,R2,[X|R]) :-
   $comprises(R1,X1,R1a), $comprises(R2,X2,R2a),
   compare(Delta,X1,X2),
  (Delta = (<) , !, X = X1, $merge(R1a,R2,R)
   ; Delta = (>) , !, X = X2, $merge(R1,R2a,R)
   ; X = X1, $merge(R1a,R2a,R)
  ).

$comprises([X|L],X,L).

/*------------------------------------------ */
/* Sorting on keys by bisecting and merging. */

keysort(L,R) :- length(L,N), $keysort(N,L,_,R1), R=R1.

$keysort(2,[X1|L1],L,R) :- !,
   $comprises(L1,X2,L),
   $compare_keys(Delta,X1,X2),
  (Delta = (>) , !, R = [X2,X1] ; R = [X1,X2] ).
$keysort(1,[X|L],L,[X]) :- !.
$keysort(0,L,L,[]) :- !.
$keysort(N,L1,L3,R) :-
   N1 is N//2, N2 is N-N1,
   $keysort(N1,L1,L2,R1),
   $keysort(N2,L2,L3,R2),
   $keymerge(R1,R2,R).

$keymerge([],R,R) :- !.
$keymerge(R,[],R) :- !.
$keymerge(R1,R2,[X|R]) :-
   $comprises(R1,X1,R1a), $comprises(R2,X2,R2a),
   $compare_keys(Delta,X1,X2),
  (Delta = (>) , !, X = X2, $keymerge(R1,R2a,R)
   ; X = X1, $keymerge(R1a,R2,R)
  ).

$compare_keys(Delta,K1-X1,K2-X2) :- compare(Delta,K1,K2).

/*==========================================*/

X^P :- P.

/*===========================================*/

$tag(Key,Value) :-
   recorda(Key,Value,_).

$untag(Key,Value) :-
   recorded(Key,Value,Ref),
   erase(Ref).

length([],0) :- !.
length([_|L],N) :- !, length(L,N0), N is N0+1.


% tracing : trace control

debug :-
   $debug(P,1),
   (  P=1 ;
      display('Debug mode switched on.'), ttynl
   ), !.

nodebug :-
   $debug(P,0),
   (  P=0 ;
      (  $someleft, $allspyremove,
          display('All spy-points removed.'), ttynl   ;
         true
      ),
      display('Debug mode switched off.'), ttynl
   ), !.

spy(X) :- $spy(X,on),debug,write('*** in some left'), nl, $someleft,
		 	write('*** out of some left'),
                     	fail.
spy(_).

nospy(X) :- $spy(X,off), fail.
nospy(_).

leash(X) :- nonvar(X),
   $leashcode(X,N),
   $leash(P,N),
   $prleash(N), !.
leash(X) :-
   display('! Invalid leash specification : '),
   display(X), ttynl, fail.

$leashcode(full,2'1111) :- !.
$leashcode(on,2'1111):- !.
$leashcode(half,2'1010) :- !.
$leashcode(loose,2'1000) :- !.
$leashcode(off,2'0000) :- !.
$leashcode(N,N) :- integer(N), N>=0, N=<2'1111, !.


$prleash(0) :- !, display('No leashing.'), ttynl.
$prleash(N) :-
   $leashcode(Code,N),
   display('Leashing set to '), display(Code),
   display(' ('),$pcl(Had,2'1000,N,call),
   $pcl(Had,2'0100,N,exit),
   $pcl(Had,2'0010,N,backto),
   $pcl(Had,2'0001,N,fail),
   display(').'),ttynl.

$pcl(Had,M,N,W) :- N/\M =:= 0,  !.
$pcl(Had,_,_,W) :-
   (  var(Had),Had=yes ;
       display(',')
   ),
   display(W), !.

debugging :-  $debug(D,D),
   (  D=0, !,
      display('Debug mode is switched off.'),
      ttynl, ! ;
      display('Debug mode is switched on.'), ttynl,
      ( $someleft, !,
      display('Spy-points set on : '),ttynl,
      (  current_atom(Functor),
      	 $current_functor(Functor,Arity,2'100010000,2'11110000),
         ttytab(8), $prspy(Functor,Arity), ttynl, fail   ;
        true
      )     ;
            display('There are no spy-points set.'), ttynl
   ),
      $leash(L,L), $prleash(L)  ), !.

$spy(V,_) :- var(V), !,
   display('! Invalid procedure specification : '),
   display(V),ttynl.
$spy([],_) :- !.
$spy([HD|TL]):- !,
   $spy(HD),
   $spy(TL).
$spy(X,off) :-
   $functorspec(X,Functor,Arity),
   (  var(Arity) ;  A=Arity ),
   (  $current_functor(Functor,A,2'100010000,2'11110000),
      !,
      ( $current_functor(Functor,Arity,2'100010000,2'11110000),
         functor(T,Functor,Arity), $flags(T,P,P/\2'11101111),
          display('Spy-point on '), $prspy(Functor,Arity),
          display(' removed.'), ttynl, fail
         ; true
      )
      ;  display('There is no spy point on'),
           display(X), display('.'), ttynl
   ), !.

$spy(X,on) :-
   $functorspec(X,Functor,Arity),
   (  atom(X),
      (  $current_functor(Functor,Arity,2'100000000,2'11110000),
         functor(Head,Functor,Arity),
         $enter(Head,Functor,Arity),
         fail
       ; (  $current_functor(Functor,_,2'100000000,2'11100000) ;
            display('You have no clauses for '), display(X),
            display(' - nothing done.'), ttynl
   )     )
  ; functor(Head,Functor,Arity),
    (  $current_functor(Functor,Arity,256,2'111100000)
     ; display('[ Warning: you have no clauses for '),
      $prspy(Functor,Arity), display(' ]'), ttynl
    ),
    $enter(Head,Functor,Arity)
   ),
   !.

$spy(_,_).


$enter(Head,Functor,Arity) :-
   (  $current_functor(Functor,Arity,2'100010000,2'11110000),
      display('There already is a spy-point on ');
      $flags(Head,P,P),
      (  P/\2'11100000 =:= 0, $flags(Head,P,P\/2'10000)   ; true),
      display('Spy-point placed on ')
   ),
   $prspy(Functor,Arity),
   display('.'), ttynl, !.

$prspy(Functor,Arity) :-
   display(Functor), display(/), display(Arity).

$someleft :- current_atom(A), $current_functor(A,_,2'10000,2'10000), !.

$allspyremove :-
   current_atom(F),
    $current_functor(F,A,2'100010000,2'11110000),
   functor(T,F,A), $flags(T,P,P/\2'11101111), fail.
$allspyremove.

$functorspec(V,_,_) :- var(V),!, $badspec(V).
$functorspec(X,X,_) :- atom(X),!.
$functorspec(F/N,F,N) :- atom(F), integer(N), !.
$functorspec(X,_,_) :- $badspec(X).

$badspec(X) :- display('! Invalid procedure specification : '),
               display(X), ttynl, fail.



/*========================================*/
% listing : Listing clauses in the database


listing :-
        current_predicate(_,Pred),
        $list_clauses(Pred).
listing.


listing(V) :- var(V), !.       % ignore variables
listing([]) :- !.
listing([X|Rest]) :-
        !,
        listing(X),
        listing(Rest).
listing(X) :-
        $functorspec(X,Name,Arity),
        current_predicate(Name,Pred),
        functor(Pred,Name,Arity),
        $list_clauses(Pred).
listing(_).


$list_clauses(Pred) :-
        nl,
        clause(Pred,Body),
        $write_clause(Pred,Body),
        fail.

$write_clause(Head,Body) :-
        writeq(Head),
        ( Body = true  ;
                tab(1), write((:-)),
                $write_body(Body,3,',')
        ),
        put("."), nl,
        !.

$write_body(X,I,T) :- var(X), !, $beforelit(T,I), writeq(X).
$write_body((P,Q), IO, T) :-
        !,
        $write_body(P,IO,T),
        put(","),
        $aftercomma(T,IO,I),
        $write_body(Q,I,',').
$write_body((P;Q),I,T) :-
        !,
        nl, tab(I-2), put("("),
        $write_body(P,I,'('),
        put(";"),
        $write_body(Q,I,';'),
        tab(1), put(")").
$write_body(X,I,T) :-
        $beforelit(T,I),
        writeq(X).

$aftercomma(',',I,I) :- !.
$aftercomma(_,IO,I) :- I is IO + 3.

$beforelit('(',_) :- !, tab(1).
$beforelit(_,I) :- nl, tab(I).



/* protect : Setting the flags for the system predicates */

$mem(X,[X|_]).
$mem(X,[_|Rest]) :- $mem(X,Rest).

$protected(P,A) :- $unprotected(P,A), !, fail.
$protected(P,A).

% Predicate flags used here:
%
%	
%	128 (PROTECTED)
%	 64 (INVISIBLE)
%	 32 (UNTRACEABLE)


%  Cut must be transparent due to the way it is currently
%  implemented (this fixes bug that prevented tracing
%  past cuts).
%  Note that transparent also seem to imply untracable,
%  which means you don't see cuts at all.

  :- $sysflgs(!,64).


			% This list are all transparent and untracable.

  :-(( $mem(X,[ call(_),(A,B),(A;B),$call(_),$hidden_call(_),(A->B)]),
       $sysflgs(X,96), fail  ;  true )).

			% The following predicates are better off invisible so
			%  they are made untracable as well.

  :-(( $mem(X,[
          write(_), writeq(_), nl, get0(_), get(_), skip(_), put(_), tab(_),
          display(_), ttynl(_), ttytab(_), read(_), spy(_), nospy(_), 
	  leash(_), trace, debug, nodebug, debugging
         ]),
             $sysflgs(X,32), fail  ;  true )).

			%  ALL current predicates but those specified
			%  by $unprotected are turned into
			%  system predicates (which cannot be redefined, seen
			%  by listing etc).

  :-(( current_atom(A), $current_functor(A,Arity,256,0), $protected(A,Arity),
     functor(Pred,A,Arity), $flags(Pred,Flags,Flags\/128), fail  ;  true )).
  :- $flags(fail,Flags,Flags\/128). % Must be specially protected (no clauses)

			% Finally, ALL predicates whose names start with a
			% dollar are made untraceable and their atoms hidden.

  :-(( current_atom(A), name(A,[36|_]),
	$hide_atom(A),   % THIS MUST BE IN THE LAST GOAL IN THE BOOT LOAD!!
        $current_functor(A,Arity,256,0),
         functor(Pred,A,Arity),
         $flags(Pred,Flags,Flags\/32), fail  ;  true )).


end_of_file.                     % needed here for a special reason...
