Heimseite
Seitenübersicht
An/abmeldung
Anschlagbrett
Herunterladen(c) 2005-2024 XLOG Technologies AG
/***************************************************************/
/* Dynamic Database */
/***************************************************************/
/**
* dynamic I: [ISO 7.4.2.1]
* The predicate succeeds. As a side effect the
* predicate I is touched.
*/
% dynamic(+Indicator)
dynamic(V) :- var(V),
throw(error(instantiation_error,_)).
dynamic(F/N) :- !,
sys_check_atom(F),
sys_check_integer(N),
sys_style_indicator(F, N),
kb_pred_touch(F, N, 1).
dynamic(I) :-
throw(error(type_error(predicate_indicator,I),_)).
/**
* asserta(C): [ISO 8.9.1]
* The predicate succeeds. As a side effect, the clause C
* is inserted at the top.
*/
% asserta(+Clause)
asserta(Clause) :-
sys_trans_horn(Clause, Help),
sys_encode_horn(Help, Encode, 0),
sys_host_make(Encode, Native),
sys_host_asserta(Help, Native).
% sys_host_asserta(+Clause, +Encode)
sys_host_asserta(tr_clause(_,Head,_), Native) :- !,
functor(Head, F, A),
ir_clause_add(F, A, Native, 2).
sys_host_asserta(T, _) :-
throw(error(type_error(tr_clause, T),_)).
/**
* assertz(C): [ISO 8.9.2]
* The predicate succeeds. As a side effect, the clause C
* is inserted at the bottom.
*/
% assertz(+Clause)
assertz(Clause) :-
sys_trans_horn(Clause, Help),
sys_encode_horn(Help, Encode, 0),
sys_host_make(Encode, Native),
sys_host_assertz(Help, Native).
% sys_host_assertz(+Clause, +Encode)
sys_host_assertz(tr_clause(_,Head,_), Native) :- !,
functor(Head, F, A),
ir_clause_add(F, A, Native, 3).
sys_host_assertz(T, _) :-
throw(error(type_error(tr_clause, T),_)).
/**
* clause(H, B): [ISO 8.8.1]
* The predicate succeeds with the clauses that unify H :- B.
*/
% clause(+Callable, -Goal)
clause(H, B) :-
sys_check_callable(H),
kb_clause_ref(H, 2, C),
kb_clause_data(C, H, O, L),
sys_decode_body(L, R),
sys_untrans_body(R, O, A),
A = B.
/**
* retract(C): [ISO 8.9.3]
* The predicate succeeds with the clauses that unify C.
* As a side effect the clause is removed.
*/
% retract(+Clause)
retract(V) :- var(V),
throw(error(instantiation_error,_)).
retract((H :- B)) :- !,
sys_check_callable(H),
functor(H, F, N),
kb_clause_ref(H, 3, C),
kb_clause_data(C, H, O, L),
sys_decode_body(L, R),
sys_untrans_body(R, O, A),
A = B,
kb_clause_remove(F, N, 0, C).
retract(H) :-
sys_check_callable(H),
functor(H, F, N),
kb_clause_ref(H, 3, C),
kb_clause_data(C, H, _, L),
L = [],
kb_clause_remove(F, N, 0, C).
/**
* retractall(H): [TC2 8.9.5]
* The predicate succeeds. As a side effect the clauses
* that unify the head H are removed.
*/
% retractall(+Callable)
retractall(H) :-
sys_check_callable(H),
functor(H, F, N),
kb_clause_ref(H, 7, C),
kb_clause_head(C, H),
kb_clause_remove(F, N, 1, C),
fail.
retractall(_).
/**
* abolish(I): [ISO 8.9.4]
* The predicate succeeds. As a side effect, the
* predicate I is destroyed.
*/
% abolish(+Indicator)
abolish(V) :- var(V),
throw(error(instantiation_error,_)).
abolish(F/N) :- !,
sys_check_atom(F),
sys_check_integer(N),
sys_abolish(F, N).
abolish(I) :-
throw(error(type_error(predicate_indicator,I),_)).
% sys_abolish(+Atom, +Integer)
sys_abolish(F, N) :-
kb_pred_link(F, N, Q),
kb_link_flags(Q, O),
O /\ 1 =:= 0,
throw(error(permission_error(modify, static_procedure, F/N),_)).
sys_abolish(F, N) :-
retractall(sys_predprop(F, N, _)),
kb_pred_destroy(F, N).
/***************************************************************/
/* Predicate Property */
/***************************************************************/
% sys_predprop(-Atom, -Integer, -Term)
:- dynamic sys_predprop/3.
/**
* current_predicate(I): [ISO 8.8.2]
* The predicate succeeds in I with current predicate indicators.
*/
% current_predicate(-Indicator)
current_predicate(I) :- \+ ground(I), !,
kb_pred_list(L),
member(I, L).
current_predicate(F/N) :- !,
sys_check_atom(F),
sys_check_integer(N),
kb_pred_link(F, N, _).
current_predicate(I) :-
throw(error(type_error(predicate_indicator,I),_)).
/**
* predicate_property(I, P):
* The predicate succeeds in P with the properties of the predicate indicator I.
*/
% predicate_property(+Indicator, -Term)
predicate_property(I, P) :- \+ ground(I), !,
sys_predprop_pattern(I, P).
predicate_property(F/N, P) :- !,
sys_check_atom(F),
sys_check_integer(N),
sys_predprop_get(F, N, P).
predicate_property(I, _) :-
throw(error(type_error(predicate_indicator,I),_)).
% sys_predprop_pattern(+Indicator, -Term)
sys_predprop_pattern(F/N, P) :-
current_predicate(F/N),
sys_predprop_get(F, N, P).
% sys_predprop_get(+Atom, +Integer, -Term)
sys_predprop_get(F, N, P) :-
kb_pred_link(F, N, Q),
kb_link_flags(Q, O),
sys_predprop_flag(O, P).
sys_predprop_get(F, N, P) :-
sys_predprop(F, N, P).
% sys_predprop_flag(+Integer, -Term)
sys_predprop_flag(O, dynamic) :-
O /\ 1 =\= 0.
sys_predprop_flag(O, static) :-
O /\ 1 =:= 0.
/*******************************************************************/
/* Make Host */
/*******************************************************************/
% sys_host_make(+IRClauseOrGoal, -HostObject)
sys_host_make(ir_clause(A,B,W,D), C) :-
K is W+1,
sys_host_list(A, X, v(K,[]), v(J,R)),
sys_host_list(B, Y, v(J,R), v(I,_)),
ir_clause_new(I, X, Y, W, D, C).
sys_host_make(ir_goal(A), Goal) :-
sys_host_list(A, X, v(0,[]), v(I,_)),
ir_goal_new(I, X, Goal).
% sys_host_list(+List, +HostList, +Pair, -Pair)
sys_host_list([X|L], [Y|R]) -->
sys_host_instr(X, Y),
sys_host_list(L, R).
sys_host_list([], []) --> [].
% sys_host_instr(+Callable, +HostObject, +Pair, -Pair)
sys_host_instr(first_var(_,G), A) --> {var(G)}, !,
{ir_place_new(-1, A)}.
sys_host_instr(first_var(W,_), A) -->
(sys_host_current_recycle([W|R]) ->
sys_host_set_recycle(R);
sys_host_current_max(W),
{H is W+1},
sys_host_set_max(H)),
{V is (-W)-2,
ir_place_new(V, A)}.
sys_host_instr(var(W,G), A) -->
({var(G)} ->
sys_host_current_recycle(R),
sys_host_set_recycle([W|R]);
[]),
{ir_place_new(W, A)}.
sys_host_instr(functor(F,L), A) -->
{sys_host_const(F, G)},
sys_host_list(L, R),
{ir_skeleton_new(G, R, A)}.
sys_host_instr(const(F), G) -->
{sys_host_const(F, G)}.
% sys_host_current_max(-Integer, -Pair, +Pair)
sys_host_current_max(I, v(I,R), v(I,R)).
% sys_host_set_max(+Integer, -Pair, +Pair)
sys_host_set_max(I, v(_,R), v(I,R)).
% sys_host_current_recycle(-List, -Pair, +Pair)
sys_host_current_recycle(R, v(I,R), v(I,R)).
% sys_host_set_recycle(+List, -Pair, +Pair)
sys_host_set_recycle(R, v(I,_), v(I,R)).
% sys_host_alternatives(+List, +HostList)
sys_host_alternatives([X|L], [Y|R]) :-
sys_host_make(X, Y),
sys_host_alternatives(L, R).
sys_host_alternatives([], []).
/*******************************************************************/
/* Constants */
/*******************************************************************/
% sys_host_const(+Const, -HostConst)
sys_host_const(functor(Q,L), D) :- !,
sys_host_const(Q, F),
sys_host_args(L, R),
D =.. [F|R].
sys_host_const(link(L), D) :- !,
sys_host_alternatives(L, R),
kb_make_defined(R, D).
sys_host_const(site(F), D) :- !,
ir_pred_site(F, D).
sys_host_const(C, C).
% sys_host_args(+List, -List)
sys_host_args([X|L], [Y|R]) :-
sys_host_const(X, Y),
sys_host_args(L, R).
sys_host_args([], []).
/****************************************************************/
/* Term Decode */
/****************************************************************/
/**
* sys_decode_body(L, R):
* The predicate succeeds in R with the unlinked goal list L.
*/
% sys_decode_body(+List, -List)
sys_decode_body([X|L], [Z|R]) :-
sys_decode_callable(X, Y),
sys_decode_goal(Y, Z),
sys_decode_body(L, R).
sys_decode_body([], []).
% sys_decode_callable(+Callable, -Callable)
sys_decode_callable(X, X) :- var(X), !.
sys_decode_callable(X, Y) :- functor(X, Q, _), ir_is_site(Q), !,
ir_site_name(Q, F), sys_decode_site(X, Y, F).
sys_decode_callable(X, X).
% sys_decode_site(+Callable, -Callable, +Atom)
sys_decode_site(X, Y, F) :- compound(X), !,
X =.. [_|L],
Y =.. [F|L].
sys_decode_site(_, F, F).
/**
* sys_decode_goal(F, G):
* The predicate succeeds in G with the unlinked goal F.
*/
% sys_decode_goal(+Term, -Term)
sys_decode_goal(X, call(X)) :- var(X), !.
sys_decode_goal(X, R) :- functor(X, Q, _), kb_is_link(Q), !,
sys_decode_link(X, R).
sys_decode_goal('$EVAL'(E,V), V is F) :- !,
sys_decode_expr(E, F).
sys_decode_goal(E =:= F, G =:= H) :- !,
sys_decode_expr(E, G),
sys_decode_expr(F, H).
sys_decode_goal(E =\= F, G =\= H) :- !,
sys_decode_expr(E, G),
sys_decode_expr(F, H).
sys_decode_goal(E < F, G < H) :- !,
sys_decode_expr(E, G),
sys_decode_expr(F, H).
sys_decode_goal(E > F, G > H) :- !,
sys_decode_expr(E, G),
sys_decode_expr(F, H).
sys_decode_goal(E =< F, G =< H) :- !,
sys_decode_expr(E, G),
sys_decode_expr(F, H).
sys_decode_goal(E >= F, G >= H) :- !,
sys_decode_expr(E, G),
sys_decode_expr(F, H).
sys_decode_goal(X, X).
% sys_decode_link(+Callable, -Callable)
sys_decode_link(X, '$ALT'(P)) :-
findall(C, kb_clause_ref(X, 0, C), L),
sys_decode_alternatives(L, X, P).
% sys_decode_alternatives(+List, +Callable, -List)
sys_decode_alternatives([C|L], X, ['$SEQ'(U,W)|R]) :-
kb_clause_data(C, X, U, V),
sys_decode_body(V, W),
sys_decode_alternatives(L, X, R).
sys_decode_alternatives([], _, []).
/**
* sys_decode_expr(F, G):
* The predicate succeeds in G with the unlinked expression F.
*/
% sys_decode_expr(+Expr, -Expr)
sys_decode_expr(V, V) :- var(V), !.
sys_decode_expr(X, Y) :- functor(X, Q, _), ir_is_site(Q), !,
ir_site_name(Q, F), sys_decode_compute(X, Y, F).
sys_decode_expr(C, D) :- compound(C), !,
C =.. [F|L],
sys_decode_args(L, R),
D =.. [F|R].
sys_decode_expr(A, A).
% sys_decode_compute(+Callable, -Callable, +Atom)
sys_decode_compute(X, Y, F) :- compound(X), !,
X =.. [_|L],
sys_decode_args(L, R),
Y =.. [F|R].
sys_decode_compute(_, F, F).
% sys_decode_args(+List, -List)
sys_decode_args([X|L], [Y|R]) :-
sys_decode_expr(X, Y),
sys_decode_args(L, R).
sys_decode_args([], []).
/****************************************************************/
/* Term Untransform */
/****************************************************************/
/**
* sys_untrans_body(L, O, B):
* The predicate succeeds in B with the untransformed option O
* and goal list L.
*/
% sys_untrans_body(+List, +Option, -Goal)
sys_untrans_body([X|L], O, Y) :-
sys_untrans_rest(L, X, O, Y).
sys_untrans_body([], _, true).
% sys_untrans_rest(+List, +Goal, +Option, -Goal)
sys_untrans_rest([Y|L], X, O, (Z, T)) :-
sys_untrans_goal(X, O, Z),
sys_untrans_rest(L, Y, O, T).
sys_untrans_rest([], X, O, Y) :-
sys_untrans_goal(X, O, Y).
/**
* sys_untrans_goal(G, O, H):
* The predicate succeeds in H with the untransformed option O
* and goal G.
*/
% sys_untrans_goal(+Callable, +Option, -Goal)
sys_untrans_goal('$ALT'(P), O, Q) :- !,
sys_untrans_alternatives(P, O, Q).
sys_untrans_goal('$CUT'(X), just(Y), !) :- X == Y, !.
sys_untrans_goal(X, _, X).
/**
* sys_untrans_alternatives(P, O, Q):
* The predicate succeeds in Q with the untransformed option O
* and alternatives P.
*/
% sys_untrans_alternatives(+List, +Option, -Goal)
sys_untrans_alternatives([X|L], O, Y) :-
sys_untrans_more(L, X, O, Y).
sys_untrans_alternatives([], _, fail).
% sys_untrans_more(+List, +Cond, +Option, -Goal)
sys_untrans_more([Y|L], '$SEQ'(M,X), O, (Z;T)) :-
sys_untrans_alternative(M, X, O, Z),
sys_untrans_more(L, Y, O, T).
sys_untrans_more([], '$SEQ'(M,X), O, Y) :-
sys_untrans_alternative(M, X, O, Y).
/**
* sys_untrans_alternative(U, V, O, Z):
* The predicate succeeds in Z with the untransformed option O
* and cutvar U and body V.
*/
% sys_untrans_alternative(+Option, +List, +Option, -Goal)
sys_untrans_alternative(just(X), L, O, (A -> B)) :-
sys_untrans_split(L, X, P, Q),
sys_trans_mark(M, P, R),
sys_untrans_body(R, M, A),
sys_untrans_body(Q, O, B).
sys_untrans_alternative(nothing, L, O, B) :-
sys_untrans_body(L, O, A),
sys_untrans_ambiguity(A, B).
/**
* sys_untrans_split(L, X, P, Q):
* The predicate succeeds in P and Q with the split of the
* list of goals L by the redo variable X.
*/
% sys_untrans_split(+List, +Var, -List, -List)
sys_untrans_split(['$CUT'(X)|L], Y, [], L) :- X == Y, !.
sys_untrans_split([X|L], Y, [X|P], Q) :-
sys_untrans_split(L, Y, P, Q).
/**
* sys_untrans_ambiguity(B, A):
* The predicate succeeds in A with a body logically
* equivalent to B, that doesn't have the form (_ -> _).
*/
% sys_untrans_ambiguity(+Alternative, -Body)
sys_untrans_ambiguity((A -> B), (A -> B; fail)) :- !.
sys_untrans_ambiguity(A, A).
/*******************************************************************/
/* Initialize Environment */
/*******************************************************************/
:- sys_get_locale(L),
set_prolog_flag(sys_locale, L).
:- sys_get_args(L),
set_prolog_flag(argv, L).