Home Page
Site Map
Login/out
Message Board
Download(c) 2005-2024 XLOG Technologies AG
/**
* 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('../config.p').
:- ensure_loaded('../../player/cross/main.p').
:- ensure_loaded('../../playerpy/cross/main.p').
:- ensure_loaded('../../playerj/cross/main.p').
:- ensure_loaded(library(util/files)).
run :-
env(doge, Doge),
set_prolog_flag(base_url, Doge),
write('js '), time(run_doge),
write('py '), time(runpy_doge),
write('j '), time(runj_doge).
/*******************************************************************/
/* Strip File */
/*******************************************************************/
/**
* strip_path(A, B):
* The predicate succeeds in copying the Prolog text file A
* into the Prolog text file B, with new header, stripped comments
* and beautified clauses and directives. The last modified date
* is also copied from file A to file B. The predicate silently
* overwrites an already existing file B.
*/
% strip_path(+Atom, +Atom)
strip_path(InName, OutName) :-
copy_text('transpiler/cross/header.p', OutName),
canonical_add(InName, OutName),
copy_time(InName, OutName).
% strip_pathdirs(+Atom, +Atom)
strip_pathdirs(InDir, OutDir) :-
ensure_directory(OutDir),
directory_member(InDir, Name),
sub_atom(Name, _, _, 0, '.p'),
atom_concat(InDir, Name, InName),
atom_concat(OutDir, Name, OutName),
strip_path(InName, OutName),
fail.
strip_pathdirs(InDir, OutDir) :-
directory_member(InDir, Name),
\+ sub_atom(Name, _, _, _, '.'),
atom_concat(Name, '/', Name2),
atom_concat(InDir, Name2, InName),
atom_concat(OutDir, Name2, OutName),
strip_pathdirs(InName, OutName),
fail.
strip_pathdirs(_, _).
/**
* copy_path(A, B):
* The predicate succeeds in copying the Prolog text file A
* into the Prolog text file B. The last modified date is also
* copied from file A to file B. The predicate silently
* overwrites an already existing file B.
*/
% copy_path(+Atom, +Atom)
copy_path(InName, OutName) :-
copy_text(InName, OutName),
copy_time(InName, OutName).
% copy_pathdirs(+Atom, +Atom)
copy_pathdirs(InDir, OutDir) :-
ensure_directory(OutDir),
directory_member(InDir, Name),
sub_atom(Name, _, _, 0, '.p'),
atom_concat(InDir, Name, InName),
atom_concat(OutDir, Name, OutName),
copy_path(InName, OutName),
fail.
copy_pathdirs(InDir, OutDir) :-
directory_member(InDir, Name),
\+ sub_atom(Name, _, _, _, '.'),
atom_concat(Name, '/', Name2),
atom_concat(InDir, Name2, InName),
atom_concat(OutDir, Name2, OutName),
copy_pathdirs(InName, OutName),
fail.
copy_pathdirs(_, _).
/**
* clean_path(A, B):
* The predicate succeeds in 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, +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, Ext) :-
directory_member(OutDir, Name),
sub_atom(Name, _, _, 0, Ext),
atom_concat(InDir, Name, InName),
atom_concat(OutDir, Name, OutName),
clean_path(InName, OutName),
fail.
clean_pathdirs(_, _, _).
/****************************************************************/
/* Style Checks */
/****************************************************************/
% cross_including(-Atom, -Stream)
:- multifile cross_including/2.
:- dynamic cross_including/2.
% cross_clear
cross_clear:-
retractall(cross_predprop(_,_,_)),
retractall(cross_currpred(_,_,_)).
/****************************************************************/
/* Predicate Tracking */
/****************************************************************/
% 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_pred(+Atom, +Integer, +Integer)
cross_touch_pred(F, N, 1) :-
cross_currpred(F, N, _), !.
cross_touch_pred(F, N, 0) :-
cross_currpred(F, N, O), !,
cross_touch_ok(F, N, O).
cross_touch_pred(F, N, O) :-
assertz(cross_currpred(F, N, O)).
% cross_touch_ok(+Atom, +Integer, +Integer)
cross_touch_ok(_, _, 0) :- !.
cross_touch_ok(F, N, 1) :-
Error = error(permission_error(modify,static_procedure,F/N), _),
cross_fill_stack(Error),
cross_print_error(Error).
/****************************************************************/
/* Style Check */
/****************************************************************/
% cross_loading(-Atom)
:- dynamic cross_loading/1.
% cross_lastpred(-Atom, -Integer)
:- dynamic cross_lastpred/2.
% cross_predprop(-Atom, -Integer, -Atom)
:- dynamic cross_predprop/3.
% cross_style_static(+Clause, +Integer, -List, +List)
cross_style_static(V, _) --> {var(V)}, !.
cross_style_static((:- _), _) --> !.
cross_style_static((H :- _), Flags) --> !,
cross_style_head(H, Flags).
cross_style_static(H, Flags) -->
cross_style_head(H, Flags).
% cross_style_head(+Term, +Integer, -List, +List)
cross_style_head(H, Flags) --> {callable(H)}, !,
{functor(H, F, N)},
cross_style_indicator(F, N, Flags).
cross_style_head(_, _) --> [].
% cross_style_indicator(+Atom, +Integer, +Integer, -List, +List)
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), _),
cross_fill_stack(Error),
cross_print_error(Error)),
cross_update_last(F, N)}.
cross_style_indicator(F, N, Flags) -->
cross_usage_predicate(F, N, Flags),
{cross_update_last(F, N)}.
% cross_usage_predicate(+Atom, +Integer, +Integer, -List, +List)
cross_usage_predicate(F, N, Flags) -->
{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)))},
({Flags /\ 2 =:= 0} ->
[(:- sys_usage_predicate(F, N))];
[]).
/****************************************************************/
/* Singleton Check */
/****************************************************************/
% cross_singleton_check(+Map)
cross_singleton_check([Name|Names]) :-
cross_assoc_keys([Name|Names], Keys),
Error = warning(syntax_error(singleton_var,Keys), _),
cross_fill_stack(Error),
cross_print_error(Error).
cross_singleton_check([]).
% cross_assoc_keys(+Map, -List)
cross_assoc_keys([N=_|L], [N|R]) :-
cross_assoc_keys(L, R).
cross_assoc_keys([], []).
/****************************************************************/
/* Directive Simulation */
/****************************************************************/
% cross_replace_term(+Term, +Integer, -List, +List)
cross_replace_term(V, _) --> {var(V)}, !, [V].
cross_replace_term((:- T), Flags) --> !,
cross_replace_directive(T, Flags).
cross_replace_term(T, _) --> [T].
% cross_replace_directive(+Term, +Integer, -List, +List)
cross_replace_directive(V, _) --> {var(V)}, !, [(:- V)].
cross_replace_directive(dynamic(I), Flags) --> !,
cross_dynamic(I, Flags), {I = F/N},
[(:- kb_pred_touch(F, N, 1))].
cross_replace_directive(discontiguous(I), Flags) --> !,
{cross_discontiguous(I), I = F/N},
({Flags /\ 2 =:= 0} ->
[(:- dg_get_partition(T), assertz(set_predprop(F, N, sys_discontiguous(T))))];
[]).
cross_replace_directive(multifile(I), Flags) --> !,
{cross_multifile(I), I = F/N},
({Flags /\ 2 =:= 0} ->
[(:- sys_multifile_safe(F, N))];
[]).
cross_replace_directive(T, _) --> [(:- T)].
% cross_dynamic(+Indicator, +Integer, -List, +List)
cross_dynamic(V, _) --> {var(V),
throw(error(instantiation_error,_))}.
cross_dynamic(F/N, Flags) --> !,
{cross_check_atom(F),
cross_check_integer(N)},
cross_style_indicator(F, N, Flags),
{cross_touch_pred(F, N, 0)}.
cross_dynamic(I, _) -->
{throw(error(type_error(predicate_indicator,I),_))}.
% cross_discontiguous(+Indicator)
cross_discontiguous(V) :- var(V),
throw(error(instantiation_error,_)).
cross_discontiguous(F/N) :- !,
cross_check_atom(F),
cross_check_integer(N),
once(cross_loading(S)),
assertz(cross_predprop(F, N, cross_discontiguous(S))).
cross_discontiguous(I) :-
throw(error(type_error(predicate_indicator,I),_)).
% cross_multifile(+Indicator)
cross_multifile(V) :- var(V),
throw(error(instantiation_error,_)).
cross_multifile(F/N) :- !,
cross_check_atom(F),
cross_check_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_defered(-Term, +Integer)
cross_defered(_, Flags) :- Flags /\ 2 =:= 0, !, fail.
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)).
/***************************************************************/
/* Property Helpers */
/***************************************************************/
% cross_update_last(+Atom, +Integer)
cross_update_last(F, N) :-
retractall(cross_lastpred(_, _)),
assertz(cross_lastpred(F, N)).
% cross_loading_begin(+Atom)
cross_loading_begin(S) :-
asserta(cross_loading(S)).
% cross_loading_end :-
cross_loading_end :-
once(retract(cross_loading(S))),
retractall(cross_lastpred(_, _)),
retractall(cross_predprop(_, _, cross_discontiguous(S))).
/****************************************************************/
/* Some Checks */
/****************************************************************/
% cross_check_atom(+Term)
cross_check_atom(V) :- var(V),
cross_throw(error(instantiation_error,_)).
cross_check_atom(A) :- atom(A), !.
cross_check_atom(A) :-
cross_throw(error(type_error(atom,A),_)).
% cross_check_integer(+Term)
cross_check_integer(V) :- var(V),
cross_throw(error(instantiation_error,_)).
cross_check_integer(I) :- integer(I), !.
cross_check_integer(I) :-
cross_throw(error(type_error(integer,I),_)).
/*************************************************************/
/* Character Utility */
/*************************************************************/
% cross_is_cntrl(+Code)
cross_is_cntrl(C) :- code_type(C, T), member(T, [15,16]).
% cross_is_invalid(+Code)
cross_is_invalid(C) :- code_type(C, T), member(T, [0,18,19]).
% cross_escape_codes2(+List, -List, +List)
cross_escape_codes2([H|T]) --> !, [H], cross_escape_codes2(T).
cross_escape_codes2([]) --> [].
% cross_escape_zeros(+Integer, -List, +List)
cross_escape_zeros(0) --> !.
cross_escape_zeros(N) --> [0'0], {M is N-1}, cross_escape_zeros(M).
/*************************************************************/
/* Initialization */
/*************************************************************/
:- initialization(run).