/**
* Modern Albufeira Prolog Interpreter
*
* Warranty & Liability
* To the extent permitted by applicable law and unless explicitly
* otherwise agreed upon, XLOG Technologies AG makes no warranties
* regarding the provided information. XLOG Technologies AG assumes
* no liability that any problems might be solved with the information
* provided by XLOG Technologies AG.
*
* Rights & License
* All industrial property rights regarding the information - copyright
* and patent rights in particular - are the sole property of XLOG
* Technologies AG. If the company was not the originator of some
* excerpts, XLOG Technologies AG has at least obtained the right to
* reproduce, change and translate the information.
*
* Reproduction is restricted to the whole unaltered document. Reproduction
* of the information is only allowed for non-commercial uses. Selling,
* giving away or letting of the execution of the library is prohibited.
* The library can be distributed as part of your applications and libraries
* for execution provided this comment remains unchanged.
*
* Restrictions
* Only to be distributed with programs that add significant and primary
* functionality to the library. Not to be distributed with additional
* software intended to replace any components of the library.
*
* Trademarks
* Jekejeke is a registered trademark of XLOG Technologies AG.
*/
:- ensure_loaded(library(util/files)).
:- ensure_loaded(library(compat)).
/***************************************************************/
/* Message Hook */
/***************************************************************/
% put_message(+Stream, +Term)
put_message(S, M) :-
writeq(S, M).
% cross_flags(-Integer)
:- dynamic(cross_flags/1).
% term_expansion(+Clause, -Clause)
:- multifile(term_expansion/2).
term_expansion(T, R) :- nonvar(T), T = (:- D), cross_flags(_),
cross_replace_directive(D, R).
% cross_replace_directive(+Directive, +Integer, -Clause)
cross_replace_directive(D, R) :- nonvar(D), D = multifile(I),
cross_multifile(I),
cross_flags(Flags),
(Flags /\ 2 =:= 0 ->
I = F/N,
R = (:- sys_multifile_safe(F, N));
R = []).
cross_replace_directive(D, R) :- nonvar(D), D = dynamic(I),
cross_dynamic(I, S),
I = F/N,
R = [S | (:- kb_pred_touch(F, N, 1))].
cross_replace_directive(D, R) :- nonvar(D), D = discontiguous(I),
cross_discontiguous(I),
cross_flags(Flags),
(Flags /\ 2 =:= 0 ->
I = F/N,
R = (:- dg_get_partition(T),
assertz(sys_predprop(F, N, sys_discontiguous(T))));
R = []).
/***************************************************************/
/* Modification Check */
/***************************************************************/
/**
* dirty_path(A, B):
* The predicate succeeds if the file B is out of sync, i.e. if
* the file B does not exist, or if the file A is more recent
* than the file B. Otherwise the file B is considered in sync,
* i.e. not out of sync.
*/
% dirty_path(+Atom, +Atom)
dirty_path(_, OutName) :-
\+ file_exists(OutName), !.
dirty_path(InName, OutName) :-
file_property(InName, last_modified(Time)),
file_property(OutName, last_modified(Time2)),
Time > Time2.
/***************************************************************/
/* Smart Copying */
/***************************************************************/
/**
* update_path(A, B):
* The predicate succeeds. As a side effect if the file B is out
* of sync, it is copying the Prolog text file A over the Prolog
* text file B. The last modified date is also copied from
* file A to file B.
*/
% update_path(+Atom, +Atom)
update_path(InName, OutName) :-
dirty_path(InName, OutName), !,
copy_text(InName, OutName),
copy_time(InName, OutName).
update_path(_, _).
% update_pathdirs(+Atom, +Atom)
update_pathdirs(InDir, OutDir) :-
ensure_directory(OutDir),
directory_member(InDir, Name),
\+ sub_atom(Name, _, _, _, '.'),
atom_concat(Name, '/', Name2),
atom_concat(InDir, Name2, InName),
atom_concat(OutDir, Name2, OutName),
update_pathdirs(InName, OutName),
fail.
update_pathdirs(InDir, OutDir) :-
directory_member(InDir, Name),
\+ \+ sub_atom(Name, _, _, _, '.'),
atom_concat(InDir, Name, InName),
atom_concat(OutDir, Name, OutName),
update_path(InName, OutName),
fail.
update_pathdirs(_, _).
/***************************************************************/
/* Post Cleaning */
/***************************************************************/
/**
* clean_path(A, B):
* The predicate succeeds. As a side effect, it is removing
* the Prolog text file B if no Prolog text file A exists.
* Otherwise the Prolog text file B is not removed.
*/
% clean_path(+Atom, +Atom)
clean_path(InName, _) :-
file_exists(InName), !.
clean_path(_, OutName) :-
delete_file(OutName).
% clean_pathdirs(+Atom, +Atom)
clean_pathdirs(InDir, OutDir) :-
directory_member(OutDir, Name),
\+ sub_atom(Name, _, _, _, '.'),
atom_concat(Name, '/', Name2),
atom_concat(InDir, Name2, InName),
atom_concat(OutDir, Name2, OutName),
clean_pathdirs(InName, OutName),
fail.
clean_pathdirs(InDir, OutDir) :-
directory_member(OutDir, Name),
\+ \+ sub_atom(Name, _, _, _, '.'),
atom_concat(InDir, Name, InName),
atom_concat(OutDir, Name, OutName),
clean_path(InName, OutName),
fail.
clean_pathdirs(_, _).
/****************************************************************/
/* Predicate Existence */
/****************************************************************/
% 1 = static
% 0 = dynamic
% cross_currpred(-Atom, -Integer, -Integer)
:- dynamic(cross_currpred/3).
% cross_pred_type(+Atom, +Integer, -Integer)
cross_pred_type(F, N, O) :-
cross_currpred(F, N, O), !.
cross_pred_type(_, _, 1).
% cross_touch_dynamic(+Atom, +Integer)
cross_touch_dynamic(F, N) :-
cross_currpred(F, N, O), !,
cross_touch_ok(F, N, O).
cross_touch_dynamic(F, N) :-
assertz(cross_currpred(F, N, 0)).
% cross_touch_ok(+Atom, +Integer, +Integer)
cross_touch_ok(_, _, 0) :- !.
cross_touch_ok(F, N, 1) :-
throw(error(permission_error(modify,static_procedure,F/N), _)).
% cross_touch_static(+Atom, +Integer)
cross_touch_static(F, N) :-
cross_currpred(F, N, _), !.
cross_touch_static(F, N) :-
assertz(cross_currpred(F, N, 1)).
/****************************************************************/
/* Predicate Properties */
/****************************************************************/
% cross_predprop(-Atom, -Integer, -Atom)
:- dynamic(cross_predprop/3).
% cross_clear
cross_clear :-
retractall(cross_predprop(_,_,_)),
retractall(cross_currpred(_,_,_)).
% cross_defered(-Term)
cross_defered(R) :-
cross_predprop(F, N, cross_multifile(_)),
R = (:- sys_multifile_safe(F, N)).
cross_defered(R) :-
cross_predprop(F, N, cross_usage(_)),
R = (:- sys_usage_predicate(F, N)).
/***************************************************************/
/* Loading Parenthesis */
/***************************************************************/
% cross_loading(-Atom)
:- dynamic(cross_loading/1).
% cross_lastpred(-Atom, -Integer)
:- dynamic(cross_lastpred/2).
% cross_loading_begin(+Atom, -Either)
cross_loading_begin(S, just(F, N)) :-
retract(cross_lastpred(F, N)), !,
asserta(cross_loading(S)).
cross_loading_begin(S, nothing) :-
asserta(cross_loading(S)).
% cross_loading_end(-Either) :-
cross_loading_end(just(F, N)) :-
once(retract(cross_loading(S))),
retractall(cross_predprop(_, _, cross_discontiguous(S))),
cross_update_last(F, N).
cross_loading_end(nothing) :-
once(retract(cross_loading(S))),
retractall(cross_predprop(_, _, cross_discontiguous(S))),
retractall(cross_lastpred(_, _)).
% cross_update_last(+Atom, +Integer)
cross_update_last(F, N) :-
retractall(cross_lastpred(_, _)),
assertz(cross_lastpred(F, N)).
/****************************************************************/
/* Style Check */
/****************************************************************/
/**
* cross_style_static(C, F, D):
* The predicate succeeds in D by some additional directives for C.
*/
% cross_style_static(+Clause, +Integer, -Clause)
cross_style_static(T, [Clause2|Rest2]) :- nonvar(T), T = [Clause|Rest], !,
cross_style_static(Clause, Clause2),
cross_style_static(Rest, Rest2).
cross_style_static(T, []) :- nonvar(T), T = [], !.
cross_style_static(T, []) :- nonvar(T), T = (:- _), !.
cross_style_static(T, R) :- nonvar(T), T = (H :- _), !,
cross_style_head(H, R).
cross_style_static(H, R) :-
cross_style_head(H, R).
% cross_style_head(+Term, -Directive)
cross_style_head(H, R) :- callable(H), !,
functor(H, F, N),
cross_style_indicator(F, N, R).
cross_style_head(_, []).
% cross_style_indicator(+Atom, +Integer, -Directive)
cross_style_indicator(F, N, []) :-
cross_lastpred(F, N), !.
cross_style_indicator(F, N, []) :-
once(cross_loading(S)),
cross_predprop(F, N, cross_usage(S)), !,
(cross_predprop(F, N, cross_discontiguous(S)) -> true;
Error = warning(syntax_error(discontiguous_pred,F/N), _),
sys_fill_stack(Error),
sys_print_error(Error)),
cross_update_last(F, N).
cross_style_indicator(F, N, R) :-
cross_usage_predicate(F, N, R),
cross_update_last(F, N).
% cross_usage_predicate(+Atom, +Integer, -Directive)
cross_usage_predicate(F, N, R) :-
once(cross_loading(S)),
(\+ cross_predprop(F, N, cross_multifile(S)),
cross_predprop(F, N, cross_usage(D)),
S \== D ->
throw(error(permission_error(redefine, procedure, F/N), _));
true),
assertz(cross_predprop(F, N, cross_usage(S))),
cross_flags(Flags),
(Flags /\ 2 =:= 0 ->
R = (:- sys_usage_predicate(F, N));
R = []).
/****************************************************************/
/* Directive Simulation */
/****************************************************************/
% cross_multifile(+Indicator)
cross_multifile(F/N) :- !,
must_be(atom, F),
must_be(integer, N),
cross_multifile_safe(F, N).
cross_multifile(I) :-
throw(error(type_error(predicate_indicator,I),_)).
% cross_multifile_safe(+Atom, +Integer)
cross_multifile_safe(F, N) :-
once(cross_loading(S)),
(cross_predprop(F, N, cross_usage(D)),
S \== D,
\+ cross_predprop(F, N, cross_multifile(D)) ->
throw(error(permission_error(promote, multifile, F/N), _));
true),
assertz(cross_predprop(F, N, cross_multifile(S))).
% cross_dynamic(+Indicator, -Directive)
cross_dynamic(F/N, R) :- !,
must_be(atom, F),
must_be(integer, N),
cross_style_indicator(F, N, R),
cross_touch_dynamic(F, N).
cross_dynamic(I, _) :-
throw(error(type_error(predicate_indicator,I),_)).
% cross_discontiguous(+Indicator)
cross_discontiguous(F/N) :- !,
must_be(atom, F),
must_be(integer, N),
once(cross_loading(S)),
assertz(cross_predprop(F, N, cross_discontiguous(S))).
cross_discontiguous(I) :-
throw(error(type_error(predicate_indicator,I),_)).
/****************************************************************/
/* Character Utility */
/****************************************************************/
% cross_is_cntrl(+Code)
cross_is_cntrl(C) :- code_category(C, T), member(T, [15,16]).
% cross_is_invalid(+Code)
cross_is_invalid(C) :- code_category(C, T), member(T, [0,18,19]).
% cross_esc_codes2(+List, -List, +List)
cross_esc_codes2([H|T]) --> !, [H], cross_esc_codes2(T).
cross_esc_codes2([]) --> [].
% cross_esc_zeros(+Integer, -List, +List)
cross_esc_zeros(0) --> !.
cross_esc_zeros(N) --> [0'0], {M is N-1}, cross_esc_zeros(M).
% cross_high_surrogate(+Integer, -Integer)
cross_high_surrogate(X, Y) :- Y is (X >> 10) + 0xD7C0.
% cross_low_surrogate(+Integer, -Integer)
cross_low_surrogate(X, Y) :- Y is (X /\ 0x3FF) + 0xDC00.
/****************************************************************/
/* Anonymous Utility */
/****************************************************************/
% numberanon(+Term)
numberanon(T) :-
term_singletons(T, Z),
sys_numberanon(Z).
% sys_numberanon(+List)
sys_numberanon([]).
sys_numberanon(['$ANON'|L]) :-
sys_numberanon(L).