This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/pl/atoms.yap

213 lines
6.2 KiB
Prolog

/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-2014 *
* *
*************************************************************************/
%% @{
:- system_module( '$_atoms', [
atom_concat/2,
string_concat/2,
atomic_list_concat/2,
atomic_list_concat/3,
current_atom/1], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
%% @{
/**
* @addtogroup Predicates_on_Atoms
* @ingroup YAPChars
*
*/
/** @pred atom_concat(+ _As_,? _A_)
The predicate holds when the first argument is a list of atoms, and the
second unifies with the atom obtained by concatenating all the atoms in
the first list.
*/
atom_concat(Xs,At) :-
( var(At) ->
'$atom_concat'(Xs, At )
;
'$atom_concat_constraints'(Xs, 0, At, Unbound),
'$process_atom_holes'(Unbound)
).
% the constraints are of the form hole: HoleAtom, Begin, Atom, End
'$atom_concat_constraints'([At], 0, At, []) :- !.
'$atom_concat_constraints'([At0], mid(Next, At), At, [hole(At0, Next, At, end)]) :- !.
% just slice first atom
'$atom_concat_constraints'([At0|Xs], 0, At, Unbound) :-
atom(At0), !,
sub_atom(At0, 0, _Sz, L, _Ata ),
sub_atom(At, _, L, 0, Atr ), %remainder
'$atom_concat_constraints'(Xs, 0, Atr, Unbound).
% first hole: Follow says whether we have two holes in a row, At1 will be our atom
'$atom_concat_constraints'([At0|Xs], 0, At, [hole(At0, 0, At, Next)|Unbound]) :-
'$atom_concat_constraints'(Xs, mid(Next,_At1), At, Unbound).
% end of a run
'$atom_concat_constraints'([At0|Xs], mid(end, At1), At, Unbound) :-
atom(At0), !,
sub_atom(At, Next, _Sz, L, At0),
sub_atom(At, 0, Next, Next, At1),
sub_atom(At, _, L, 0, Atr), %remainder
'$atom_concat_constraints'(Xs, 0, Atr, Unbound).
'$atom_concat_constraints'([At0|Xs], mid(Next,At1), At, Next, [hole(At0, Next, At, Follow)|Unbound]) :-
'$atom_concat_constraints'(Xs, mid(Follow, At1), At, Unbound).
'$process_atom_holes'([]).
'$process_atom_holes'([hole(At0, Next, At1, End)|Unbound]) :- End == end, !,
sub_atom(At1, Next, _, 0, At0),
'$process_atom_holes'(Unbound).
'$process_atom_holes'([hole(At0, Next, At1, Follow)|Unbound]) :-
sub_atom(At1, Next, Sz, _Left, At0),
Follow is Next+Sz,
'$process_atom_holes'(Unbound).
/** @pred atomic_list_concat(+ _As_,? _A_)
The predicate holds when the first argument is a list of atomic terms, and
the second unifies with the atom obtained by concatenating all the
atomic terms in the first list. The first argument thus may contain
atoms or numbers.
*/
atomic_list_concat(L,At) :-
atomic_concat(L, At).
/** @pred atomic_list_concat(? _As_,+ _Separator_,? _A_)
Creates an atom just like atomic_list_concat/2, but inserts
_Separator_ between each pair of atoms. For example:
~~~~~{.prolog}
?- atomic_list_concat([gnu, gnat], `, `, A).
A = `gnu, gnat`
~~~~~
YAP emulates the SWI-Prolog version of this predicate that can also be
used to split atoms by instantiating _Separator_ and _Atom_ as
shown below.
~~~~~{.prolog}
?- atomic_list_concat(L, -, 'gnu-gnat').
L = [gnu, gnat]
~~~~~
*/
atomic_list_concat(L, El, At) :-
var(El), !,
'$do_error'(instantiation_error,atomic_list_concat(L,El,At)).
atomic_list_concat(L, El, At) :-
ground(L), !,
'$add_els'(L,El,LEl),
atomic_concat(LEl, At).
atomic_list_concat(L, El, At) :-
nonvar(At), !,
'$atomic_list_concat_all'( At, El, L).
'$atomic_list_concat_all'( At, El, [A|L]) :-
sub_atom(At, Pos, 1, Left, El), !,
sub_atom(At, 0, Pos, _, A),
sub_atom(At, _, Left, 0, At1),
'$atomic_list_concat_all'( At1, El, L).
'$atomic_list_concat_all'( At, _El, [At]).
'$add_els'([A,B|L],El,[A,El|NL]) :- !,
'$add_els'([B|L],El,NL).
'$add_els'(L,_,L).
%
% small compatibility hack
'$singletons_in_term'(T,VL) :-
'$variables_in_term'(T,[],V10),
'$sort'(V10, V1),
'$non_singletons_in_term'(T,[],V20),
'$sort'(V20, V2),
'$subtract_lists_of_variables'(V2,V1,VL).
'$subtract_lists_of_variables'([],VL,VL).
'$subtract_lists_of_variables'([_|_],[],[]) :- !.
'$subtract_lists_of_variables'([V1|VL1],[V2|VL2],VL) :-
V1 == V2, !,
'$subtract_lists_of_variables'(VL1,VL2,VL).
'$subtract_lists_of_variables'([V1|VL1],[V2|VL2],[V2|VL]) :-
'$subtract_lists_of_variables'([V1|VL1],VL2,VL).
/** @pred current_atom( _A_)
Checks whether _A_ is a currently defined atom. It is used to find all
currently defined atoms by backtracking.
*/
current_atom(A) :- % check
atom(A), !.
current_atom(A) :- % generate
'$current_atom'(A).
current_atom(A) :- % generate
'$current_wide_atom'(A).
string_concat(Xs,At) :-
( var(At) ->
'$string_concat'(Xs, At )
;
'$string_concat_constraints'(Xs, 0, At, Unbound),
'$process_string_holes'(Unbound)
).
% the constraints are of the form hole: HoleString, Begin, String, End
'$string_concat_constraints'([At], 0, At, []) :- !.
'$string_concat_constraints'([At0], mid(Next, At), At, [hole(At0, Next, At, end)]) :- !.
% just slice first string
'$string_concat_constraints'([At0|Xs], 0, At, Unbound) :-
string(At0), !,
sub_string(At, 0, _Sz, L, At0 ),
sub_string(At, _, L, 0, Atr ), %remainder
'$string_concat_constraints'(Xs, 0, Atr, Unbound).
% first hole: Follow says whether we have two holes in a row, At1 will be our string
'$string_concat_constraints'([At0|Xs], 0, At, [hole(At0, 0, At, Next)|Unbound]) :-
'$string_concat_constraints'(Xs, mid(Next,_At1), At, Unbound).
% end of a run
'$string_concat_constraints'([At0|Xs], mid(end, At1), At, Unbound) :-
string(At0), !,
sub_string(At, Next, _Sz, L, At0),
sub_string(At, 0, Next, Next, At1),
sub_string(At, _, L, 0, Atr), %remainder
'$string_concat_constraints'(Xs, 0, Atr, Unbound).
'$string_concat_constraints'([At0|Xs], mid(Next,At1), At, Next, [hole(At0, Next, At, Follow)|Unbound]) :-
'$string_concat_constraints'(Xs, mid(Follow, At1), At, Unbound).
'$process_string_holes'([]).
'$process_string_holes'([hole(At0, Next, At1, End)|Unbound]) :- End == end, !,
sub_string(At1, Next, _, 0, At0),
'$process_string_holes'(Unbound).
'$process_string_holes'([hole(At0, Next, At1, Follow)|Unbound]) :-
sub_string(At1, Next, Sz, _Left, At0),
Follow is Next+Sz,
'$process_string_holes'(Unbound).
/**
@}
*/