/*  --- Copyright University of Sussex 1987.  All rights reserved. ---------
 > File:           $usepop/pop/local/plog/lib/plogpsys.pl
 > Purpose:        Prolog production system interpreter: Version 9.2
 > Author:         Tom Khabaza, Jan 17 1986 (see revisions)
 > Machines:       cvaxa unx1 psuna psunb pas-sun esuna tsuna tbobf vax2 cgeca
 > Documentation:  TEACH * PLOGPSYS
 > Related Files:  TEACH * BLOCKPSYS
 */

:- library(useful).

;;; principle functor of a rule
:- op(255,xfy,=>).

;;; Manipulating real facts
:- op(200, fx, add).
:- op(200, fx, remove).
:- op(200, fx, removeall).

;;; Manipulating pseudo-facts
:- op(200, fx, add_pseudo).
:- op(200, fx, remove_pseudo).
:- op(200, fx, removeall_pseudo).

;;; General Prolog goal
:- op(200, fx, prolog_goal).

;;; i/o
:- op(200, fx, print).
:- op(200, fx, input).
:- op(200, fx, show).
:- op(200, fx, show_pseudo).

;;; tracing command
:- op(200, fx, tracepsys).

;;; showfacts commands
:- op(200, fx, showfacts).
:- op(200, fx, noshowfacts).


/*  To run the production system, enter the main loop with status "go";
 *  when this terminates, the production system has stopped.
 *  Then show the contents of the production system database.
 */

run :- cleanup, run(go), !,  showdatabase, cleanup.
run :- nl, write('Failing - no (more) rules applicable'), showdatabase,
    cleanup.


/* showdatabase displays the contents of the production system database.
 * Note that for purposes of 'showdatabase', facts in the PS database
 * are UNIT clauses of the predicate fact/1 - clauses with bodies are
 * not displayed.
 */

showdatabase :-
    nl, nl, write('Production system database:'), nl, nl, fail.
showdatabase :-
    clause(fact(F), true), write(F), nl, fail.
showdatabase :- nl.


/* run/1 provides the main loop for the interpreter.
 * It's argument is a status flag which causes it to stop
 * with appropriate messages at appropriate times.
 */

run(stop) :- nl, write('Stopping - stop action executed'), nl, !.
run(fail) :- nl, write('Stopping - no (more) rules applicable'), nl, !.
run(_) :-
    cycle(NewStatus),
    run(NewStatus).


/* cycle/1 is the body of the main loop.
 * Its argument is used to return a status, to control the next
 * iteration.
 * The second clause gives us the failure status if there are no
 * applicable rules.
 * If the production system backtracks, there will be backtracking
 * between 'apply' and 'select'.
 * 'applicable' should fail on backtracking.
 */

cycle(Status) :-
    applicable(Rules),
    (Rules = [] ->
        Status = fail ;
        select(Rules, Rule), apply(Rule, Status)).


/* applicable/1
 * Rules is the set of rules whose conditions are all currently true.
 */

applicable(Rules) :-
    findall(H => NewB,
        ( (H => B), alltrue(H,Acts), append_to_body(Acts,B,NewB) ),
        Rules).


/* alltrue/1
 * True if its argument is a conjunction of conditions (possibly unary)
 * all of which are currently true.  Deals with conjunction - a,b.
 */

alltrue((A,B), Acts) :- !,
    alltrue(A, Acts1), alltrue(B, Acts2),
    append(Acts1, Acts2, Acts).
alltrue(A, Acts) :-
    psys_true_with_neg(A, Acts).


/* psys_true_with_neg/1
 * True if its argument is a positive or negative goal which is
 * currently true.
 * Deals with negation - not(a).
 *  and negated conjunction - not(( a,b ))
 *      (note the double brackets for negative conjunctions).
 */

psys_true_with_neg(not(A), []) :-
    !, not(alltrue(A, _)).
psys_true_with_neg(A, Acts) :-
    not(psys_true(not(A), _)),
    psys_true(A, Acts).


/* psys_true/1
 * True if its argument is a goal which is currently true
 * as a fact, pseudo-fact or system pseudo-fact.
 */

psys_true((- A), [remove A]) :-
    fact(A).
psys_true(A, []) :-
    A \= (- _), fact(A).
psys_true((- A),
        [prolog_goal
          error('pseudo fact as removal condition is illegal', [- A])]) :-
    pseudo_fact(A).
psys_true(A, []) :-
    A \= (- _), pseudo_fact(A).
psys_true((- A),
        [prolog_goal
            error('system pseudo fact as removal condition is illegal',
                [- A])] )  :-
    system_pseudo_fact(A).
psys_true(A, []) :-
    A \= (- _), system_pseudo_fact(A).


