GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/files/language/xprolog/_boot

Text File | 1987-10-12 | 5.7 KB | 221 lines

/*
 *        X PROLOG  Vers. 2.0
 *
 *
 *    Written by :     Andreas Toenne
 *            CS Dept. , IRB
 *            University of Dortmund, W-Germany
 *            <[e-mail]>
 *            <....!seismo!unido!atoenne>
 *            <[e-mail]>
 *
 *    Copyright :    This software is copyrighted by Andreas Toenne.
 *            Permission is granted hereby to copy the entire
 *            package including this copyright notice without fee.
 *
 */

%    X Prolog Boot File

% hack to create an intermediate goal for call
% this make the cut local to call

call(A) :- $call(A).

% definitions for conjunction and disjunction
% both procedures are made transparent to the cut

(A ; B) :- $call(A).
(A ; B) :- $call(B).

(A , B) :- $call(A), $call(B).

% further predicates

not(Predicate) :- call(Predicate), !, fail.
not(Predicate).

clause(Head, Body) :- $clause(Head, Body, Help).  % see the documentation

A = A.                    % equality predicate :-)

print(Term) :- var(Term), !, write(Term).
print(Term) :- portray(Term).        % portray should be user defined

append([],L,L).                % common append procedure
append([X|L1],L2,[X|L3]) :- append(L1,L2,L3).

member(X, [X|_]).            % common member procedure
member(X, [_|Y]) :- member(X, Y).

% toplevel interpreter loop
% the main goal should not be changed

main :- $loop(toplevel).        % start things
main.                    % just to make Xprolog happy

% this is a failure driven loop

$loop(toplevel) :-
    prompt(Old, '|    '),        % change the default prompt
    repeat,                % loop forever
        $prompt('?- '),        % give a prompt
        read(Term),        % wait for response
        $solve(Term, toplevel),    % solve the query
    prompt(_, Old),            % restore the prompt
    !.
$loop(Where) :-                % loop not at top level
    prompt(Old, '| '),        % different default prompt
    repeat,                % round and round again
        prompt_if_user,        % no prompt for files
        read(Term),        % read something
        $solve(Term, Where),    % solve it
    prompt(_, Old),            % restore the prompt
    !.

prompt_if_user :- seeing(user), $prompt('| '), !.
prompt_if_user.

$solve(end_of_file, _) :- !.        % the only way to stop the repeat
$solve(Term, _) :- var(Term), !, fail.    % don't accept strange goals
$solve(Term, Where) :-            % try to solve it as a goal
    $query(Term, Where, Goal, What), % check for sort of question
    !,
    prompt(Old, '|: '),
    $solve_goal(Goal, What),    % try to solve a goal
    prompt(_, Old),
    fail.
$solve(Term, Where) :-            % try to assert it
    $process(Term, Result),        % hook for preprocessors
    assertz(Result),        % assert it
    !,
    fail.
$solve(Term, _) :-            % assert or $process failed
    write('! clause: '),
    write(Term),
    fail.

% this is a hook to add preprocessors like the grammar rule translator
% to this top level interpreter.
% simply add via 'asserta' another clause for the preprocessor

$process(T,T).

% check the current term for a question or a command

$query(:-(X), _, X, command) :- !.    % this is a command
$query(?-(X), _, X, question) :- !.    % this is a question
$query(X, toplevel, X, question).    % always questions on top level

% this procedure solves goals
% note the use of $more and $goalvars

$solve_goal(Term, command) :-        % no answer, no alternatives
    call(Term),            % try it once
    !.                % and no further alternatives
$solve_goal(_, command)    :-        % above clause failed
    !,
    nl, write('?'), nl.        % notify the user
$solve_goal(Term, question) :-
    $goalvars(List),        % save the reader's symbol table
    call(Term),            % try the question
    $more(Ok),            % call(Term) had a alternative ?
    $reply(List, Ok),        % say 'yes' to the user
    nl,
    !.
$solve_goal(_, question) :-        % above clause failed !
    nl,
    write(no),            % sorry but ...
    nl,
    !.

$reply(List, Ok) :-            % say yes and show variables
    $show_variables(List),
    write(yes),            % horray
    Ok = yes,            % an alternative ?
    $askformore,            % check if the user wants it
    !.
$reply(_, Ok) :-            % no more alternative
    Ok = no,
    !.

$askformore :- get(X), skip(10), X \== 59. % 59 is ';'

$show_variables([]) :- !.
$show_variables([(Name, Variable)|L]) :-
    write(Name),
    write(' = '),
    write(Variable),
    nl,
    !,
    $show_variables(L).



% consult and friends
% we simply use the top level interpreter for the asserts and queries

[X|Y] :- $process_files([X|Y]).

$process_files([]) :- !.
$process_files([-File|Rest]) :- !, reconsult(File), $process_files(Rest).
$process_files([File|Rest]) :- !, consult(File), $process_files(Rest).

consult(File) :- !, $read_file(File, 0).

reconsult(File) :- !, $read_file(File, 1).

$read_file(File, R) :-
    Heap is heapused,
    Time is cputime,
    $reconsulting(R),
    $test_filename(File),        % check the file
    seeing(OldIn),
    telling(OldOut),
    see(File),            % open the file
    $do_loop,
    seen,                % close the file
    see(OldIn),
    tell(OldOut),
    $reconsulting(0),
    DiffTime is cputime - Time,
    DiffHeap is heapused - Heap,
    write(File),
    ( R == 0 , write('  consulted ') ;
      R == 1 , write('  reconsulted ')),
    write(DiffHeap), write(' bytes '),
    write(DiffTime), write(' msec.'),
    nl, !.

$do_loop :- $loop(filelevel).        % loop at filelevel
$do_loop.

$test_filename(user) :- !.        % this stream is always ok
$test_filename(File) :-
    not atom(File),            % invalid name
    nl,
    write('Invalid filename: '),
    write(File),
    nl,
    !, fail.
$test_filename(File) :-
    not exists(File),        % file not found
    nl,
    write('The file '),
    write(File),
    write(' does not exist.'),
    nl,
    !, fail.
$test_filename(_).            % is ok

%
% debugging hooks
%

leash(off) :- $leash(0).
leash(loose) :- $leash(1).
leash(half) :- $leash(5).
leash(tight) :- $leash(7).
leash(full) :- $leash(15).