/*  --- University of Sussex POPLOG file -----------------------------------
 *  File:           $usepop/pop/local/plog/lib/objects.pl
 *  Purpose:        A subset of Object-Programming facilities for Prolog
 *  Author:         Mark Keefe, Dec  5 1985
 *  Machines:       cvaxa unx1 sun vax2
 *  Documentation:  TEACH * OBJECTS
 *  Related Files:  See TEACH * NEWOBJ, *FLAVOUR, *FRAMES
 */

/*
 * Inheritance is represented (inferred from) a sequence of simple dependency
 * declarations of the form (X isa Y) in the database (entered by user).
 *
 * Method associations are determined by satisfying add_objects.  For each user
 * declaration of the form (C with [M1, M2, ...]) where the M's are facts and
 * rules, the head of each M is augmented to contain C as its first argument.
 * Then any previous clauses in the database for the augmented M are retracted
 * as if a reconsult goal had encountered the augmented M, then the augmented
 * M is asserted.
 */

?- library(useful).
?- op(252, xfx, isa).
?- op(252, xfx, with).

add_objects :-
    retractall(done(_)),
    clause(Object with Method_list, _),
    nonvar(Object),
    add_object_methods(Object, Method_list).    ;;; always fails
add_objects.

add_object_methods(_, []) :- fail.
add_object_methods(Object, [(Method_head :- Body) | Rest_methods]) :-
    aug_ret(Method_head, Object, Aug_method),
    assertz((Aug_method :- Body)),
    !,
    add_object_methods(Object, Rest_methods).
add_object_methods(Object, [Method_head | Rest_methods]) :-
    aug_ret(Method_head, Object, Aug_method),
    assertz(Aug_method),
    !,
    add_object_methods(Object, Rest_methods).

aug_ret(Method_head, Object, Aug_method) :-
    augment_head(Method_head, Object, Aug_method),
    retract_previous_methods(Object, Aug_method).

augment_head(Method_head, Object, Aug_method) :-
    Method_head =.. [Selector, .. Args],
    Aug_method =.. [Selector, Object, .. Args].

retract_previous_methods(_, Method_head) :-
    clause(done(Method_head), _), !.    ;;; already done - retract nothing
retract_previous_methods(Object, Method_head) :-
    make_copy(Method_head, Head2),  ;;; copy struct with uninstantiated args
    arg(1, Head2, Object),          ;;; instantiate 1st arg to Object
    asserta(done(Head2)),           ;;; record having done Head2
    retractall(Head2).              ;;; retract all Head2's

make_copy(Head, Head2) :-
    functor(Head, Func, Num),
    functor(Head2, Func, Num).

/*
 * To attempt to satisfy an expression of the form M >--> O, or O <--< M,
 * where M and O are instantiated, a superclass S of O is generated.
 * The superclasses are generated in the order of the precedence relation
 * described in TEACH *PROLOBJ (ie, by doing a depth-first, left-to-right
 * search of the "isa" network, avoiding all but the first in case of
 * duplicates.  Note that a class is (degeneratively) a superclass of itself:
 * It is the first in the ordered list of its superclasses.
 *
 * The message M is augmented to contain S as its first
 * argument.  Then, the applicability of the method to the augmented message
 * is tested. Currently, the method is considered applicable if there is a
 * clause for it, but it is possible to think of other tests, such as testing
 * it as a goal, or testing only that the principal functor and number of
 * args match some clause.  If the test succeeds, then we are stuck with the
 * choice of S which implements the method (ie, having found a superclass
 * that provides the desired operation, there is no further bactracking to
 * other superclasses).
 *
 * Backtracking will occur only amongst the matching methods in the chosen
 * superclass.  If the test fails, then backtracking does indeed
 * allow us to generate the next superclass S and reapply the test.  So,
 * a message expression can fail in two ways: (1) no superclass is found for
 * which the test succeeds (ie, no superclass implements the desired
 * operation), and (2) a superclass is found, but the method itself fails,
 * having tried all alternatives for the chosen superclass.
 */

?-op(252, xfx, '<--<').
?-op(252, xfx, '>-->').

Object <--<  Message :- send_message(Object, Message).
Message >-->  Object :- send_message(Object, Message).

send_message(Object, Message) :-
    nonvar(Message), nonvar(Object),
    asserta(found([])),
    get_next_super(Object, Super),
    augment_head(Message, Super, Aug_Message),
    test_applicability(Aug_Message),
    retract(found(_)),
    !,
    Aug_Message.
send_message(_,_) :- retractall(found(_)), fail.

get_next_super(Object, _) :-	already_found(Object), !, fail.
get_next_super(Object, Object) :- record_found(Object).
get_next_super(Object, Super) :-
    (Object isa Something),
    get_next_super(Something, Super).

already_found(Object) :-
    clause(found(List), _),
    member(Object, List).

record_found(Y) :-
    retract(found(L)),
    asserta(found([Y | L])), !.

test_applicability(Aug_Message) :-
    asserta((test :- clause(Aug_Message, Body))),
    test,
    retractall(test).

supers(Object, Supers) :-
    nonvar(Object), var(Supers),
    asserta(found([])),
	get_next_super(Object, _),
	fail.
supers(Object, Supers) :-
    retract(found(Rev_supers)),
    reverse(Rev_supers, Supers).

reverse(L1, L2) :- revzap(L1, [], L2).

revzap([X | L], L2, L3) :- revzap(L, [X | L2], L3).
revzap([], L, L).

cancel_methods(Object, Method_list) :-
    nonvar(Object),
    do_cancel_methods(Object, Method_list), !.

do_cancel_methods(_, []).
do_cancel_methods(Object, [Method | Rest_methods]) :-
    augment_head(Method, Object, Aug_method),
    retractall(Aug_method),
    do_cancel_methods(Object, Rest_methods).