/* select/2
 * Rule is a selected rule from RULES.
 * This gives us the production system's conflict resolution strategy;
 * given a list of applicable rules, each solution to the goal should bind
 * Rule to a different rule.
 * Normally, only the first of these solutions will be used; later ones
 * will only be used if the production system backtracks.
 */

select(Rules, Rule) :- member(Rule, Rules).


/* apply/2
 * Arg 1 is a rule, arg 2 returns a status flag.
 * Do tracing if it is switched on, then apply the body of the rule,
 * with starting status 'go'.
 * Returned status is that returned by apply_body; this is used for 'stop'
 * actions.
 */

apply(H => B, Status) :-
    (tracingpsys -> trace_rule(H => B) ; true),
    apply_body(go, B, Status),
    (showingfacts(_) -> show_facts ; true).


/* apply_body/3
 * Apply a rule body, taking an initial status and producing a final status.
 * If the initial status is 'stop', nothing is done, and the final status
 * is also 'stop'.
 * Otherwise, execute the action or actions; the stop action causes
 * the status 'stop' to be returned.
 */

apply_body(stop, _, stop) :- !.

;;; multiple actions, separated by ','.
apply_body(go, (A,B), Stat2) :-
    apply_body(go, A, Stat1),
    apply_body(Stat1, B, Stat2).

;;; Manipulating real facts
apply_body(go, add X, go) :- fact(X), !.
apply_body(go, add X, go) :- soft_asserta(fact(X)).
apply_body(go, remove X, go) :- not(fact(X)), !.
apply_body(go, remove X, go) :- soft_retract(fact(X)).
apply_body(go, removeall X, go) :- soft_retractall_unit(fact(X)), !.
apply_body(go, clear, go) :- soft_retractall_unit(fact(_)), !.

;;; Manipulating pseudo-facts

;;; adding pseudo-facts with bodies
apply_body(go, add_pseudo (H:-B), go) :-
    clause(pseudo_fact(H),B), !.
apply_body(go, add_pseudo (H:-B), go) :-
    !, soft_asserta(pseudo_fact(H):-B).

;;; adding pseudo-facts without bodies
apply_body(go, add_pseudo X, go) :- pseudo_fact(X), !.
apply_body(go, add_pseudo X, go) :- soft_asserta(pseudo_fact(X)).

;;; removing pseudo-facts with bodies
apply_body(go, remove_pseudo (H:-B), go) :-
    not(clause(pseudo_fact(H,B))), !.
apply_body(go, remove_pseudo (H:-B), go) :-
    !, soft_retract(pseudo_fact(H):-B).

;;; removing pseudo-facts without bodies
apply_body(go, remove_pseudo X, go) :-
    not(clause(pseudo_fact(X),true)), !.
apply_body(go, remove_pseudo X, go) :-
    soft_retract(pseudo_fact(X):-true).

;;; remove all of a pseudo-fact with body
apply_body(go, removeall_pseudo (H:-B), go) :-
    !, retractall_non_unit(pseudo_fact(H):-B), !.

;;; remove all of a pseudo-fact without body
apply_body(go, removeall_pseudo X, go) :-
    soft_retractall_unit(pseudo_fact(X)), !.

;;; clear out all pseudo-facts
apply_body(go, clear_pseudo, go) :-
    soft_retractall(pseudo_fact(_),1).

;;; clear out all facts of both sorts
apply_body(go, clear_both, go) :-
    soft_retractall_unit(fact(_)),
    soft_retractall(pseudo_fact(_),1).

;;; i/o
apply_body(go, print X, go) :- write(X), nl, !.
apply_body(go, input X, go) :- readline(X), !.

;;; examining the database at run-time
apply_body(go, show X, go) :-
    clause(fact(X), true), write(X), nl, fail.
apply_body(go, show _, go) :- nl, !.

;;; like show, for pseudo-database
apply_body(go, show_pseudo X, go) :-
    clause(pseudo_fact(X), true), write(X), nl, fail.
apply_body(go, show_pseudo _, go) :- nl, !.


;;; general prolog goal action - note no cut
apply_body(go, prolog_goal G, go) :- !, call(G).

;;; backtracking action - fail apply_body -
;;;     the 'stop' return status here should never be seen
apply_body(go, fail, stop) :- !, fail.

;;; stop action - simply change the status to 'stop'
apply_body(go, stop, stop) :- !.

;;; null action - does nothing, useful for null bodies when
;;; removal conditions are being used.

apply_body(go, null, go) :- !.

;;; "Catch-all" - unknow action type.
apply_body(go, Action, stop) :-
    not(member(Action,
        [(_,_), add _ , remove _ , removeall _ , clear,
            add_pseudo _ , remove_pseudo _ , removeall_pseudo _ ,
            clear_pseudo, clear_both,
            prolog_goal _ , print _ , input _ , fail, stop])),
    !, error('Unknown action', [Action]).


/*  There must be some fact and pseudo-fact present initially
 *  to foil Prolog's "undefined predicate" behaviour.
 */

fact(_) :- fail.
pseudo_fact(_) :- fail.


/*  System pseudo_facts.
 *  Equality, arithmetic comparison and calculation.
 */

system_pseudo_fact(X=Y) :- X=Y.
system_pseudo_fact(X\=Y) :- X\=Y.
system_pseudo_fact(X>Y) :- X>Y.
system_pseudo_fact(X<Y) :- X<Y.
system_pseudo_fact(X>=Y) :- X>=Y.
system_pseudo_fact(X=<Y) :- X=<Y.
system_pseudo_fact(X is Y) :- X is Y.


;;; Tracing aparatus

tracingpsys :- !, fail.

tracepsys on :-
    retractall(tracingpsys),
    assert(tracingpsys),
    write('Production system tracing: on'), nl.
tracepsys off :-
    retractall(tracingpsys),
    assert((tracingpsys :- !,fail)),
    write('Production system tracing: off'), nl.

trace_rule(Rule) :-
    write('Using rule:'), nl, write(Rule), nl, nl.
trace_rule(Rule) :-
    write('Backtracking over rule:'), nl, write(Rule), nl, nl, fail.


;;; Showing aparatus

showingfacts(_) :- !, fail.

showfacts X :-
    retractall(showingfacts(X)),
    asserta(showingfacts(X)).

(noshowfacts) :-
    retractall(showingfacts(_)),
    assert((showingfacts(_) :- !, fail)).

noshowfacts X :- retractall(showingfacts(X)).

show_facts :-
    showingfacts(X), fact(X), write(X), nl, fail.
show_facts :- nl.


/*
 *  Utilities of various sorts
 */

;;; Append to body: append a list of actions to a comma-expression
;;; of actions:

append_to_body([], B, B).
append_to_body([H|T], B1, (H,B2)) :- append_to_body(T, B1, B2).

/*
;;; definition of findall from Clocksin & Mellish

findall(X, G, _):-
    asserta(found(special_mark)),
    call(G),
    asserta(found(X)),
    fail.
findall(_, _, L) :-
    collect_found([], M), !, L=M.

*/

collect_found(S, L) :-  getnext(X), !, collect_found([X | S], L).
collect_found(L, L).

getnext(X) :- retract(found(X)), !, X \== special_mark.


;;; soft assert, retract and retractall
soft_asserta(X) :- asserta(X).
soft_asserta(X) :- retract(X), fail.

soft_retract(X) :-
    retract(X), asserta(last_soft_retract(X)).
soft_retract(X) :-
    last_soft_retract(X), retract(last_soft_retract(X)),
    asserta(X), fail.

soft_retractall(H:-B) :-
    findall((H:-B), retract(H:-B), L),
    asserta(last_soft_retractall(L)).
soft_retractall(H) :-
    H \= (_ :- _),
    findall((H:-B), retract(H:-B), L),
    asserta(last_soft_retractall(L)).
soft_retractall(_) :-
    retract(last_soft_retractall(L)),
    asserta_all(L), fail.

;;; version of soft_retractall for unit clauses only
soft_retractall_unit(P) :-
    soft_retractall(P :- true).

;;; version of soft_retractall for non-unit clauses
soft_retractall_non_unit(H:-B) :-
    soft_retractall(H:-B).

asserta_all([]).
asserta_all([H|T]) :-
    asserta(H), asserta_all(T).


;;; Clean up the garbage left by soft retracts et al.
cleanup :-
    retractall(last_soft_retract(_)),
    retractall(last_soft_retractall(_)).


;;; readline - copied from local library readline.pl
:- prolog_language(pop11).

procedure (x,c);
    lvars c x;
    unify(readline(),x,c);
endprocedure -> prolog_valof("readline",1);

:- prolog_language(prolog).


/* --- Revision History ---------------------------------------------------
--- Tom Khabaza, Aug 19 1987 - Added "null" action - turns out to be
        very useful in conjunction with removal conditions.
--- Tom Khabaza, Jul  6 1987 - Version 9.
        Added removal conditions (with "-" prefix for removal of trigger).
--- Tom Khabaza, 25th March 1987 - Version 8.
        Examining the database at run-time.
        New actions: show, show_pseudo.
--- Tom Khabaza, 18th March 1987 - Version 7.
        Added distinction between facts, pseudo-facts and system
        pseudo-facts.  Considerably more complex version of alltrue/1.
        New actions: clear, add_pseudo, remove_pseudo, removeall_pseudo,
        clear_pseudo, clear_both.
        Added backtracking - using soft asserta, retract & retractall for
        all database changes.
        New action: fail.
        Added arbitrary Prolog goals as actions: new action prolog_goal.
--- Tom Khabaza, 16th March 1987 - Version 6.
        Removed bug due to applicable giving back [].
        Added backtracking.
        Cleaned up readline/1 and showdatabase/0.
*/
