rishi/scryer-prolog
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

remove vestigial prolog/ directory (#444)

Browse Source
This commit is contained in:
Mark Thom
2020-06-12 18:26:38 -06:00
parent 5ffb4597b3
commit 33325f1574
89 changed files with 327 additions and 298 deletions
Download Patch File Download Diff File Expand all files Collapse all files

123
src/lib/arithmetic.pl Normal file
View File

@@ -0,0 +1,123 @@
:- module(arithmetic, [expmod/4, lsb/2, msb/2, number_to_rational/2,
number_to_rational/3,
rational_numerator_denominator/3]).
:- use_module(library(charsio), [write_term_to_chars/3]).
:- use_module(library(error)).
:- use_module(library(lists), [append/3, member/2]).
expmod(Base, Expo, Mod, R) :-
( member(N, [Base, Expo, Mod]), var(N) -> instantiation_error(expmod/4)
; member(N, [Base, Expo, Mod]), \+ integer(N) ->
type_error(integer, N, expmod/4)
; Expo < 0 -> domain_error(not_less_than_zero, Expo, expmod/4)
; expmod_(Base, Expo, Mod, 1, R)
).
expmod_(_, _, 1, _, 0) :- !.
expmod_(_, 0, _, R, R) :- !.
expmod_(Base0, Expo0, Mod, C0, R) :-
Expo0 /\ 1 =:= 1,
C is (C0 * Base0) mod Mod,
!,
Expo is Expo0 >> 1,
Base is (Base0 * Base0) mod Mod,
expmod_(Base, Expo, Mod, C, R).
expmod_(Base0, Expo0, Mod, C, R) :-
Expo is Expo0 >> 1,
Base is (Base0 * Base0) mod Mod,
expmod_(Base, Expo, Mod, C, R).
lsb(X, N) :-
builtins:must_be_number(X, lsb/2),
( \+ integer(X) -> type_error(integer, X, lsb/2)
; X < 1 -> domain_error(not_less_than_one, X, lsb/2)
; builtins:can_be_number(N, lsb/2),
X1 is X /\ (-X),
msb_(X1, -1, N)
).
msb(X, N) :-
builtins:must_be_number(X, msb/2),
( \+ integer(X) -> type_error(integer, X, msb/2)
; X < 1 -> domain_error(not_less_than_one, X, msb/2)
; builtins:can_be_number(N, msb/2),
X1 is X >> 1,
msb_(X1, 0, N)
).
msb_(0, N, N) :- !.
msb_(X, M, N) :-
X1 is X >> 1,
M1 is M + 1,
msb_(X1, M1, N).
number_to_rational(Real, Fraction) :-
( var(Real) -> instantiation_error(number_to_rational/2)
; integer(Real) -> Fraction is Real rdiv 1
; (rational(Real) ; float(Real)) ->
number_to_rational(1.0e-6, Real, Fraction)
; type_error(number, Real, number_to_rational/2)
).
% If 0 <= Eps0 <= 1e-16 then the search is for "infinite" precision.
number_to_rational(Eps0, Real0, Fraction) :-
( var(Eps0) -> instantiation_error(number_to_rational/3)
; \+ number(Eps0) -> type_error(number, Eps0, number_to_rational/3)
; Eps0 < 0 -> domain_error(not_less_than_zero, Eps0, number_to_rational/3)
; Eps_ is Eps0 rdiv 1,
rational_numerator_denominator(Eps_, EpsN, EpsD),
Eps = EpsN/EpsD
),
( var(Real0) -> instantiation_error(number_to_rational/3)
; \+ number(Real0) -> type_error(number, Eps0, number_to_rational/3)
; Real_ is Real0 rdiv 1,
rational_numerator_denominator(Real_, RealN, RealD),
Real = RealN/RealD
),
E0/E1 = Eps,
P0/Q0 = Real,
( P0 < 0 -> I1 is -1 + P0 // Q0
; I1 is P0 // Q0
),
P1 is P0 mod Q0,
Q1 = Q0,
( P1 =:= 0 -> Fraction is I1 + 0 rdiv 1
; Qn1n is max(P1 * E1 - Q1 * E0, 0),
Qn1d is Q1 * E1,
Qn1 = Qn1n/Qn1d,
Qp1n is P1 * E1 + Q1 * E0,
Qp1d = Qn1d,
Qp1 = Qp1n/Qp1d,
stern_brocot_(Qn1, Qp1, 0/1, 1/0, P2/Q2),
Fraction is I1 + P2 rdiv Q2
),
!.
number(X) :-
( integer(X)
; float(X)
; rational(X)
).
stern_brocot_(Qnn/Qnd, Qpn/Qpd, A/B, C/D, Fraction) :-
Fn1 is A + C,
Fd1 is B + D,
simplify_fraction(Fn1/Fd1, Fn/Fd),
S1 is sign(Fn * Qnd - Fd * Qnn),
S2 is sign(Fn * Qpd - Fd * Qpn),
( S1 < 0 -> stern_brocot_(Qnn/Qnd, Qpn/Qpd, Fn/Fd, C/D, Fraction)
; S2 > 0 -> stern_brocot_(Qnn/Qnd, Qpn/Qpd, A/B, Fn/Fd, Fraction)
; Fraction = Fn/Fd
).
simplify_fraction(A0/B0, A/B) :-
G is gcd(A0, B0),
A is A0 // G,
B is B0 // G.
rational_numerator_denominator(R, N, D) :-
write_term_to_chars(R, [], Cs),
append(Ns, [' ', r, d, i, v, ' '|Ds], Cs),
number_chars(N, Ns),
number_chars(D, Ds).

489
src/lib/assoc.pl Normal file
View File

@@ -0,0 +1,489 @@
/* Author: R.A.O'Keefe, L.Damas, V.S.Costa, Glenn Burgess,
Jiri Spitz and Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 2004-2018, various people and institutions
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(assoc,
[ empty_assoc/1, % -Assoc
is_assoc/1, % +Assoc
assoc_to_list/2, % +Assoc, -Pairs
assoc_to_keys/2, % +Assoc, -List
assoc_to_values/2, % +Assoc, -List
gen_assoc/3, % ?Key, +Assoc, ?Value
get_assoc/3, % +Key, +Assoc, ?Value
get_assoc/5, % +Key, +Assoc0, ?Val0, ?Assoc, ?Val
list_to_assoc/2, % +List, ?Assoc
map_assoc/2, % :Goal, +Assoc
map_assoc/3, % :Goal, +Assoc0, ?Assoc
max_assoc/3, % +Assoc, ?Key, ?Value
min_assoc/3, % +Assoc, ?Key, ?Value
ord_list_to_assoc/2, % +List, ?Assoc
put_assoc/4, % +Key, +Assoc0, +Value, ?Assoc
del_assoc/4, % +Key, +Assoc0, ?Value, ?Assoc
del_min_assoc/4, % +Assoc0, ?Key, ?Value, ?Assoc
del_max_assoc/4 % +Assoc0, ?Key, ?Value, ?Assoc
]).
:- use_module(library(lists)).
/** <module> Binary associations
Assocs are Key-Value associations implemented as a balanced binary tree
(AVL tree).
@see library(pairs), library(rbtrees)
@author R.A.O'Keefe, L.Damas, V.S.Costa and Jan Wielemaker
*/
/*
:- meta_predicate
map_assoc(1, ?),
map_assoc(2, ?, ?).
*/
%! empty_assoc(?Assoc) is semidet.
%
% Is true if Assoc is the empty association list.
empty_assoc(t).
%! assoc_to_list(+Assoc, -Pairs) is det.
%
% Translate Assoc to a list Pairs of Key-Value pairs. The keys
% in Pairs are sorted in ascending order.
assoc_to_list(Assoc, List) :-
assoc_to_list(Assoc, List, []).
assoc_to_list(t(Key,Val,_,L,R), List, Rest) :-
assoc_to_list(L, List, [Key-Val|More]),
assoc_to_list(R, More, Rest).
assoc_to_list(t, List, List).
%! assoc_to_keys(+Assoc, -Keys) is det.
%
% True if Keys is the list of keys in Assoc. The keys are sorted
% in ascending order.
assoc_to_keys(Assoc, List) :-
assoc_to_keys(Assoc, List, []).
assoc_to_keys(t(Key,_,_,L,R), List, Rest) :-
assoc_to_keys(L, List, [Key|More]),
assoc_to_keys(R, More, Rest).
assoc_to_keys(t, List, List).
%! assoc_to_values(+Assoc, -Values) is det.
%
% True if Values is the list of values in Assoc. Values are
% ordered in ascending order of the key to which they were
% associated. Values may contain duplicates.
assoc_to_values(Assoc, List) :-
assoc_to_values(Assoc, List, []).
assoc_to_values(t(_,Value,_,L,R), List, Rest) :-
assoc_to_values(L, List, [Value|More]),
assoc_to_values(R, More, Rest).
assoc_to_values(t, List, List).
%! is_assoc(+Assoc) is semidet.
%
% True if Assoc is an association list. This predicate checks
% that the structure is valid, elements are in order, and tree
% is balanced to the extent guaranteed by AVL trees. I.e.,
% branches of each subtree differ in depth by at most 1.
is_assoc(Assoc) :-
is_assoc(Assoc, _Min, _Max, _Depth).
is_assoc(t,X,X,0) :- !.
is_assoc(t(K,_,-,t,t),K,K,1) :- !, ground(K).
is_assoc(t(K,_,>,t,t(RK,_,-,t,t)),K,RK,2) :-
% Ensure right side Key is 'greater' than K
!, ground((K,RK)), K @< RK.
is_assoc(t(K,_,<,t(LK,_,-,t,t),t),LK,K,2) :-
% Ensure left side Key is 'less' than K
!, ground((LK,K)), LK @< K.
is_assoc(t(K,_,B,L,R),Min,Max,Depth) :-
is_assoc(L,Min,LMax,LDepth),
is_assoc(R,RMin,Max,RDepth),
% Ensure Balance matches depth
compare(Rel,RDepth,LDepth),
balance(Rel,B),
% Ensure ordering
ground((LMax,K,RMin)),
LMax @< K,
K @< RMin,
Depth is max(LDepth, RDepth)+1.
% Private lookup table matching comparison operators to Balance operators used in tree
balance(=,-).
balance(<,<).
balance(>,>).
%! gen_assoc(?Key, +Assoc, ?Value) is nondet.
%
% True if Key-Value is an association in Assoc. Enumerates keys in
% ascending order on backtracking.
%
% @see get_assoc/3.
gen_assoc(Key, Assoc, Value) :-
( ground(Key)
-> get_assoc(Key, Assoc, Value)
; gen_assoc_(Key, Assoc, Value)
).
gen_assoc_(Key, t(_,_,_,L,_), Val) :-
gen_assoc_(Key, L, Val).
gen_assoc_(Key, t(Key,Val,_,_,_), Val).
gen_assoc_(Key, t(_,_,_,_,R), Val) :-
gen_assoc_(Key, R, Val).
%! get_assoc(+Key, +Assoc, -Value) is semidet.
%
% True if Key-Value is an association in Assoc.
%
% @error type_error(assoc, Assoc) if Assoc is not an association list.
get_assoc(Key, Assoc, Val) :-
must_be(assoc, Assoc),
get_assoc_(Key, Assoc, Val).
/*
:- if(current_predicate('$btree_find_node'/5)).
get_assoc_(Key, Tree, Val) :-
Tree \== t,
'$btree_find_node'(Key, Tree, 0x010405, Node, =),
arg(2, Node, Val).
:- else.
*/
get_assoc_(Key, t(K,V,_,L,R), Val) :-
compare(Rel, Key, K),
get_assoc(Rel, Key, V, L, R, Val).
get_assoc(=, _, Val, _, _, Val).
get_assoc(<, Key, _, Tree, _, Val) :-
get_assoc(Key, Tree, Val).
get_assoc(>, Key, _, _, Tree, Val) :-
get_assoc(Key, Tree, Val).
% :- endif.
%! get_assoc(+Key, +Assoc0, ?Val0, ?Assoc, ?Val) is semidet.
%
% True if Key-Val0 is in Assoc0 and Key-Val is in Assoc.
get_assoc(Key, t(K,V,B,L,R), Val, t(K,NV,B,NL,NR), NVal) :-
compare(Rel, Key, K),
get_assoc(Rel, Key, V, L, R, Val, NV, NL, NR, NVal).
get_assoc(=, _, Val, L, R, Val, NVal, L, R, NVal).
get_assoc(<, Key, V, L, R, Val, V, NL, R, NVal) :-
get_assoc(Key, L, Val, NL, NVal).
get_assoc(>, Key, V, L, R, Val, V, L, NR, NVal) :-
get_assoc(Key, R, Val, NR, NVal).
%! list_to_assoc(+Pairs, -Assoc) is det.
%
% Create an association from a list Pairs of Key-Value pairs. List
% must not contain duplicate keys.
%
% @error domain_error(unique_key_pairs, List) if List contains duplicate keys
list_to_assoc(List, Assoc) :-
( List = [] -> Assoc = t
; keysort(List, Sorted),
( ord_pairs(Sorted)
-> length(Sorted, N),
list_to_assoc(N, Sorted, [], _, Assoc)
; throw(error(domain_error(unique_key_pairs, List), list_to_assoc/2))
)
).
list_to_assoc(1, [K-V|More], More, 1, t(K,V,-,t,t)) :- !.
list_to_assoc(2, [K1-V1,K2-V2|More], More, 2, t(K2,V2,<,t(K1,V1,-,t,t),t)) :- !.
list_to_assoc(N, List, More, Depth, t(K,V,Balance,L,R)) :-
N0 is N - 1,
RN is N0 div 2,
Rem is N0 mod 2,
LN is RN + Rem,
list_to_assoc(LN, List, [K-V|Upper], LDepth, L),
list_to_assoc(RN, Upper, More, RDepth, R),
Depth is LDepth + 1,
compare(B, RDepth, LDepth),
balance(B, Balance).
%! ord_list_to_assoc(+Pairs, -Assoc) is det.
%
% Assoc is created from an ordered list Pairs of Key-Value
% pairs. The pairs must occur in strictly ascending order of
% their keys.
%
% @error domain_error(key_ordered_pairs, List) if pairs are not ordered.
ord_list_to_assoc(Sorted, Assoc) :-
( Sorted = [] -> Assoc = t
; ( ord_pairs(Sorted)
-> length(Sorted, N),
list_to_assoc(N, Sorted, [], _, Assoc)
; domain_error(key_ordered_pairs, Sorted)
)
).
%! ord_pairs(+Pairs) is semidet
%
% True if Pairs is a list of Key-Val pairs strictly ordered by key.
ord_pairs([K-_V|Rest]) :-
ord_pairs(Rest, K).
ord_pairs([], _K).
ord_pairs([K-_V|Rest], K0) :-
K0 @< K,
ord_pairs(Rest, K).
%! map_assoc(:Pred, +Assoc) is semidet.
%
% True if Pred(Value) is true for all values in Assoc.
map_assoc(Pred, T) :-
map_assoc_(T, Pred).
map_assoc_(t, _).
map_assoc_(t(_,Val,_,L,R), Pred) :-
map_assoc_(L, Pred),
call(Pred, Val),
map_assoc_(R, Pred).
%! map_assoc(:Pred, +Assoc0, ?Assoc) is semidet.
%
% Map corresponding values. True if Assoc is Assoc0 with Pred
% applied to all corresponding pairs of of values.
map_assoc(Pred, T0, T) :-
map_assoc_(T0, Pred, T).
map_assoc_(t, _, t).
map_assoc_(t(Key,Val,B,L0,R0), Pred, t(Key,Ans,B,L1,R1)) :-
map_assoc_(L0, Pred, L1),
call(Pred, Val, Ans),
map_assoc_(R0, Pred, R1).
%! max_assoc(+Assoc, -Key, -Value) is semidet.
%
% True if Key-Value is in Assoc and Key is the largest key.
max_assoc(t(K,V,_,_,R), Key, Val) :-
max_assoc(R, K, V, Key, Val).
max_assoc(t, K, V, K, V).
max_assoc(t(K,V,_,_,R), _, _, Key, Val) :-
max_assoc(R, K, V, Key, Val).
%! min_assoc(+Assoc, -Key, -Value) is semidet.
%
% True if Key-Value is in assoc and Key is the smallest key.
min_assoc(t(K,V,_,L,_), Key, Val) :-
min_assoc(L, K, V, Key, Val).
min_assoc(t, K, V, K, V).
min_assoc(t(K,V,_,L,_), _, _, Key, Val) :-
min_assoc(L, K, V, Key, Val).
%! put_assoc(+Key, +Assoc0, +Value, -Assoc) is det.
%
% Assoc is Assoc0, except that Key is associated with
% Value. This can be used to insert and change associations.
put_assoc(Key, A0, Value, A) :-
insert(A0, Key, Value, A, _).
insert(t, Key, Val, t(Key,Val,-,t,t), yes).
insert(t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
compare(Rel, K, Key),
insert(Rel, t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged).
insert(=, t(Key,_,B,L,R), _, V, t(Key,V,B,L,R), no).
insert(<, t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
insert(L, K, V, NewL, LeftHasChanged),
adjust(LeftHasChanged, t(Key,Val,B,NewL,R), left, NewTree, WhatHasChanged).
insert(>, t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
insert(R, K, V, NewR, RightHasChanged),
adjust(RightHasChanged, t(Key,Val,B,L,NewR), right, NewTree, WhatHasChanged).
adjust(no, Oldree, _, Oldree, no).
adjust(yes, t(Key,Val,B0,L,R), LoR, NewTree, WhatHasChanged) :-
table(B0, LoR, B1, WhatHasChanged, ToBeRebalanced),
rebalance(ToBeRebalanced, t(Key,Val,B0,L,R), B1, NewTree, _, _).
% balance where balance whole tree to be
% before inserted after increased rebalanced
table(- , left , < , yes , no ) :- !.
table(- , right , > , yes , no ) :- !.
table(< , left , - , no , yes ) :- !.
table(< , right , - , no , no ) :- !.
table(> , left , - , no , no ) :- !.
table(> , right , - , no , yes ) :- !.
%! del_min_assoc(+Assoc0, ?Key, ?Val, -Assoc) is semidet.
%
% True if Key-Value is in Assoc0 and Key is the smallest key.
% Assoc is Assoc0 with Key-Value removed. Warning: This will
% succeed with _no_ bindings for Key or Val if Assoc0 is empty.
del_min_assoc(Tree, Key, Val, NewTree) :-
del_min_assoc(Tree, Key, Val, NewTree, _DepthChanged).
del_min_assoc(t(Key,Val,_B,t,R), Key, Val, R, yes) :- !.
del_min_assoc(t(K,V,B,L,R), Key, Val, NewTree, Changed) :-
del_min_assoc(L, Key, Val, NewL, LeftChanged),
deladjust(LeftChanged, t(K,V,B,NewL,R), left, NewTree, Changed).
%! del_max_assoc(+Assoc0, ?Key, ?Val, -Assoc) is semidet.
%
% True if Key-Value is in Assoc0 and Key is the greatest key.
% Assoc is Assoc0 with Key-Value removed. Warning: This will
% succeed with _no_ bindings for Key or Val if Assoc0 is empty.
del_max_assoc(Tree, Key, Val, NewTree) :-
del_max_assoc(Tree, Key, Val, NewTree, _DepthChanged).
del_max_assoc(t(Key,Val,_B,L,t), Key, Val, L, yes) :- !.
del_max_assoc(t(K,V,B,L,R), Key, Val, NewTree, Changed) :-
del_max_assoc(R, Key, Val, NewR, RightChanged),
deladjust(RightChanged, t(K,V,B,L,NewR), right, NewTree, Changed).
%! del_assoc(+Key, +Assoc0, ?Value, -Assoc) is semidet.
%
% True if Key-Value is in Assoc0. Assoc is Assoc0 with
% Key-Value removed.
del_assoc(Key, A0, Value, A) :-
delete(A0, Key, Value, A, _).
% delete(+Subtree, +SearchedKey, ?SearchedValue, ?SubtreeOut, ?WhatHasChanged)
delete(t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
compare(Rel, K, Key),
delete(Rel, t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged).
% delete(+KeySide, +Subtree, +SearchedKey, ?SearchedValue, ?SubtreeOut, ?WhatHasChanged)
% KeySide is an operator {<,=,>} indicating which branch should be searched for the key.
% WhatHasChanged {yes,no} indicates whether the NewTree has changed in depth.
delete(=, t(Key,Val,_B,t,R), Key, Val, R, yes) :- !.
delete(=, t(Key,Val,_B,L,t), Key, Val, L, yes) :- !.
delete(=, t(Key,Val,>,L,R), Key, Val, NewTree, WhatHasChanged) :-
% Rh tree is deeper, so rotate from R to L
del_min_assoc(R, K, V, NewR, RightHasChanged),
deladjust(RightHasChanged, t(K,V,>,L,NewR), right, NewTree, WhatHasChanged),
!.
delete(=, t(Key,Val,B,L,R), Key, Val, NewTree, WhatHasChanged) :-
% Rh tree is not deeper, so rotate from L to R
del_max_assoc(L, K, V, NewL, LeftHasChanged),
deladjust(LeftHasChanged, t(K,V,B,NewL,R), left, NewTree, WhatHasChanged),
!.
delete(<, t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
delete(L, K, V, NewL, LeftHasChanged),
deladjust(LeftHasChanged, t(Key,Val,B,NewL,R), left, NewTree, WhatHasChanged).
delete(>, t(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
delete(R, K, V, NewR, RightHasChanged),
deladjust(RightHasChanged, t(Key,Val,B,L,NewR), right, NewTree, WhatHasChanged).
deladjust(no, OldTree, _, OldTree, no).
deladjust(yes, t(Key,Val,B0,L,R), LoR, NewTree, RealChange) :-
deltable(B0, LoR, B1, WhatHasChanged, ToBeRebalanced),
rebalance(ToBeRebalanced, t(Key,Val,B0,L,R), B1, NewTree, WhatHasChanged, RealChange).
% balance where balance whole tree to be
% before deleted after changed rebalanced
deltable(- , right , < , no , no ) :- !.
deltable(- , left , > , no , no ) :- !.
deltable(< , right , - , yes , yes ) :- !.
deltable(< , left , - , yes , no ) :- !.
deltable(> , right , - , yes , no ) :- !.
deltable(> , left , - , yes , yes ) :- !.
% It depends on the tree pattern in avl_geq whether it really decreases.
% Single and double tree rotations - these are common for insert and delete.
/* The patterns (>)-(>), (>)-( <), ( <)-( <) and ( <)-(>) on the LHS
always change the tree height and these are the only patterns which can
happen after an insertion. That's the reason why we can use a table only to
decide the needed changes.
The patterns (>)-( -) and ( <)-( -) do not change the tree height. After a
deletion any pattern can occur and so we return yes or no as a flag of a
height change. */
rebalance(no, t(K,V,_,L,R), B, t(K,V,B,L,R), Changed, Changed).
rebalance(yes, OldTree, _, NewTree, _, RealChange) :-
avl_geq(OldTree, NewTree, RealChange).
avl_geq(t(A,VA,>,Alpha,t(B,VB,>,Beta,Gamma)),
t(B,VB,-,t(A,VA,-,Alpha,Beta),Gamma), yes) :- !.
avl_geq(t(A,VA,>,Alpha,t(B,VB,-,Beta,Gamma)),
t(B,VB,<,t(A,VA,>,Alpha,Beta),Gamma), no) :- !.
avl_geq(t(B,VB,<,t(A,VA,<,Alpha,Beta),Gamma),
t(A,VA,-,Alpha,t(B,VB,-,Beta,Gamma)), yes) :- !.
avl_geq(t(B,VB,<,t(A,VA,-,Alpha,Beta),Gamma),
t(A,VA,>,Alpha,t(B,VB,<,Beta,Gamma)), no) :- !.
avl_geq(t(A,VA,>,Alpha,t(B,VB,<,t(X,VX,B1,Beta,Gamma),Delta)),
t(X,VX,-,t(A,VA,B2,Alpha,Beta),t(B,VB,B3,Gamma,Delta)), yes) :-
!,
table2(B1, B2, B3).
avl_geq(t(B,VB,<,t(A,VA,>,Alpha,t(X,VX,B1,Beta,Gamma)),Delta),
t(X,VX,-,t(A,VA,B2,Alpha,Beta),t(B,VB,B3,Gamma,Delta)), yes) :-
!,
table2(B1, B2, B3).
table2(< ,- ,> ).
table2(> ,< ,- ).
table2(- ,- ,- ).
must_be(assoc, X) :-
( X == t
-> true
; compound(X),
functor(X, t, 5)
), !.
must_be(assoc, X) :-
throw(error(type_error(assoc, X), _)).

165
src/lib/atts.pl Normal file
View File

@@ -0,0 +1,165 @@
:- module(atts, [op(1199, fx, attribute), call_residue_vars/2,
term_attributed_variables/2,
'$absent_attr'/2, '$copy_attr_list'/2, '$get_attr'/2,
'$put_attr'/2, '$absent_from_list'/2,
'$get_from_list'/3, '$add_to_list'/3, '$del_attr'/3,
'$del_attr_step'/3, '$del_attr_buried'/4,
'$default_attr_list'/4]).
:- use_module(library(dcgs)).
:- use_module(library(terms)).
/* represent the list of attributes belonging to a variable,
of a particular module, as a list of terms of the form
Module:put_atts(V, ListOfAtts). */
'$default_attr_list'(Module, V) -->
( { Module:get_atts(V, Attributes) } ->
'$default_attr_list'(Attributes, Module, V)
; []
).
'$default_attr_list'([PG | PGs], Module, AttrVar) -->
( { '$module_of'(Module, PG) } -> [Module:put_atts(AttrVar, PG)]
; { true }
),
'$default_attr_list'(PGs, Module, AttrVar).
'$default_attr_list'([], _, _) --> [].
'$absent_attr'(V, Attr) :-
'$get_attr_list'(V, Ls),
'$absent_from_list'(Ls, Attr).
'$absent_from_list'(X, Attr) :-
( var(X) -> true
; X = [L|Ls], L \= Attr -> '$absent_from_list'(Ls, Attr)
).
'$get_attr'(V, Attr) :-
'$get_attr_list'(V, Ls), nonvar(Ls), '$get_from_list'(Ls, V, Attr).
'$get_from_list'([L|Ls], V, Attr) :-
nonvar(L),
( L \= Attr -> nonvar(Ls), '$get_from_list'(Ls, V, Attr)
; L = Attr, '$enqueue_attr_var'(V)
).
'$put_attr'(V, Attr) :-
'$get_attr_list'(V, Ls), '$add_to_list'(Ls, V, Attr).
'$add_to_list'(Ls, V, Attr) :-
( var(Ls) ->
Ls = [Attr | _], '$enqueue_attr_var'(V)
; Ls = [_ | Ls0], '$add_to_list'(Ls0, V, Attr)
).
'$del_attr'(Ls0, _, _) :-
var(Ls0), !.
'$del_attr'(Ls0, V, Attr) :-
Ls0 = [Att | Ls1],
nonvar(Att),
( Att \= Attr ->
'$del_attr_buried'(Ls0, Ls1, V, Attr)
; '$enqueue_attr_var'(V),
'$del_attr_head'(V),
'$del_attr'(Ls1, V, Attr)
).
'$del_attr_step'(Ls1, V, Attr) :-
( nonvar(Ls1) -> Ls1 = [_ | Ls2], '$del_attr_buried'(Ls1, Ls2, V, Attr)
; true ).
%% assumptions: Ls0 is a list, Ls1 is its tail;
%% the head of Ls0 can be ignored.
'$del_attr_buried'(Ls0, Ls1, V, Attr) :-
( var(Ls1) -> true
; Ls1 = [Att | Ls2] ->
( Att \= Attr -> '$del_attr_buried'(Ls1, Ls2, V, Attr)
; '$enqueue_attr_var'(V),
'$del_attr_non_head'(Ls0), %% set tail of Ls0 = tail of Ls1. can be undone by backtracking.
'$del_attr_step'(Ls1, V, Attr)
)
).
'$copy_attr_list'(L, []) :- var(L), !.
'$copy_attr_list'([Att|Atts], [Att|CopiedAtts]) :-
'$copy_attr_list'(Atts, CopiedAtts).
user:term_expansion(Term0, Terms) :-
nonvar(Term0),
Term0 = (:- attribute Atts),
nonvar(Atts),
phrase(expand_terms(Atts), Terms).
expand_terms(Atts) -->
put_attrs_var_check,
put_attrs(Atts),
get_attrs_var_check,
get_attrs(Atts).
put_attrs_var_check -->
{ numbervars([Var, Attr], 0, _) },
[(put_atts(Var, Attr) :- nonvar(Var), throw(error(type_error(variable, Var), put_atts/2))),
(put_atts(Var, Attr) :- var(Attr), throw(error(instantiation_error, put_atts/2)))].
get_attrs_var_check -->
{ numbervars([Var, Ls, Attr], 0, _) },
[(get_atts(Var, Attr) :- nonvar(Var), throw(error(type_error(variable, Var), get_atts/2))),
(get_atts(Var, Attr) :- var(Attr), !, '$get_attr_list'(Var, Ls), nonvar(Ls),
'$copy_attr_list'(Ls, Attr))].
put_attrs(Name/Arity) -->
put_attr(Name, Arity),
{ numbervars([Var, Attr], 0, _) },
[(put_atts(Var, Attr) :- lists:maplist(put_atts(Var), Attr), !)].
put_attrs((Name/Arity, Atts)) -->
{ nonvar(Atts) },
put_attr(Name, Arity),
put_attrs(Atts).
get_attrs(Name/Arity) -->
get_attr(Name, Arity).
get_attrs((Name/Arity, Atts)) -->
{ nonvar(Atts) },
get_attr(Name, Arity),
get_attrs(Atts).
put_attr(Name, Arity) -->
{ functor(Attr, Name, Arity),
numbervars(Attr, 0, Arity),
V = '$VAR'(Arity) },
[(put_atts(V, +Attr) :- !, functor(Attr, Head, Arity),
functor(AttrForm, Head, Arity),
'$get_attr_list'(V, Ls),
'$del_attr'(Ls, V, AttrForm),
'$put_attr'(V, Attr)),
(put_atts(V, Attr) :- !, functor(Attr, Head, Arity),
functor(AttrForm, Head, Arity),
'$get_attr_list'(V, Ls),
'$del_attr'(Ls, V, AttrForm),
'$put_attr'(V, Attr)),
(put_atts(V, -Attr) :- !, functor(Attr, _, _),
'$get_attr_list'(V, Ls),
'$del_attr'(Ls, V, Attr))].
get_attr(Name, Arity) -->
{ functor(Attr, Name, Arity),
numbervars(Attr, 0, Arity),
V = '$VAR'(Arity) },
[(get_atts(V, +Attr) :- !, functor(Attr, _, _), '$get_attr'(V, Attr)),
(get_atts(V, Attr) :- !, functor(Attr, _, _), '$get_attr'(V, Attr)),
(get_atts(V, -Attr) :- !, functor(Attr, _, _), '$absent_attr'(V, Attr))].
user:goal_expansion(Term, M:put_atts(Var, Attr)) :-
nonvar(Term),
Term = put_atts(Var, M, Attr).
user:goal_expansion(Term, M:get_atts(Var, Attr)) :-
nonvar(Term),
Term = get_atts(Var, M, Attr).
call_residue_vars(Goal, Vars) :-
'$get_attr_var_queue_delim'(B),
call(Goal),
'$get_attr_var_queue_beyond'(B, Vars).
term_attributed_variables(Term, Vars) :-
'$term_attributed_variables'(Term, Vars).

107
src/lib/between.pl Normal file
View File

@@ -0,0 +1,107 @@
:- module(between, [between/3, gen_int/1, gen_nat/1, numlist/2, numlist/3, repeat/1]).
%% TODO: numlist/5.
:- use_module(library(lists), [length/2]).
:- use_module(library(error)).
between(Lower, Upper, X) :-
must_be(integer, Lower),
must_be(integer, Upper),
can_be(integer, X),
( nonvar(X) ->
Lower =< X,
X =< Upper
; between_(Lower, Upper, X)
).
between_(Lower, Upper, Lower) :-
Lower =< Upper.
between_(Lower1, Upper, X) :-
Lower1 < Upper,
Lower2 is Lower1 + 1,
between_(Lower2, Upper, X).
enumerate_nats(I, I).
enumerate_nats(I0, N) :-
I1 is I0 + 1,
enumerate_nats(I1, N).
gen_nat(N) :-
can_be(integer, N),
( var(N) -> enumerate_nats(0, N)
; true
).
enumerate_ints(I, I).
enumerate_ints(I0, N) :-
I0 > 0,
N is -I0.
enumerate_ints(I0, N) :-
I1 is I0 + 1,
enumerate_ints(I1, N).
gen_int(N) :-
can_be(integer, N),
( var(N) -> enumerate_ints(0, N)
; true
).
repeat_integer(N) :-
N > 0.
repeat_integer(N0) :-
N0 > 0, N1 is N0 - 1, repeat_integer(N1).
repeat(N) :-
must_be(integer, N), repeat_integer(N).
numlist(Upper, List) :-
( integer(Upper) -> findall(X, between(1, Upper, X), List)
; List = [_|_], length(List, Upper), findall(X, between(1, Upper, X), List)
).
diag_nats(M, N, M, N).
diag_nats(M, 0, M1, N1) :-
!,
M0 is M+1,
diag_nats(0, M0, M1, N1).
diag_nats(M, N, M1, N1) :-
M0 is M+1,
N0 is N-1,
diag_nats(M0, N0, M1, N1).
diag_nats(0, 0).
diag_nats(M, N) :-
diag_nats(0, 1, M, N).
diag_nats_signs(0, 0, 0, 0) :- !.
diag_nats_signs(0, M, 0, M0) :- !,
( M0 = M ; M0 is -M ).
diag_nats_signs(M, 0, M0, 0) :- !,
( M0 = M ; M0 is -M ).
diag_nats_signs(M, N, M, N).
diag_nats_signs(M, N, M, N0) :-
N0 is -N.
diag_nats_signs(M, N, M0, N) :-
M0 is -M.
diag_nats_signs(M, N, M0, N0) :-
M0 is -M, N0 is -N.
diag_ints(M, N, M0, N0) :-
diag_nats(M, N),
diag_nats_signs(M, N, M0, N0).
diag_ints(M, N) :-
diag_ints(_, _, M, N).
gen_ints(L, U) :-
can_be(integer, L), can_be(integer, U),
( integer(L), integer(U), !
; integer(L) -> gen_int(U)
; integer(U) -> gen_int(L)
; diag_ints(L, U)
),
L =< U.
numlist(Lower, Upper, List) :-
gen_ints(Lower, Upper), findall(X, between(Lower, Upper, X), List).

1298
src/lib/builtins.pl Normal file
View File

File diff suppressed because it is too large Load Diff

184
src/lib/charsio.pl Normal file
View File

@@ -0,0 +1,184 @@
:- module(charsio, [char_type/2,
chars_utf8bytes/2,
get_single_char/1,
read_term_from_chars/2,
write_term_to_chars/3]).
:- use_module(library(dcgs)).
:- use_module(library(iso_ext)).
:- use_module(library(error)).
:- use_module(library(lists)).
fabricate_var_name(VarType, VarName, N) :-
char_code('A', AC),
LN is N mod 26 + AC,
char_code(LC, LN),
NN is N // 26,
( NN =:= 0 ->
( VarType == fabricated ->
atom_chars(VarName, ['_', LC])
; VarType == numbervars ->
atom_chars(VarName, [LC])
)
; number_chars(NN, NNChars),
( VarType == fabricated ->
atom_chars(VarName, ['_', LC | NNChars])
; VarType == numbervars ->
atom_chars(VarName, [LC | NNChars])
)
).
var_list_contains_name([VarName = _ | VarList], VarName0) :-
( VarName == VarName0 -> true
; var_list_contains_name(VarList, VarName0)
).
var_list_contains_variable([_ = Var | VarList], Var0) :-
( Var == Var0 -> true
; var_list_contains_variable(VarList, Var0)
).
make_new_var_name(VarType, V, VarName, N, N1, VarList) :-
fabricate_var_name(VarType, VarName0, N),
( var_list_contains_name(VarList, VarName0) ->
N0 is N + 1,
make_new_var_name(VarType, V, VarName, N0, N1, VarList)
; VarName = VarName0,
N1 is N + 1
).
extend_var_list(Vars, VarList, NewVarList, VarType) :-
extend_var_list_(Vars, 0, VarList, NewVarList0, VarType),
append(VarList, NewVarList0, NewVarList).
extend_var_list_([], _, VarList, [], _).
extend_var_list_([V|Vs], N, VarList, NewVarList, VarType) :-
( var_list_contains_variable(VarList, V) ->
extend_var_list_(Vs, N, VarList, NewVarList, VarType)
; make_new_var_name(VarType, V, VarName, N, N1, VarList),
NewVarList = [VarName = V | NewVarList0],
extend_var_list_(Vs, N1, VarList, NewVarList0, VarType)
).
char_type(Char, Type) :-
( var(Char) -> instantiation_error(char_type/2)
; atom_length(Char, 1) ->
( ground(Type) ->
( ctype(Type) ->
'$char_type'(Char, Type)
; domain_error(char_type, Type, char_type/2)
)
; ctype(Type),
'$char_type'(Char, Type)
)
; type_error(in_character, Char, char_type/2)
).
ctype(alnum).
ctype(alpha).
ctype(alphabetic).
ctype(ascii).
ctype(ascii_graphic).
ctype(ascii_punctuation).
ctype(binary_digit).
ctype(control).
ctype(decimal_digit).
ctype(exponent).
ctype(graphic).
ctype(hexadecimal_digit).
ctype(layout).
ctype(lower).
ctype(meta).
ctype(numeric).
ctype(octal_digit).
ctype(prolog).
ctype(sign).
ctype(solo).
ctype(symbolic_control).
ctype(symbolic_hexadecimal).
ctype(upper).
ctype(whitespace).
get_single_char(C) :-
( var(C) -> '$get_single_char'(C)
; atom_length(C, 1) -> '$get_single_char'(C)
; type_error(in_character, C, get_single_char/1)
).
read_term_from_chars(Chars, Term) :-
( var(Chars) ->
instantiation_error(read_term_from_chars/2)
; nonvar(Term) ->
throw(error(uninstantiation_error(Term), read_term_from_chars/2))
; '$skip_max_list'(_, -1, Chars, Chars0),
Chars0 == [],
partial_string(Chars) ->
true
;
type_error(complete_string, Chars, read_term_from_chars/2)
),
'$read_term_from_chars'(Chars, Term).
write_term_to_chars(_, Options, _) :-
var(Options), instantiation_error(write_term_to_chars/3).
write_term_to_chars(Term, Options, Chars) :-
builtins:parse_write_options(Options,
[IgnoreOps, MaxDepth, NumberVars, Quoted, VNNames],
write_term_to_chars/3),
( nonvar(Chars) ->
throw(error(uninstantiation_error(Chars), write_term_to_chars/3))
;
true
),
term_variables(Term, Vars),
extend_var_list(Vars, VNNames, NewVarNames, numbervars),
'$write_term_to_chars'(Chars, Term, IgnoreOps, NumberVars, Quoted, NewVarNames, MaxDepth).
% Encodes Ch character to list of Bytes.
char_utf8bytes(Ch, Bytes) :-
char_code(Ch, Code),
phrase(code_to_utf8(Code), Bytes).
code_to_utf8(Code) --> {Code @< 0x80}, [Code], !.
code_to_utf8(Code) --> {Code @< 0x800}, encode(Code, 0xC0, 2), !.
code_to_utf8(Code) --> {Code @< 0x10000}, encode(Code, 0xE0, 3), !.
code_to_utf8(Code) --> {Code @< 0x110000}, encode(Code, 0xF0, 4), !.
encode(_, _, 0) --> !.
encode(Code, Prefix, Nb) -->
{ Nb1 is Nb - 1, Byte is Prefix \/ ((Code >> (6 * Nb1)) /\ 0x3F) },
[Byte], encode(Code, 0x80, Nb1).
% Maps characters and UTF-8 bytes.
% If Cs is a variable, parses Bs as a list of UTF-8 bytes.
% Otherwise, transform the list of characters Cs to UTF-8 bytes.
chars_utf8bytes(Cs, Bs) :-
var(Cs), must_be(list, Bs) ->
once(phrase(decode_utf8(Cs), Bs))
; (must_be(list, Cs),
maplist(must_be(atom), Cs),
maplist(char_utf8bytes, Cs, Bss),
append(Bss, Bs)).
decode_utf8([]) --> [].
decode_utf8(Chars) --> leading(Nb, Code), continuation(Code, Chars, Nb).
leading(1, Byte) --> [Byte], {Byte /\ 0x80 =:= 0}.
leading(2, Code) --> [Byte], {Byte /\ 0xE0 =:= 0xC0, Code is Byte - 0xC0}.
leading(3, Code) --> [Byte], {Byte /\ 0xF0 =:= 0xE0, Code is Byte - 0xE0}.
leading(4, Code) --> [Byte], {Byte /\ 0xF8 =:= 0xF0, Code is Byte - 0xF0}.
leading(1, 0xFFFD) --> [_]. % invalid first byte
continuation(Code, [H|T], 1) --> {char_code(H, Code)}, decode_utf8(T).
continuation(Code, Chars, Nb) --> [Byte],
{Nb1 is Nb - 1, Byte /\ 0xC0 =:= 0x80, NextCode is (Code << 6) \/ (Byte - 0x80)},
continuation(NextCode, Chars, Nb1).
% invalid continuation byte
% each remaining continuation byte (if any) will raise 0xFFFD too
continuation(_, ['\xFFFD\'|T], _) --> [_], decode_utf8(T).

1711
src/lib/clpb.pl Normal file
View File

File diff suppressed because it is too large Load Diff

7622
src/lib/clpz.pl Normal file
View File

File diff suppressed because it is too large Load Diff

30
src/lib/cont.pl Normal file
View File

@@ -0,0 +1,30 @@
:- module(cont, [reset/3, shift/1]).
reset(Goal, Ball, Cont) :-
call(Goal),
'$reset_cont_marker',
'$bind_from_register'(Cont, 3),
'$bind_from_register'(Ball, 4).
shift(Ball) :-
'$nextEP'(first, E, P),
get_chunks(E, P, L),
( L == [] ->
Cont = cont(true)
; Cont = cont(call_continuation(L))
),
'$write_cont_and_term'(_, _, Cont, Ball),
'$unwind_environments'.
get_chunks(E, P, L) :-
( '$points_to_cont_reset_marker'(P) ->
L = []
; '$get_cont_chunk'(E,P,TB),
L = [TB|Rest],
'$nextEP'(E, NextE, NextP),
get_chunks(NextE, NextP, Rest)
).
call_continuation(L) :- '$call_continuation'(L).
'$write_cont_and_term'(_, _, _, _).

801
src/lib/crypto.pl Normal file
View File

@@ -0,0 +1,801 @@
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Written May 2020 by Markus Triska (triska@metalevel.at)
Part of Scryer Prolog.
Predicates for cryptographic applications.
This library assumes that the Prolog flag double_quotes is set to chars.
In Scryer Prolog, lists of characters are very efficiently represented,
and strings have the advantage that the atom table remains unmodified.
Especially for cryptographic applications, it as an advantage that
using strings leaves little trace of what was processed in the system.
For predicates that accept an encoding/1 option to specify the encoding
of the input data, if encoding(octet) is used, then the input can also
be specified as a list of bytes, i.e., integers between 0 and 255.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- module(crypto,
[hex_bytes/2, % ?Hex, ?Bytes
crypto_n_random_bytes/2, % +N, -Bytes
crypto_data_hash/3, % +Data, -Hash, +Options
crypto_data_hkdf/4, % +Data, +Length, -Bytes, +Options
crypto_password_hash/2, % +Password, ?Hash
crypto_password_hash/3, % +Password, -Hash, +Options
crypto_data_encrypt/6, % +PlainText, +Algorithm, +Key, +IV, -CipherText, +Options
crypto_data_decrypt/6, % +CipherText, +Algorithm, +Key, +IV, -PlainText, +Options
ed25519_new_keypair/1, % -KeyPair
ed25519_keypair_public_key/2, % +KeyPair, +PublicKey
ed25519_sign/4, % +KeyPair, +Data, -Signature, +Options
ed25519_verify/4, % +PublicKey, +Data, +Signature, +Options
crypto_name_curve/2, % +Name, -Curve
crypto_curve_order/2, % +Curve, -Order
crypto_curve_generator/2, % +Curve, -Generator
crypto_curve_scalar_mult/4 % +Curve, +Scalar, +Point, -Result
]).
:- use_module(library(error)).
:- use_module(library(lists)).
:- use_module(library(between)).
:- use_module(library(dcgs)).
:- use_module(library(clpz)).
:- use_module(library(arithmetic)).
:- use_module(library(format)).
:- use_module(library(charsio)).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
hex_bytes(?Hex, ?Bytes) is det.
Relation between a hexadecimal sequence and a list of bytes. Hex
is a string of hexadecimal numbers. Bytes is a list of *integers*
between 0 and 255 that represent the sequence as a list of bytes.
At least one of the arguments must be instantiated.
Example:
?- hex_bytes("501ACE", Bs).
Bs = [80,26,206]
; false.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
hex_bytes(Hs, Bytes) :-
( ground(Hs) ->
must_be(list, Hs),
maplist(must_be(atom), Hs),
( phrase(hex_bytes(Hs), Bytes) ->
true
; domain_error(hex_encoding, Hs, hex_bytes/2)
)
; must_be_bytes(Bytes, hex_bytes/2),
phrase(bytes_hex(Bytes), Hs)
).
hex_bytes([]) --> [].
hex_bytes([H1,H2|Hs]) --> [Byte],
{ char_hexval(H1, High),
char_hexval(H2, Low),
Byte is High*16 + Low },
hex_bytes(Hs).
bytes_hex([]) --> [].
bytes_hex([B|Bs]) --> [C0,C1],
{ High is B>>4,
Low is B /\ 0xf,
char_hexval(C0, High),
char_hexval(C1, Low)
},
bytes_hex(Bs).
char_hexval(C, H) :- nth0(H, "0123456789abcdef", C), !.
char_hexval(C, H) :- nth0(H, "0123456789ABCDEF", C), !.
must_be_bytes(Bytes, Context) :-
must_be(list, Bytes),
maplist(must_be(integer), Bytes),
( member(B, Bytes), \+ between(0, 255, B) ->
type_error(byte, B, Context)
; true
).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Cryptographically secure random numbers
=======================================
crypto_n_random_bytes(+N, -Bytes) is det
Bytes is unified with a list of N cryptographically secure
pseudo-random bytes. Each byte is an integer between 0 and 255. If
the internal pseudo-random number generator (PRNG) has not been
seeded with enough entropy to ensure an unpredictable byte
sequence, an exception is thrown.
One way to relate such a list of bytes to an _integer_ is to use
CLP(ℤ) constraints as follows:
:- use_module(library(clpz)).
:- use_module(library(lists)).
bytes_integer(Bs, N) :-
foldl(pow, Bs, 0-0, N-_).
pow(B, N0-I0, N-I) :-
B in 0..255,
N #= N0 + B*256^I0,
I #= I0 + 1.
With this definition, we can generate a random 256-bit integer
_from_ a list of 32 random _bytes_:
?- crypto_n_random_bytes(32, Bs),
bytes_integer(Bs, I).
Bs = [146,166,162,210,242,7,25,132,64,94|...],
I = 337420085690608915485...(56 digits omitted)
The above relation also works in the other direction, letting you
translate an integer _to_ a list of bytes. In addition, you can
use hex_bytes/2 to convert bytes to _tokens_ that can be easily
exchanged in your applications.
?- crypto_n_random_bytes(12, Bs),
hex_bytes(Hex, Bs).
Bs = [34,25,50,72,58,63,50,172,32,46|...], Hex = "221932483a3f32ac202 ..."
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_n_random_bytes(N, Bs) :-
must_be(integer, N),
length(Bs, N),
maplist(crypto_random_byte, Bs).
crypto_random_byte(B) :- '$crypto_random_byte'(B).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Hashing
=======
crypto_data_hash(+Data, -Hash, +Options)
Where Data is a list of characters, and Hash is the computed hash
as a list of hexadecimal characters.
Options is a list of:
- algorithm(+A)
where A is one of ripemd160, sha256, sha384, sha512, sha512_256,
sha3_224, sha3_256, sha3_384, sha3_512, blake2s256, blake2b512,
or a variable. If A is a variable, then it is unified with the
default algorithm, which is an algorithm that is considered
cryptographically secure at the time of this writing.
- encoding(+Encoding)
The default encoding is utf8. The alternative is octet,
to treat the input as a list of raw bytes.
Example:
?- crypto_data_hash("abc", Hs, [algorithm(sha256)]).
Hs = "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad"
; false.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
SHA256 is the current default for several hash-related predicates.
It is deemed sufficiently secure for the foreseeable future. Yet,
application programmers must be aware that the default may change in
future versions. The hash predicates all yield the algorithm they
used if a Prolog variable is used for the pertaining option.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_data_hash(Data0, Hash, Options0) :-
must_be(list, Options0),
options_data_bytes(Options0, Data0, Data),
functor_hash_options(algorithm, A, Options0, _),
( hash_algorithm(A) -> true
; domain_error(hash_algorithm, A, crypto_data_hash/3)
),
'$crypto_data_hash'(Data, HashBytes, A),
hex_bytes(Hash, HashBytes).
options_data_bytes(Options, Data, Bytes) :-
option(encoding(Encoding), Options, utf8),
must_be(atom, Encoding),
encoding_bytes(Encoding, Data, Bytes).
default_hash(sha256).
functor_hash_options(F, Hash, Options0, [Option|Options]) :-
Option =.. [F,Hash],
( select(Option, Options0, Options) ->
( var(Hash) ->
default_hash(Hash)
; must_be(atom, Hash)
)
; Options = Options0,
default_hash(Hash)
).
hash_algorithm(ripemd160).
hash_algorithm(sha256).
hash_algorithm(sha512).
hash_algorithm(sha384).
hash_algorithm(sha512_256).
hash_algorithm(sha3_224).
hash_algorithm(sha3_256).
hash_algorithm(sha3_384).
hash_algorithm(sha3_512).
hash_algorithm(blake2s256).
hash_algorithm(blake2b512).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
crypto_data_hkdf(+Data, +Length, -Bytes, +Options) is det.
Concentrate possibly dispersed entropy of Data and then expand it
to the desired length. Data is a list of characters.
Bytes is unified with a list of bytes of length Length, and is
suitable as input keying material and initialization vectors to
symmetric encryption algorithms.
Admissible options are:
- algorithm(+Algorithm)
One of sha256, sha384 or sha512. If you specify a variable,
then it is unified with the algorithm that was used, which is a
cryptographically secure algorithm by default.
- info(+Info)
Optional context and application specific information,
specified as a list of characters. The default is [].
- salt(+List)
Optionally, a list of bytes that are used as salt. The
default is all zeroes.
- encoding(+Encoding)
The default encoding is utf8. The alternative is octet,
to treat the input as a list of raw bytes.
The `info/1` option can be used to generate multiple keys from a
single master key, using for example values such as "key" and
"iv", or the name of a file that is to be encrypted.
See crypto_n_random_bytes/2 to obtain a suitable salt.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_data_hkdf(Data0, L, Bytes, Options0) :-
functor_hash_options(algorithm, Algorithm, Options0, Options),
( hkdf_algorithm(Algorithm) -> true
; domain_error(hkdf_algorithm, Algorithm, crypto_data_hkdf/4)
),
must_be(integer, L),
L >= 0,
options_data_bytes(Options, Data0, Data),
option(salt(SaltBytes), Options, []),
must_be_bytes(SaltBytes, crypto_data_hkdf/4),
option(info(Info0), Options, []),
chars_bytes_(Info0, Info, crypto_data_hkdf/4),
'$crypto_data_hkdf'(Data, SaltBytes, Info, Algorithm, L, Bytes).
hkdf_algorithm(sha256).
hkdf_algorithm(sha384).
hkdf_algorithm(sha512).
option(What, Options, Default) :-
( member(V, Options), var(V) ->
instantiation_error(option/3)
; true
),
( member(What, Options) -> true
; What =.. [_,Default]
).
chars_bytes_(Cs, Bytes, Context) :-
must_be(list, Cs),
( maplist(integer, Cs) -> Bytes = Cs
; chars_utf8bytes(Cs, Bytes)
),
must_be_bytes(Bytes, Context).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
The so-called modular crypt format (MCF) is a standard for encoding
password hash strings. However, there's no official specification
document describing it. Nor is there a central registry of
identifiers or rules. This page describes what is known about it:
https://pythonhosted.org/passlib/modular_crypt_format.html
As of 2016, the MCF is deprecated in favor of the PHC String Format:
https://github.com/P-H-C/phc-string-format/blob/master/phc-sf-spec.md
This is what we are using below. For the time being, it is best to
treat these hashes as opaque terms in applications. Please let me
know if you need to rely on any specifics of this format.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
crypto_password_hash(+Password, ?Hash) is semidet.
If Hash is instantiated, the predicate succeeds _iff_ the hash
matches the given password. Otherwise, the call is equivalent to
crypto_password_hash(Password, Hash, []) and computes a
password-based hash using the default options.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_password_hash(Password0, Hash) :-
( nonvar(Hash) ->
chars_bytes_(Password0, Password, crypto_password_hash/2),
must_be(list, Hash),
dollar_segments(Hash, [[],"pbkdf2-sha512",[t,=|CsIterations],SaltB64,HashB64]),
number_chars(Iterations, CsIterations),
bytes_base64(SaltBytes, SaltB64),
bytes_base64(HashBytes, HashB64),
'$crypto_password_hash'(Password, SaltBytes, Iterations, HashBytes)
; crypto_password_hash(Password0, Hash, [])
).
dollar_segments(Ls, Segments) :-
( append(Front, [$|Ds], Ls) ->
Segments = [Front|Rest],
dollar_segments(Ds, Rest)
; Segments = [Ls]
).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
crypto_password_hash(+Password, -Hash, +Options) is det.
Derive Hash based on Password. This predicate is similar to
crypto_data_hash/3 in that it derives a hash from given data.
However, it is tailored for the specific use case of _passwords_.
One essential distinction is that for this use case, the derivation
of a hash should be _as slow as possible_ to counteract brute-force
attacks over possible passwords.
Another important distinction is that equal passwords must yield,
with very high probability, _different_ hashes. For this reason,
cryptographically strong random numbers are automatically added to
the password before a hash is derived.
Hash is unified with a string that contains the computed hash and
all parameters that were used, except for the password. Instead of
storing passwords, store these hashes. Later, you can verify the
validity of a password with crypto_password_hash/2, comparing the
then entered password to the stored hash. If you need to export this
atom, you should treat it as opaque ASCII data with up to 255 bytes
of length. The maximal length may increase in the future.
Admissible options are:
- algorithm(+Algorithm)
The algorithm to use. Currently, the only available algorithm
is 'pbkdf2-sha512', which is therefore also the default.
- cost(+C)
C is an integer, denoting the binary logarithm of the number
of _iterations_ used for the derivation of the hash. This
means that the number of iterations is set to 2^C. Currently,
the default is 17, and thus more than one hundred _thousand_
iterations. You should set this option as high as your server
and users can tolerate. The default is subject to change and
will likely increase in the future or adapt to new algorithms.
- salt(+Salt)
Use the given list of bytes as salt. By default,
cryptographically secure random numbers are generated for this
purpose. The default is intended to be secure, and constitutes
the typical use case of this predicate.
Currently, PBKDF2 with SHA-512 is used as the hash derivation
function, using 128 bits of salt. All default parameters, including
the algorithm, are subject to change, and other algorithms will also
become available in the future. Since computed hashes store all
parameters that were used during their derivation, such changes will
not affect the operation of existing deployments. Note though that
new hashes will then be computed with the new default parameters.
See crypto_data_hkdf/4 for generating keys from Hash.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_password_hash(Password0, Hash, Options) :-
chars_bytes_(Password0, Password, crypto_password_hash/3),
must_be(list, Options),
option(cost(C), Options, 17),
Iterations is 2^C,
Algorithm = 'pbkdf2-sha512', % current default and only option
option(algorithm(Algorithm), Options, Algorithm),
( member(salt(SaltBytes), Options) ->
must_be_bytes(SaltBytes, crypto_password_hash/2)
; crypto_n_random_bytes(16, SaltBytes)
),
'$crypto_password_hash'(Password, SaltBytes, Iterations, HashBytes),
bytes_base64(HashBytes, HashB64),
bytes_base64(SaltBytes, SaltB64),
phrase(format_("$pbkdf2-sha512$t=~d$~s$~s", [Iterations,SaltB64,HashB64]), Hash).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Bidirectional Bytes <-> Base64 conversion
=========================================
This implements Base64 conversion *without padding*.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
n_base64(0 , 'A'). n_base64(1 , 'B'). n_base64(2 , 'C'). n_base64(3 , 'D').
n_base64(4 , 'E'). n_base64(5 , 'F'). n_base64(6 , 'G'). n_base64(7 , 'H').
n_base64(8 , 'I'). n_base64(9 , 'J'). n_base64(10, 'K'). n_base64(11, 'L').
n_base64(12, 'M'). n_base64(13, 'N'). n_base64(14, 'O'). n_base64(15, 'P').
n_base64(16, 'Q'). n_base64(17, 'R'). n_base64(18, 'S'). n_base64(19, 'T').
n_base64(20, 'U'). n_base64(21, 'V'). n_base64(22, 'W'). n_base64(23, 'X').
n_base64(24, 'Y'). n_base64(25, 'Z'). n_base64(26, 'a'). n_base64(27, 'b').
n_base64(28, 'c'). n_base64(29, 'd'). n_base64(30, 'e'). n_base64(31, 'f').
n_base64(32, 'g'). n_base64(33, 'h'). n_base64(34, 'i'). n_base64(35, 'j').
n_base64(36, 'k'). n_base64(37, 'l'). n_base64(38, 'm'). n_base64(39, 'n').
n_base64(40, 'o'). n_base64(41, 'p'). n_base64(42, 'q'). n_base64(43, 'r').
n_base64(44, 's'). n_base64(45, 't'). n_base64(46, 'u'). n_base64(47, 'v').
n_base64(48, 'w'). n_base64(49, 'x'). n_base64(50, 'y'). n_base64(51, 'z').
n_base64(52, '0'). n_base64(53, '1'). n_base64(54, '2'). n_base64(55, '3').
n_base64(56, '4'). n_base64(57, '5'). n_base64(58, '6'). n_base64(59, '7').
n_base64(60, '8'). n_base64(61, '9'). n_base64(62, '+'). n_base64(63, '/').
bytes_base64(Ls, Bs) :-
( list(Bs), maplist(atom, Bs) ->
maplist(n_base64, Is, Bs),
phrase(bytes_base64_(Ls), Is),
Ls ins 0..255
; phrase(bytes_base64_(Ls), Is),
Is ins 0..63,
maplist(n_base64, Is, Bs)
).
list(Ls) :-
nonvar(Ls),
( Ls = [] -> true
; Ls = [_|Rest],
list(Rest)
).
bytes_base64_([]) --> [].
bytes_base64_([A]) --> [W,X],
{ A #= W*4 + X//16,
X #= 16*_ }.
bytes_base64_([A,B]) --> [W,X,Y],
{ A #= W*4 + X//16,
B #= (X mod 16)*16 + Y//4,
Y #= 4*_ }.
bytes_base64_([A,B,C|Ls]) --> [W,X,Y,Z],
{ A #= W*4 + X//16,
B #= (X mod 16)*16 + Y//4,
C #= (Y mod 4)*64 + Z },
bytes_base64_(Ls).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
crypto_data_encrypt(+PlainText,
+Algorithm,
+Key,
+IV,
-CipherText,
+Options).
Encrypt the given PlainText, using the symmetric algorithm
Algorithm, key Key, and initialization vector (or nonce) IV, to
give CipherText.
PlainText must be a list of characters, Key and IV must be lists of
bytes, and CipherText is created as a list of characters.
Keys and IVs can be chosen at random (using for example
crypto_n_random_bytes/2) or derived from input keying material (IKM)
using for example crypto_data_hkdf/4. This input is often a shared
secret, such as a negotiated point on an elliptic curve, or the hash
that was computed from a password via crypto_password_hash/3 with a
freshly generated and specified _salt_.
Reusing the same combination of Key and IV typically leaks at least
_some_ information about the plaintext. For example, identical
plaintexts will then correspond to identical ciphertexts. For some
algorithms, reusing an IV with the same Key has disastrous results
and can cause the loss of all properties that are otherwise
guaranteed. Especially in such cases, an IV is also called a
_nonce_ (number used once).
It is safe to store and transfer the used initialization vector (or
nonce) in plain text, but the key _must be kept secret_.
Currently, the only supported algorithm is 'chacha20-poly1305', a
powerful and efficient _authenticated_ encryption scheme, providing
secrecy and at the same time reliable protection against undetected
_modifications_ of the encrypted data. This is a very good choice
for virtually all use cases. It is a stream cipher and can encrypt
data of any length up to 256 GB. Further, the encrypted data has
exactly the same length as the original, and no padding is used.
Options:
- encoding(+Encoding)
Encoding to use for PlainText. Default is utf8. The alternative
is octet to treat PlainText as raw bytes.
- tag(-List)
For authenticated encryption schemes, List is unified with a
list of _bytes_ holding the tag. This tag must be provided for
decryption.
Here is an example encryption and decryption, using the ChaCha20
stream cipher with the Poly1305 authenticator. This cipher uses a
256-bit key and a 96-bit nonce, i.e., 32 and 12 _bytes_,
respectively:
?- Algorithm = 'chacha20-poly1305',
crypto_n_random_bytes(32, Key),
crypto_n_random_bytes(12, IV),
crypto_data_encrypt("this text is to be encrypted", Algorithm,
Key, IV, CipherText, [tag(Tag)]),
crypto_data_decrypt(CipherText, Algorithm,
Key, IV, RecoveredText, [tag(Tag)]).
Yielding:
Algorithm = 'chacha20-poly1305',
Key = [113,247,153,134,177,220,13,193,50,150|...],
IV = [135,20,149,153,63,35,68,114,247,171|...],
CipherText = "\x94\0Ej\x94\®Â\x95\óÑÆXÃn¾ð©b\x1c\ ...",
RecoveredText = "this text is to be ...",
Tag = [152,117,152,17,162,75,150,206,144,40|...]
In this example, we use crypto_n_random_bytes/2 to generate a key
and nonce from cryptographically secure random numbers. For
repeated applications, you must ensure that a nonce is only used
_once_ together with the same key. Note that for _authenticated_
encryption schemes, the _tag_ that was computed during encryption
is necessary for decryption. It is safe to store and transfer the
tag in plain text.
See also crypto_data_decrypt/6, and hex_bytes/2 for conversion
between bytes and hex encoding.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_data_encrypt(PlainText0, Algorithm, Key, IV, CipherText, Options) :-
options_data_bytes(Options, PlainText0, PlainText),
option(tag(Tag), Options, _),
( nonvar(Tag) ->
must_be_bytes(Tag, crypto_data_encrypt/6)
; true
),
must_be_bytes(Key, crypto_data_encrypt/6),
must_be_bytes(IV, crypto_data_encrypt/6),
must_be(atom, Algorithm),
( Algorithm = 'chacha20-poly1305' -> true
; domain_error('chacha20-poly1305', Algorithm, crypto_data_encrypt/6)
),
'$crypto_data_encrypt'(PlainText, Key, IV, Tag, CipherText).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
crypto_data_decrypt(+CipherText,
+Algorithm,
+Key,
+IV,
-PlainText,
+Options).
Decrypt the given CipherText, using the symmetric algorithm
Algorithm, key Key, and initialization vector IV, to give
PlainText. CipherText must be a list of characters, and Key and IV
must be lists of bytes. PlainText is created as a list of
characters.
Currently, the only supported algorithm is 'chacha20-poly1305',
a very secure, fast and versatile authenticated encryption method.
Options is a list of:
- encoding(+Encoding)
Encoding to use for PlainText. The default is utf8. The
alternative is octet, which is used if the data are raw bytes.
- tag(+Tag)
For authenticated encryption schemes, the tag must be specified as
a list of bytes exactly as they were generated upon encryption.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
crypto_data_decrypt(CipherText0, Algorithm, Key, IV, PlainText, Options) :-
option(tag(Tag), Options, []),
must_be_bytes(Tag, crypto_data_decrypt/6),
must_be_bytes(Key, crypto_data_decrypt/6),
must_be_bytes(IV, crypto_data_decrypt/6),
must_be(atom, Algorithm),
option(encoding(Encoding), Options, utf8),
must_be(atom, Encoding),
member(Encoding, [utf8,octet]),
must_be(list, CipherText0),
encoding_bytes(octet, CipherText0, CipherText1),
append(CipherText1, Tag, CipherText),
( Algorithm = 'chacha20-poly1305' -> true
; domain_error('chacha20-poly1305', Algorithm, crypto_data_decrypt/6)
),
'$crypto_data_decrypt'(CipherText, Key, IV, Encoding, PlainText).
encoding_bytes(octet, Bs0, Bs) :-
must_be(list, Bs0),
( maplist(integer, Bs0) ->
Bs0 = Bs
; maplist(char_code, Bs0, Bs)
),
must_be_bytes(Bs, crypto_encoding).
encoding_bytes(utf8, Cs, Bs) :-
must_be(list, Cs),
( maplist(atom, Cs) ->
chars_bytes_(Cs, Bs, crypto_encoding)
; domain_error(encryption_encoding, Cs, crypto)
).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Digital signatures with Ed25519
===============================
- ed25519_new_keypair(-Pair)
Yields a new Ed25519 key pair Pair, a list of characters. The
pair contains the private key and must be kept absolutely secret.
Pair can be used for signing. Its public key can be obtained
with ed25519_keypair_public_key/2.
- ed25519_keypair_public_key(+Pair, -PublicKey)
PublicKey is the public key of the given key pair. The public key
can be used for signature verification, and can be shared freely.
The public key is represented as a list of characters.
- ed25519_sign(+Key, +Data, -Signature, +Options)
Key and Data must be lists of characters. Key is a key pair in
PKCS#8 v2 format as generated by ed25519_new_keypair/1. Sign Data
with Key, yielding Signature as a list of hexadecimal characters.
- ed25519_verify(+Key, +Data, +Signature, +Options)
Key and Data must be lists of characters. Key is a public key.
Succeeds if Data was signed with the private key corresponding to
Key, where Signature is a list of hexadecimal characters as
generated by ed25519_sign/4. Fails otherwise.
Currently, the only option for signing and verifying is:
- encoding(+Encoding)
The default encoding of Data is utf8. The alternative is octet,
which treats Data as a list of raw bytes.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
ed25519_new_keypair(Pair) :-
'$ed25519_new_keypair'(Pair).
ed25519_keypair_public_key(Pair0, PublicKey) :-
encoding_bytes(octet, Pair0, Pair),
'$ed25519_keypair_public_key'(Pair, PublicKey).
ed25519_sign(Key0, Data0, Signature, Options) :-
options_data_bytes(Options, Data0, Data),
encoding_bytes(octet, Key0, Key),
'$ed25519_sign'(Key, Data, Signature0),
hex_bytes(Signature, Signature0).
ed25519_verify(Key0, Data0, Signature0, Options) :-
options_data_bytes(Options, Data0, Data),
encoding_bytes(octet, Key0, Key),
hex_bytes(Signature0, Signature),
'$ed25519_verify'(Key, Data, Signature).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Operations on Elliptic Curves
=============================
Sample use: Establishing a shared secret S, using ECDH key exchange.
?- crypto_name_curve(secp256k1, C),
crypto_curve_generator(C, Generator),
PrivateKey = 10,
crypto_curve_scalar_mult(C, PrivateKey, Generator, PublicKey),
Random = 12,
crypto_curve_scalar_mult(C, Random, Generator, R),
crypto_curve_scalar_mult(C, Random, PublicKey, S),
crypto_curve_scalar_mult(C, PrivateKey, R, S).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
An elliptic curve over a prime field F_p is represented as:
curve(Name,P,A,B,point(X,Y),Order,FieldLength,Cofactor).
First, we define suitable accessors.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
curve_name(curve(Name,_,_,_,_,_,_,_), Name).
curve_p(curve(_,P,_,_,_,_,_,_), P).
curve_a(curve(_,_,A,_,_,_,_,_), A).
curve_b(curve(_,_,_,B,_,_,_,_), B).
curve_field_length(curve(_,_,_,_,_,_,FieldLength,_), FieldLength).
crypto_curve_generator(curve(_,_,_,_,G,_,_,_), G).
crypto_curve_order(curve(_,_,_,_,_,Order,_,_), Order).
crypto_curve_scalar_mult(Curve, Scalar, point(X,Y), point(RX, RY)) :-
must_be(integer, Scalar),
must_be_on_curve(Curve, point(X,Y)),
curve_name(Curve, Name),
curve_field_length(Curve, L0),
L #= 2*L0, % for hex encoding
phrase(format_("04~|~`0t~16r~*+~`0t~16r~*+", [X,L,Y,L]), Hex),
hex_bytes(Hex, Bytes),
'$crypto_curve_scalar_mult'(Name, Scalar, Bytes, SX, SY),
number_chars(RX, SX),
number_chars(RY, SY).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
?- crypto_name_curve(secp256k1, Curve),
crypto_curve_generator(Curve, G),
crypto_curve_scalar_mult(Curve, 2, G, R).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Validation.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
curve_contains_point(Curve, point(QX,QY)) :-
curve_a(Curve, A),
curve_b(Curve, B),
curve_p(Curve, P),
QY^2 mod P #= (QX^3 + A*QX + B) mod P.
must_be_on_curve(Curve, P) :-
\+ curve_contains_point(Curve, P),
domain_error(point_on_curve, P, crypto_elliptic_curves).
must_be_on_curve(Curve, P) :- curve_contains_point(Curve, P).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Predefined curves
=================
List available curves:
$ openssl ecparam -list_curves
Show curve parameters for secp256k1:
$ openssl ecparam -param_enc explicit -conv_form uncompressed \
-text -no_seed -name secp256k1
You must remove the leading "04:" from the generator.
The field length depends on the order of the curve and can be computed
with order_field_length/2.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
order_field_length(Order, L) :-
fitting_exponent(Order, 0, E),
L #= (E + 7) // 8.
fitting_exponent(N, E0, E) :-
( 2^E0 #>= N -> E #= E0
; E1 #= E0 + 1,
fitting_exponent(N, E1, E)
).
crypto_name_curve(secp112r1,
curve(secp112r1,
0x00db7c2abf62e35e668076bead208b,
0x00db7c2abf62e35e668076bead2088,
0x659ef8ba043916eede8911702b22,
point(0x09487239995a5ee76b55f9c2f098,
0xa89ce5af8724c0a23e0e0ff77500),
0x00db7c2abf62e35e7628dfac6561c5,
14,
1)).
crypto_name_curve(secp256k1,
curve(secp256k1,
0x00fffffffffffffffffffffffffffffffffffffffffffffffffffffffefffffc2f,
0x0,
0x7,
point(0x79be667ef9dcbbac55a06295ce870b07029bfcdb2dce28d959f2815b16f81798,
0x483ada7726a3c4655da4fbfc0e1108a8fd17b448a68554199c47d08ffb10d4b8),
0x00fffffffffffffffffffffffffffffffebaaedce6af48a03bbfd25e8cd0364141,
32,
1)).

135
src/lib/dcgs.pl Normal file
View File

@@ -0,0 +1,135 @@
:- module(dcgs, [op(1200, xfx, -->),
op(1105, xfy, '|'),
phrase/2,
phrase/3]).
:- use_module(library(error)).
:- use_module(library(lists), [append/3]).
phrase(GRBody, S0) :-
phrase(GRBody, S0, []).
phrase(GRBody, S0, S) :-
( var(GRBody) -> throw(error(instantiation_error, phrase/3))
; dcg_constr(GRBody) -> phrase_(GRBody, S0, S)
; functor(GRBody, _, _) -> call(GRBody, S0, S)
; throw(error(type_error(callable, GRBody), phrase/3))
).
phrase_([], S, S).
phrase_(!, S, S).
phrase_((A, B), S0, S) :-
phrase(A, S0, S1), phrase(B, S1, S).
phrase_((A -> B ; C), S0, S) :-
!,
( phrase(A, S0, S1) ->
phrase(B, S1, S)
; phrase(C, S0, S)
).
phrase_((A ; B), S0, S) :-
( phrase(A, S0, S) ; phrase(B, S0, S) ).
phrase_((A | B), S0, S) :-
( phrase(A, S0, S) ; phrase(B, S0, S) ).
phrase_({G}, S0, S) :-
( call(G), S0 = S ).
phrase_(call(G), S0, S) :-
call(G, S0, S).
phrase_((A -> B), S0, S) :-
phrase((A -> B ; fail), S0, S).
phrase_(phrase(NonTerminal), S0, S) :-
phrase(NonTerminal, S0, S).
phrase_([T|Ts], S0, S) :-
append([T|Ts], S, S0).
% The same version of the below two dcg_rule clauses, but with module scoping.
dcg_rule(( M:NonTerminal, Terminals --> GRBody ), ( M:Head :- Body )) :-
dcg_non_terminal(NonTerminal, S0, S, Head),
dcg_body(GRBody, S0, S1, Goal1),
dcg_terminals(Terminals, S, S1, Goal2),
Body = ( Goal1, Goal2 ).
dcg_rule(( M:NonTerminal --> GRBody ), ( M:Head :- Body )) :-
NonTerminal \= ( _, _ ),
dcg_non_terminal(NonTerminal, S0, S, Head),
dcg_body(GRBody, S0, S, Body).
% This program uses append/3 as defined in the Prolog prologue.
% Expands a DCG rule into a Prolog rule, when no error condition applies.
dcg_rule(( NonTerminal, Terminals --> GRBody ), ( Head :- Body )) :-
dcg_non_terminal(NonTerminal, S0, S, Head),
dcg_body(GRBody, S0, S1, Goal1),
dcg_terminals(Terminals, S, S1, Goal2),
Body = ( Goal1, Goal2 ).
dcg_rule(( NonTerminal --> GRBody ), ( Head :- Body )) :-
NonTerminal \= ( _, _ ),
dcg_non_terminal(NonTerminal, S0, S, Head),
dcg_body(GRBody, S0, S, Body).
dcg_non_terminal(NonTerminal, S0, S, Goal) :-
NonTerminal =.. NonTerminalUniv,
append(NonTerminalUniv, [S0, S], GoalUniv),
Goal =.. GoalUniv.
dcg_terminals(Terminals, S0, S, S0 = List) :-
append(Terminals, S, List).
dcg_body(Var, S0, S, Body) :-
var(Var),
Body = phrase(Var, S0, S).
dcg_body(GRBody, S0, S, Body) :-
nonvar(GRBody),
dcg_constr(GRBody),
dcg_cbody(GRBody, S0, S, Body).
dcg_body(NonTerminal, S0, S, Goal) :-
nonvar(NonTerminal),
\+ dcg_constr(NonTerminal),
NonTerminal \= ( _ -> _ ),
NonTerminal \= ( \+ _ ),
dcg_non_terminal(NonTerminal, S0, S, Goal).
% The following constructs in a grammar rule body
% are defined in the corresponding subclauses.
dcg_constr([]). % 7.14.1
dcg_constr([_|_]). % 7.14.2 - terminal sequence
dcg_constr(( _, _ )). % 7.14.3 - concatenation
dcg_constr(( _ ; _ )). % 7.14.4 - alternative
dcg_constr(( _'|'_ )). % 7.14.6 - alternative
dcg_constr({_}). % 7.14.7
dcg_constr(call(_)). % 7.14.8
dcg_constr(phrase(_)). % 7.14.9
dcg_constr(!). % 7.14.10
%% dcg_constr(\+ _). % 7.14.11 - not (existence implementation dep.)
dcg_constr((_->_)). % 7.14.12 - if-then (existence implementation dep.)
% The principal functor of the first argument indicates
% the construct to be expanded.
dcg_cbody([], S0, S, S0 = S).
dcg_cbody([T|Ts], S0, S, Goal) :-
must_be(list, [T|Ts]),
dcg_terminals([T|Ts], S0, S, Goal).
dcg_cbody(( GRFirst, GRSecond ), S0, S, ( First, Second )) :-
dcg_body(GRFirst, S0, S1, First),
dcg_body(GRSecond, S1, S, Second).
dcg_cbody(( GREither ; GROr ), S0, S, ( Either ; Or )) :-
\+ subsumes_term(( _ -> _ ), GREither),
dcg_body(GREither, S0, S, Either),
dcg_body(GROr, S0, S, Or).
dcg_cbody(( GRCond ; GRElse ), S0, S, ( Cond ; Else )) :-
subsumes_term(( _GRIf -> _GRThen ), GRCond),
dcg_cbody(GRCond, S0, S, Cond),
dcg_body(GRElse, S0, S, Else).
dcg_cbody(( GREither '|' GROr ), S0, S, ( Either ; Or )) :-
dcg_body(GREither, S0, S, Either),
dcg_body(GROr, S0, S, Or).
dcg_cbody({Goal}, S0, S, ( Goal, S0 = S )).
dcg_cbody(call(Cont), S0, S, call(Cont, S0, S)).
dcg_cbody(phrase(Body), S0, S, phrase(Body, S0, S)).
dcg_cbody(!, S0, S, ( !, S0 = S )).
dcg_cbody(\+ GRBody, S0, S, ( \+ phrase(GRBody,S0,_), S0 = S )).
dcg_cbody(( GRIf -> GRThen ), S0, S, ( If -> Then )) :-
dcg_body(GRIf, S0, S1, If),
dcg_body(GRThen, S1, S, Then).
user:term_expansion(Term0, Term) :-
nonvar(Term0),
dcg_rule(Term0, (Head :- Body)),
Term = (Head :- Body).

14
src/lib/diag.pl Normal file
View File

@@ -0,0 +1,14 @@
:- module(diag, [wam_instructions/2]).
:- use_module(library(error)).
wam_instructions(Clause, Listing) :-
( nonvar(Clause) ->
Clause = Name / Arity,
must_be(atom, Name),
must_be(integer, Arity),
( Arity >= 0 -> '$wam_instructions'(Name, Arity, Listing)
; throw(error(domain_error(not_less_than_zero, Arity), wam_instructions/2))
)
; throw(error(instantiation_error, wam_instructions/2))
).

55
src/lib/dif.pl Normal file
View File

@@ -0,0 +1,55 @@
:- module(dif, [dif/2]).
:- use_module(library(atts)).
:- use_module(library(dcgs)).
:- use_module(library(lists), [append/3]).
:- attribute dif/1.
put_dif_att(Var, X, Y) :-
( get_atts(Var, +dif(Z)) ->
sort([X \== Y | Z], NewZ),
put_atts(Var, +dif(NewZ))
; put_atts(Var, +dif([X \== Y]))
).
dif_set_variables([], _, _).
dif_set_variables([Var|Vars], X, Y) :-
put_dif_att(Var, X, Y),
dif_set_variables(Vars, X, Y).
append_goals([], _).
append_goals([Var|Vars], Goals) :-
( get_atts(Var, +dif(VarGoals)) ->
append(Goals, VarGoals, NewGoals0),
sort(NewGoals0, NewGoals)
; NewGoals = Goals
),
put_atts(Var, +dif(NewGoals)),
append_goals(Vars, Goals).
verify_attributes(Var, Value, Goals) :-
( get_atts(Var, +dif(Goals)) ->
term_variables(Value, ValueVars),
append_goals(ValueVars, Goals)
; Goals = []
).
% Probably the world's worst dif/2 implementation. I'm open to
% suggestions for improvement.
dif(X, Y) :- X \== Y,
( term_variables(X, XVars), term_variables(Y, YVars),
dif_set_variables(XVars, X, Y),
dif_set_variables(YVars, X, Y)
).
gather_dif_goals([]) --> [].
gather_dif_goals([(X \== Y) | Goals]) -->
[dif(X, Y)],
gather_dif_goals(Goals).
attribute_goals(X) -->
{ get_atts(X, +dif(Goals)) },
gather_dif_goals(Goals),
{ put_atts(X, -dif(_)) }.

112
src/lib/error.pl Normal file
View File

@@ -0,0 +1,112 @@
:- module(error, [must_be/2,
can_be/2,
instantiation_error/1,
domain_error/3,
type_error/3
]).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Written September 2018 by Markus Triska (triska@metalevel.at)
I place this code in the public domain. Use it in any way you want.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
must_be(Type, Term)
This predicate is intended for type-checks of built-in predicates.
It asserts that Term is:
1) instantiated *and*
2) instantiated to an instance of the given Type.
It corresponds to usage mode +Term.
Currently, the following types are supported:
- integer
- atom
- list
- boolean
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
must_be(Type, Term) :-
must_be_(type, Type),
must_be_(Type, Term).
must_be_(Type, _) :-
var(Type),
instantiation_error(must_be/2).
must_be_(var, Term) :-
( var(Term) -> true
; throw(error(uninstantiation_error, must_be/2))
).
must_be_(integer, Term) :- check_(integer, integer, Term).
must_be_(atom, Term) :- check_(atom, atom, Term).
must_be_(list, Term) :- check_(ilist, list, Term).
must_be_(type, Term) :- check_(type, type, Term).
must_be_(boolean, Term) :- check_(boolean, boolean, Term).
check_(Pred, Type, Term) :-
( var(Term) -> instantiation_error(must_be/2)
; call(Pred, Term) -> true
; type_error(Type, Term, must_be/2)
).
boolean(B) :- ( B == true ; B == false ).
ilist(V) :- var(V), instantiation_error(must_be/2).
ilist([]).
ilist([_|Ls]) :- ilist(Ls).
type(type).
type(integer).
type(atom).
type(list).
type(var).
type(boolean).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
can_be(Type, Term)
This predicate is intended for type-checks of built-in predicates.
It asserts that there is a substitution which, if applied to Term,
makes it an instance of Type.
It corresponds to usage mode ?Term.
It supports the same types as must_be/2.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
can_be(Type, Term) :-
must_be(type, Type),
( var(Term) -> true
; can_(Type, Term) -> true
; type_error(Type, Term, can_be/2)
).
can_(integer, Term) :- integer(Term).
can_(atom, Term) :- atom(Term).
can_(list, Term) :- list_or_partial_list(Term).
can_(boolean, Term) :- boolean(Term).
list_or_partial_list(Var) :- var(Var).
list_or_partial_list([]).
list_or_partial_list([_|Ls]) :-
list_or_partial_list(Ls).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Shorthands for throwing ISO errors.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
instantiation_error(Context) :-
throw(error(instantiation_error, Context)).
domain_error(Type, Term, Context) :-
throw(error(domain_error(Type, Term), Context)).
type_error(Type, Term, Context) :-
throw(error(type_error(Type, Term), Context)).

587
src/lib/format.pl Normal file
View File

@@ -0,0 +1,587 @@
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Written March 2020 by Markus Triska (triska@metalevel.at)
Part of Scryer Prolog.
This library provides the nonterminal format_//2 to describe
formatted strings. format/2 is provided for impure output.
Usage:
======
phrase(format_(FormatString, Arguments), Ls)
format_//2 describes a list of characters Ls that are formatted
according to FormatString. FormatString is a string (i.e.,
a list of characters) that specifies the layout of Ls.
The characters in FormatString are used literally, except
for the following tokens with special meaning:
~w use the next available argument from Arguments here
~q use the next argument here, formatted as by writeq/1
~a use the next argument here, which must be an atom
~s use the next argument here, which must be a string
~d use the next argument here, which must be an integer
~f use the next argument here, a floating point number
~Nf where N is an integer: format the float argument
using N digits after the decimal point
~Nd like ~d, placing the last N digits after a decimal point;
if N is 0 or omitted, no decimal point is used.
~ND like ~Nd, separating digits to the left of the decimal point
in groups of three, using the character "," (comma)
~Nr where N is an integer between 2 and 36: format the
next argument, which must be an integer, in radix N.
The characters "a" to "z" are used for radices 10 to 36.
~NR like ~Nr, except that "A" to "Z" are used for radices > 9
~| place a tab stop at this position
~N| where N is an integer: place a tab stop at text column N
~N+ where N is an integer: place a tab stop N characters
after the previous tab stop (or start of line)
~t distribute spaces evenly between the two closest tab stops
~`Ct like ~t, use character C instead of spaces to fill the space
~n newline
~Nn N newlines
~i ignore the next argument
~~ the literal ~
Instead of ~N, you can write ~* to use the next argument from Arguments
as the numeric argument.
The predicate format/2 is like format_//2, except that it outputs
the text on the terminal instead of describing it declaratively.
format/3, used as format(Stream, FormatString, Arguments), outputs
the described string to the given Stream. If Stream is a binary
stream, then the code of each emitted character must be in 0..255.
If at all possible, format_//2 should be used, to stress pure parts
that enable easy testing etc. If necessary, you can emit the list Ls
with maplist(write, Ls).
The entire library only works if the Prolog flag double_quotes
is set to chars, the default value in Scryer Prolog. This should
also stay that way, to encourage a sensible environment.
Example:
?- phrase(format_("~s~n~`.t~w!~12|", ["hello",there]), Cs).
%@ Cs = "hello\n......there!"
%@ ; false.
I place this code in the public domain. Use it in any way you want.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- module(format, [format_//2,
format/2,
format/3,
portray_clause/1,
listing/1
]).
:- use_module(library(dcgs)).
:- use_module(library(lists)).
:- use_module(library(error)).
:- use_module(library(charsio)).
:- use_module(library(between)).
format_(Fs, Args) -->
{ must_be(list, Fs),
must_be(list, Args),
phrase(cells(Fs,Args,0,[]), Cells) },
format_cells(Cells).
format_cells([]) --> [].
format_cells([Cell|Cells]) -->
format_cell(Cell),
format_cells(Cells).
format_cell(newline) --> "\n".
format_cell(cell(From,To,Es)) -->
% distribute the space between the glue elements
{ phrase(elements_gluevars(Es, 0, Length), Vs),
( Vs = [] -> true
; Space is To - From - Length,
( Space =< 0 -> maplist(=(0), Vs)
; length(Vs, NumGlue),
Distr is Space // NumGlue,
Delta is Space - Distr*NumGlue,
( Delta =:= 0 ->
maplist(=(Distr), Vs)
; BigGlue is Distr + Delta,
reverse(Vs, [BigGlue|Rest]),
maplist(=(Distr), Rest)
)
)
) },
format_elements(Es).
format_elements([]) --> [].
format_elements([E|Es]) -->
format_element(E),
format_elements(Es).
format_element(chars(Cs)) --> list(Cs).
format_element(glue(Fill,Num)) -->
{ length(Ls, Num),
maplist(=(Fill), Ls) },
list(Ls).
list([]) --> [].
list([L|Ls]) --> [L], list(Ls).
elements_gluevars([], N, N) --> [].
elements_gluevars([E|Es], N0, N) -->
element_gluevar(E, N0, N1),
elements_gluevars(Es, N1, N).
element_gluevar(chars(Cs), N0, N) -->
{ length(Cs, L),
N is N0 + L }.
element_gluevar(glue(_,V), N, N) --> [V].
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Our key datastructure is a list of cells and newlines.
A cell has the shape from_to(From,To,Elements), where
From and To denote the positions of surrounding tab stops.
Elements is a list of elements that occur in a cell,
namely terms of the form chars(Cs) and glue(Char, Var).
"glue" elements (TeX terminology) are evenly stretched
to fill the remaining whitespace in the cell. For each
glue element, the character Char is used for filling,
and Var is a free variable that is used when the
available space is distributed.
newline is used if ~n occurs in a format string.
It is is used because a newline character does not
consume whitespace in the sense of format strings.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
cells([], Args, Tab, Es) -->
( { Args == [] } -> cell(Tab, Tab, Es)
; { domain_error(empty_list, Args, format_//2) }
).
cells([~,~|Fs], Args, Tab, Es) --> !,
cells(Fs, Args, Tab, [chars("~")|Es]).
cells([~,w|Fs], [Arg|Args], Tab, Es) --> !,
{ write_term_to_chars(Arg, [], Chars) },
cells(Fs, Args, Tab, [chars(Chars)|Es]).
cells([~,q|Fs], [Arg|Args], Tab, Es) --> !,
{ write_term_to_chars(Arg, [quoted(true)], Chars) },
cells(Fs, Args, Tab, [chars(Chars)|Es]).
cells([~,a|Fs], [Arg|Args], Tab, Es) --> !,
{ atom_chars(Arg, Chars) },
cells(Fs, Args, Tab, [chars(Chars)|Es]).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, [d|Fs], Args0, [Arg0|Args]) },
!,
{ Arg is Arg0, % evaluate compound expression
must_be(integer, Arg),
number_chars(Arg, Cs0) },
( { Num =:= 0 } -> { Cs = Cs0 }
; { length(Cs0, L),
( L =< Num ->
Delta is Num - L,
length(Zs, Delta),
maplist(=('0'), Zs),
phrase(("0.",list(Zs),list(Cs0)), Cs)
; BeforeComma is L - Num,
length(Bs, BeforeComma),
append(Bs, Ds, Cs0),
phrase((list(Bs),".",list(Ds)), Cs)
) }
),
cells(Fs, Args, Tab, [chars(Cs)|Es]).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, ['D'|Fs], Args0, [Arg|Args]) },
!,
{ number_chars(Num, NCs),
phrase(("~",list(NCs),"d"), FStr),
phrase(format_(FStr, [Arg]), Cs0),
phrase(upto_what(Bs0, .), Cs0, Ds),
reverse(Bs0, Bs1),
phrase(groups_of_three(Bs1), Bs2),
reverse(Bs2, Bs),
append(Bs, Ds, Cs) },
cells(Fs, Args, Tab, [chars(Cs)|Es]).
cells([~,i|Fs], [_|Args], Tab, Es) --> !,
cells(Fs, Args, Tab, Es).
cells([~,n|Fs], Args, Tab, Es) --> !,
cell(Tab, Tab, Es),
n_newlines(1),
cells(Fs, Args, 0, []).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, [n|Fs], Args0, Args) },
!,
cell(Tab, Tab, Es),
n_newlines(Num),
cells(Fs, Args, 0, []).
cells([~,s|Fs], [Arg|Args], Tab, Es) --> !,
cells(Fs, Args, Tab, [chars(Arg)|Es]).
cells([~,f|Fs], [Arg|Args], Tab, Es) --> !,
{ format_number_chars(Arg, Chars) },
cells(Fs, Args, Tab, [chars(Chars)|Es]).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, [f|Fs], Args0, [Arg|Args]) },
!,
{ format_number_chars(Arg, Cs0),
phrase(upto_what(Bs, .), Cs0, Cs),
( Num =:= 0 -> Chars = Bs
; ( Cs = ['.'|Rest] ->
length(Rest, L),
( Num < L ->
length(Ds, Num),
append(Ds, _, Rest)
; Num =:= L ->
Ds = Rest
; Num > L,
Delta is Num - L,
% we should look into the float with
% greater accuracy here, and use the
% actual digits instead of 0.
length(Zs, Delta),
maplist(=('0'), Zs),
append(Rest, Zs, Ds)
)
; length(Ds, Num),
maplist(=('0'), Ds)
),
append(Bs, ['.'|Ds], Chars)
) },
cells(Fs, Args, Tab, [chars(Chars)|Es]).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, [r|Fs], Args0, [Arg|Args]) },
!,
{ integer_to_radix(Arg, Num, lowercase, Cs) },
cells(Fs, Args, Tab, [chars(Cs)|Es]).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, ['R'|Fs], Args0, [Arg|Args]) },
!,
{ integer_to_radix(Arg, Num, uppercase, Cs) },
cells(Fs, Args, Tab, [chars(Cs)|Es]).
cells([~,'`',Char,t|Fs], Args, Tab, Es) --> !,
cells(Fs, Args, Tab, [glue(Char,_)|Es]).
cells([~,t|Fs], Args, Tab, Es) --> !,
cells(Fs, Args, Tab, [glue(' ',_)|Es]).
cells([~|Fs0], Args0, Tab, Es) -->
{ numeric_argument(Fs0, Num, ['|'|Fs], Args0, Args) },
!,
cell(Tab, Num, Es),
cells(Fs, Args, Num, []).
cells([~|Fs0], Args0, Tab0, Es) -->
{ numeric_argument(Fs0, Num, [+|Fs], Args0, Args) },
!,
{ Tab is Tab0 + Num },
cell(Tab0, Tab, Es),
cells(Fs, Args, Tab, []).
cells([~,C|_], _, _, _) -->
{ atom_chars(A, [~,C]),
domain_error(format_string, A, format_//2) }.
cells(Fs0, Args, Tab, Es) -->
{ phrase(upto_what(Fs1, ~), Fs0, Fs),
Fs1 = [_|_] },
cells(Fs, Args, Tab, [chars(Fs1)|Es]).
format_number_chars(N0, Chars) :-
N is N0, % evaluate compound expression
number_chars(N, Chars).
n_newlines(0) --> !.
n_newlines(N0) --> { N0 > 0, N is N0 - 1 }, [newline], n_newlines(N).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
?- phrase(upto_what(Cs, ~), "abc~test", Rest).
Cs = [a,b,c], Rest = [~,t,e,s,t].
?- phrase(upto_what(Cs, ~), "abc", Rest).
Cs = [a,b,c], Rest = [].
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
upto_what([], W), [W] --> [W], !.
upto_what([C|Cs], W) --> [C], !, upto_what(Cs, W).
upto_what([], _) --> [].
groups_of_three([A,B,C,D|Rs]) --> !, [A,B,C], ",", groups_of_three([D|Rs]).
groups_of_three(Ls) --> list(Ls).
cell(From, To, Es0) -->
( { Es0 == [] } -> []
; { reverse(Es0, Es) },
[cell(From,To,Es)]
).
%?- numeric_argument("2f", Num, ['f'|Fs], Args0, Args).
%?- numeric_argument("100b", Num, Rs, Args0, Args).
numeric_argument(Ds, Num, Rest, Args0, Args) :-
( Ds = [*|Rest] ->
Args0 = [Num|Args]
; numeric_argument_(Ds, [], Ns, Rest),
foldl(pow10, Ns, 0-0, Num-_),
Args0 = Args
).
numeric_argument_([D|Ds], Ns0, Ns, Rest) :-
( member(D, "0123456789") ->
number_chars(N, [D]),
numeric_argument_(Ds, [N|Ns0], Ns, Rest)
; Ns = Ns0,
Rest = [D|Ds]
).
pow10(D, N0-Pow0, N-Pow) :-
N is N0 + D*10^Pow0,
Pow is Pow0 + 1.
integer_to_radix(I0, R, Which, Cs) :-
I is I0, % evaluate compound expression
must_be(integer, I),
must_be(integer, R),
( \+ between(2, 36, R) ->
domain_error(radix, R, format_//2)
; true
),
digits(Which, Ds),
( I < 0 ->
Pos is abs(I),
phrase(integer_to_radix_(Pos, R, Ds), Cs0, "-")
; I =:= 0 -> Cs0 = "0"
; phrase(integer_to_radix_(I, R, Ds), Cs0)
),
reverse(Cs0, Cs).
integer_to_radix_(0, _, _) --> !.
integer_to_radix_(I0, R, Ds) -->
{ M is I0 mod R,
nth0(M, Ds, D),
I is I0 // R
},
[D],
integer_to_radix_(I, R, Ds).
digits(lowercase, "0123456789abcdefghijklmnopqrstuvwxyz").
digits(uppercase, "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ").
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Impure I/O, implemented as a small wrapper over format_//2.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
format(Fs, Args) :-
phrase(format_(Fs, Args), Cs),
maplist(write, Cs).
format(Stream, Fs, Args) :-
phrase(format_(Fs, Args), Cs),
( stream_property(Stream, type(binary)) ->
% maplist(char_code, Cs, Bytes) is currently a lot slower
% than first converting Cs to an atom, and then to codes.
% In the future, we can ideally avoid creating an atom here,
% since an atom leaves traces in the system.
atom_chars(A, Cs),
atom_codes(A, Bytes),
( member(NonByte, Bytes), NonByte > 255 ->
char_code(Char, NonByte),
throw(error(representation_error(Char), format/3))
; true
),
% For binary streams, we use a specialised internal predicate
% that uses only a single "write" operation for efficiency.
'$put_bytes'(Stream, Bytes)
; maplist(put_char(Stream), Cs)
).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
?- phrase(cells("hello", [], 0, []), Cs).
?- phrase(cells("hello~10|", [], 0, []), Cs).
?- phrase(cells("~ta~t~10|", [], 0, []), Cs).
?- phrase(format_("~`at~50|", []), Ls).
?- phrase(cells("~`at~50|", [], 0, []), Cs),
phrase(format_cells(Cs), Ls).
?- phrase(cells("~ta~t~tb~tc~21|", [], 0, []), Cs).
Cs = [cell(0,21,[glue(' ',_38),chars([a]),glue(' ',_62),glue(' ',_67),chars([b]),glue(' ',_91),chars([c])])].
?- phrase(cells("~ta~t~4|", [], 0, []), Cs).
Cs = [cell(0,4,[glue(' ',_38),chars([a]),glue(' ',_62)])].
?- phrase(format_cell(cell(0,1,[glue(a,_94)])), Ls).
?- phrase(format_cell(cell(0,50,[chars("hello")])), Ls).
?- phrase(format_("~`at~50|~n", []), Ls).
?- phrase(format_("hello~n~tthere~6|", []), Ls).
?- format("~ta~t~4|", []).
a true
; false.
?- format("~ta~tb~tc~10|", []).
a b c true
; false.
?- format("~tabc~3|", []).
?- format("~ta~t~4|", []).
?- format("~ta~t~tb~tc~20|", []).
a b c true
; false.
?- format("~2f~n", [3]).
3.00
true
?- format("~20f", [0.1]).
0.10000000000000000000 true % this should use higher accuracy!
; false.
?- X is atan(2), format("~7f~n", [X]).
1.1071487
X = 1.1071487177940906
?- format("~`at~50|~n", []).
aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
true
?- format("~t~N", []).
?- format("~q", [.]).
'.' true
?- format("~12r", [300]).
210 true
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
We also provide rudimentary versions of portray_clause/1 and listing/1.
In the eventual library organization, portray_clause/1 and
related predicates may be placed in their own dedicated library.
portray_clause/1 is useful for printing solutions in such a way
that they can be read back with read/1.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
portray_clause(Term) :-
phrase(portray_clause_(Term), Ls),
maplist(write, Ls).
portray_clause_(Term) -->
{ term_variables(Term, Vs),
foldl(var_name, Vs, VNs, 0, _) },
portray_(Term, VNs), ".\n".
var_name(V, Name=V, Num0, Num) :-
charsio:fabricate_var_name(numbervars, Name, Num0),
Num is Num0 + 1.
literal(Lit, VNs) -->
{ write_term_to_chars(Lit, [quoted(true),variable_names(VNs)], Ls) },
list(Ls).
portray_(Var, VNs) --> { var(Var) }, !, literal(Var, VNs).
portray_((Head :- Body), VNs) --> !,
literal(Head, VNs), " :-\n",
body_(Body, 0, 3, VNs).
portray_((Head --> Body), VNs) --> !,
literal(Head, VNs), " -->\n",
body_(Body, 0, 3, VNs).
portray_(Any, VNs) --> literal(Any, VNs).
body_(Var, C, I, VNs) --> { var(Var) }, !,
indent_to(C, I),
literal(Var, VNs).
body_((A,B), C, I, VNs) --> !,
body_(A, C, I, VNs), ",\n",
body_(B, 0, I, VNs).
body_((A ; Else), C, I, VNs) --> % ( If -> Then ; Else )
{ nonvar(A), A = (If -> Then) },
!,
indent_to(C, I),
"( ",
{ C1 is I + 3 },
body_(If, C1, C1, VNs), " ->\n",
body_(Then, 0, C1, VNs), "\n",
else_branch(Else, C1, I, VNs).
body_((A;B), C, I, VNs) --> !,
indent_to(C, I),
"( ",
{ C1 is I + 3 },
body_(A, C1, C1, VNs), "\n",
else_branch(B, C1, I, VNs).
body_(Goal, C, I, VNs) -->
indent_to(C, I), literal(Goal, VNs).
else_branch(Else, C, I, VNs) -->
indent_to(0, I),
"; ",
body_(Else, C, C, VNs), "\n",
indent_to(0, I),
")".
indent_to(CurrentColumn, Indent) -->
{ Delta is Indent - CurrentColumn },
format_("~t~*|", [Delta]).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
?- portray_clause(a).
a.
?- portray_clause((a :- b)).
a :-
b.
?- portray_clause((a :- b, c, d)).
a :-
b,
c,
d.
true
?- portray_clause([a,b,c,d]).
"abcd".
?- portray_clause(X).
?- portray_clause((f(X) :- X)).
?- portray_clause((h :- ( a -> b; c))).
?- portray_clause((h :- ( (a -> x ; y) -> b; c))).
?- portray_clause((h(X) :- ( (a(X) ; y(A,B)) -> b; c))).
?- portray_clause((h :- (a,d;b,c) ; (b,e;d))).
?- portray_clause((a :- b ; c ; d)).
?- portray_clause((h :- L = '.')).
?- portray_clause(-->(a, (b, {t}, d))).
?- portray_clause((A :- B)).
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
listing(PI) :-
nonvar(PI),
( PI = Name/Arity0 ->
Arity = Arity0
; PI = Name//Arity0 ->
Arity is Arity0 + 2
; type_error(predicate_indicator, PI, listing/1)
),
functor(Head, Name, Arity),
\+ \+ clause(Head, _), % only true if there is at least one clause
( clause(Head, Body),
( Body == true ->
portray_clause(Head)
; portray_clause((Head :- Body))
),
false
; true
).

28
src/lib/freeze.pl Normal file
View File

@@ -0,0 +1,28 @@
:- module(freeze, [freeze/2]).
:- use_module(library(atts)).
:- use_module(library(dcgs)).
:- attribute frozen/1.
verify_attributes(Var, Other, Goals) :-
get_atts(Var, frozen(Fa)), !, % are we involved?
( var(Other) -> % must be attributed then
( get_atts(Other, frozen(Fb)) % has a pending goal?
-> put_atts(Other, frozen((Fb,Fa))) % rescue conjunction
; put_atts(Other, frozen(Fa)) % rescue the pending goal
),
Goals = []
; Goals = [Fa]
).
verify_attributes(_, _, []).
freeze(X, Goal) :-
put_atts(Fresh, frozen(Goal)),
Fresh = X.
attribute_goals(Var) -->
{ get_atts(Var, frozen(Goals)),
put_atts(Var, -frozen(_)) },
[freeze(Var, Goals)].

32
src/lib/gensym.pl Normal file
View File

@@ -0,0 +1,32 @@
:- module(gensym, [gensym/2,
reset_gensym/1]).
:- use_module(library(error)).
:- use_module(library(lists)).
:- use_module(library(iso_ext)).
:- use_module(library(si)).
gensym_key(Base, BaseKey) :-
atom_concat('gensym_', Base, BaseKey).
append_id(Base, UniqueID, Unique) :-
atom_chars(Base, BaseChars),
number_chars(UniqueID, IDChars),
append(BaseChars, IDChars, AtomChars),
atom_chars(Unique, AtomChars).
gensym(Base, Unique) :-
must_be(var, Unique),
atom_si(Base),
gensym_key(Base, BaseKey),
( bb_get(BaseKey, UniqueID0) ->
UniqueID is UniqueID0 + 1,
bb_put(BaseKey, UniqueID),
append_id(Base, UniqueID, Unique)
; bb_put(BaseKey, 1),
append_id(Base, 1, Unique)
).
reset_gensym(Base) :-
atom_si(Base),
bb_put(Base, 0).

163
src/lib/iso_ext.pl Normal file
View File

@@ -0,0 +1,163 @@
%% for builtins that are not part of the ISO standard.
%% must be loaded at the REPL with
%% ?- use_module(library(iso_ext)).
:- module(iso_ext, [bb_b_put/2, bb_get/2, bb_put/2, call_cleanup/2,
call_with_inference_limit/3, forall/2,
partial_string/1, partial_string/3,
partial_string_tail/2, setup_call_cleanup/3,
variant/2]).
forall(Generate, Test) :-
\+ (Generate, \+ Test).
%% (non-)backtrackable global variables.
bb_put(Key, Value) :- atom(Key), !, '$store_global_var'(Key, Value).
bb_put(Key, _) :- throw(error(type_error(atom, Key), bb_put/2)).
%% backtrackable global variables.
bb_b_put(Key, NewValue) :-
( '$bb_get_with_offset'(Key, OldValue, OldOffset) ->
call_cleanup((store_global_var_with_offset(Key, NewValue) ; false),
reset_global_var_at_offset(Key, OldValue, OldOffset))
; call_cleanup((store_global_var_with_offset(Key, NewValue) ; false),
reset_global_var_at_key(Key))
).
store_global_var_with_offset(Key, Value) :- '$store_global_var_with_offset'(Key, Value).
store_global_var(Key, Value) :- '$store_global_var'(Key, Value).
reset_global_var_at_key(Key) :- '$reset_global_var_at_key'(Key).
reset_global_var_at_offset(Key, Value, Offset) :- '$reset_global_var_at_offset'(Key, Value, Offset).
'$bb_get_with_offset'(Key, OldValue, Offset) :-
atom(Key), !, '$fetch_global_var_with_offset'(Key, OldValue, Offset).
'$bb_get_with_offset'(Key, _, _) :-
throw(error(type_error(atom, Key), bb_b_put/2)).
bb_get(Key, Value) :- atom(Key), !, '$fetch_global_var'(Key, Value).
bb_get(Key, _) :- throw(error(type_error(atom, Key), bb_get/2)).
call_cleanup(G, C) :- setup_call_cleanup(true, G, C).
% setup_call_cleanup.
setup_call_cleanup(S, G, C) :-
'$get_b_value'(B),
call(S),
'$set_cp_by_default'(B),
'$get_current_block'(Bb),
( '$call_with_default_policy'(var(C)) ->
throw(error(instantiation_error, setup_call_cleanup/3))
; '$call_with_default_policy'(scc_helper(C, G, Bb))
).
:- non_counted_backtracking scc_helper/3.
scc_helper(C, G, Bb) :-
'$get_cp'(Cp), '$install_scc_cleaner'(C, NBb), call(G),
( '$check_cp'(Cp) ->
'$reset_block'(Bb),
'$call_with_default_policy'(run_cleaners_without_handling(Cp))
; '$call_with_default_policy'(true)
; '$reset_block'(NBb),
'$fail').
scc_helper(_, _, Bb) :-
'$reset_block'(Bb),
'$get_ball'(Ball),
'$call_with_default_policy'(run_cleaners_with_handling),
'$erase_ball',
'$call_with_default_policy'(throw(Ball)).
scc_helper(_, _, _) :-
'$get_cp'(Cp),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)),
'$fail'.
:- non_counted_backtracking run_cleaners_with_handling/0.
run_cleaners_with_handling :-
'$get_scc_cleaner'(C), '$get_level'(B),
'$call_with_default_policy'(catch(C, _, true)),
'$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_with_handling).
run_cleaners_with_handling :-
'$restore_cut_policy'.
:- non_counted_backtracking run_cleaners_without_handling/1.
run_cleaners_without_handling(Cp) :-
'$get_scc_cleaner'(C),
'$get_level'(B),
call(C),
'$set_cp_by_default'(B),
'$call_with_default_policy'(run_cleaners_without_handling(Cp)).
run_cleaners_without_handling(Cp) :-
'$set_cp_by_default'(Cp),
'$restore_cut_policy'.
% call_with_inference_limit
:- non_counted_backtracking end_block/4.
end_block(_, Bb, NBb, L) :-
'$clean_up_block'(NBb),
'$reset_block'(Bb).
end_block(B, Bb, NBb, L) :-
'$install_inference_counter'(B, L, _),
'$reset_block'(NBb),
'$fail'.
:- non_counted_backtracking handle_ile/3.
handle_ile(B, inference_limit_exceeded(B), inference_limit_exceeded) :- !.
handle_ile(B, E, _) :-
'$remove_call_policy_check'(B),
'$call_with_default_policy'(throw(E)).
call_with_inference_limit(G, L, R) :-
'$get_current_block'(Bb),
'$get_b_value'(B),
'$call_with_default_policy'(call_with_inference_limit(G, L, R, Bb, B)),
'$remove_call_policy_check'(B).
:- non_counted_backtracking call_with_inference_limit/5.
call_with_inference_limit(G, L, R, Bb, B) :-
'$install_new_block'(NBb),
'$install_inference_counter'(B, L, Count0),
call(G),
'$inference_level'(R, B),
'$remove_inference_counter'(B, Count1),
'$call_with_default_policy'(is(Diff, L - (Count1 - Count0))),
'$call_with_default_policy'(end_block(B, Bb, NBb, Diff)).
call_with_inference_limit(_, _, R, Bb, B) :-
'$reset_block'(Bb),
'$remove_inference_counter'(B, _),
( '$get_ball'(Ball),
'$get_level'(Cp),
'$set_cp_by_default'(Cp)
; '$remove_call_policy_check'(B),
'$fail'
),
'$erase_ball',
'$call_with_default_policy'(handle_ile(B, Ball, R)).
variant(X, Y) :- '$variant'(X, Y).
partial_string(String, L, L0) :-
( String == [] ->
L = L0
; catch(atom_chars(Atom, String),
error(E, _),
throw(error(E, partial_string/3))),
'$create_partial_string'(Atom, L, L0)
).
partial_string(String) :-
'$is_partial_string'(String).
partial_string_tail(String, Tail) :-
( partial_string(String) ->
'$partial_string_tail'(String, Tail)
; throw(error(type_error(partial_string, String), partial_string_tail/2))
).

202
src/lib/lists.pl Normal file
View File

@@ -0,0 +1,202 @@
:- module(lists, [member/2, select/3, append/2, append/3, foldl/4, foldl/5,
memberchk/2, reverse/2, length/2, maplist/2,
maplist/3, maplist/4, maplist/5, maplist/6,
maplist/7, maplist/8, maplist/9, same_length/2, nth0/3,
sum_list/2, transpose/2, list_to_set/2]).
:- use_module(library(error)).
length(Xs, N) :-
var(N), !,
'$skip_max_list'(M, -1, Xs, Xs0),
( Xs0 == [] -> N = M
; var(Xs0) -> length_addendum(Xs0, N, M)).
length(Xs, N) :-
integer(N),
N >= 0, !,
'$skip_max_list'(M, N, Xs, Xs0),
( Xs0 == [] -> N = M
; var(Xs0) -> R is N-M, length_rundown(Xs0, R)).
length(_, N) :-
integer(N), !,
domain_error(not_less_than_zero, N, length/2).
length(_, N) :-
type_error(integer, N, length/2).
length_addendum([], N, N).
length_addendum([_|Xs], N, M) :-
M1 is M + 1,
length_addendum(Xs, N, M1).
length_rundown(Xs, 0) :- !, Xs = [].
length_rundown([_|Xs], N) :-
N1 is N-1,
length_rundown(Xs, N1).
member(X, [X|_]).
member(X, [_|Xs]) :- member(X, Xs).
select(X, [X|Xs], Xs).
select(X, [Y|Xs], [Y|Ys]) :- select(X, Xs, Ys).
append([], []).
append([L0|Ls0], Ls) :-
append(L0, Rest, Ls),
append(Ls0, Rest).
append([], R, R).
append([X|L], R, [X|S]) :- append(L, R, S).
memberchk(X, Xs) :- member(X, Xs), !.
reverse(Xs, Ys) :-
( nonvar(Xs) -> reverse(Xs, Ys, [], Xs)
; reverse(Ys, Xs, [], Ys)
).
reverse([], [], YsRev, YsRev).
reverse([_|Xs], [Y1|Ys], YsPreludeRev, Xss) :-
reverse(Xs, Ys, [Y1|YsPreludeRev], Xss).
maplist(_, []).
maplist(Cont1, [E1|E1s]) :-
call(Cont1, E1),
maplist(Cont1, E1s).
maplist(_, [], []).
maplist(Cont2, [E1|E1s], [E2|E2s]) :-
call(Cont2, E1, E2),
maplist(Cont2, E1s, E2s).
maplist(_, [], [], []).
maplist(Cont3, [E1|E1s], [E2|E2s], [E3|E3s]) :-
call(Cont3, E1, E2, E3),
maplist(Cont3, E1s, E2s, E3s).
maplist(_, [], [], [], []).
maplist(Cont, [E1|E1s], [E2|E2s], [E3|E3s], [E4|E4s]) :-
call(Cont, E1, E2, E3, E4),
maplist(Cont, E1s, E2s, E3s, E4s).
maplist(_, [], [], [], [], []).
maplist(Cont, [E1|E1s], [E2|E2s], [E3|E3s], [E4|E4s], [E5|E5s]) :-
call(Cont, E1, E2, E3, E4, E5),
maplist(Cont, E1s, E2s, E3s, E4s, E5s).
maplist(_, [], [], [], [], [], []).
maplist(Cont, [E1|E1s], [E2|E2s], [E3|E3s], [E4|E4s], [E5|E5s], [E6|E6s]) :-
call(Cont, E1, E2, E3, E4, E5, E6),
maplist(Cont, E1s, E2s, E3s, E4s, E5s, E6s).
maplist(_, [], [], [], [], [], [], []).
maplist(Cont, [E1|E1s], [E2|E2s], [E3|E3s], [E4|E4s], [E5|E5s], [E6|E6s], [E7|E7s]) :-
call(Cont, E1, E2, E3, E4, E5, E6, E7),
maplist(Cont, E1s, E2s, E3s, E4s, E5s, E6s, E7s).
maplist(_, [], [], [], [], [], [], [], []).
maplist(Cont, [E1|E1s], [E2|E2s], [E3|E3s], [E4|E4s], [E5|E5s], [E6|E6s], [E7|E7s], [E8|E8s]) :-
call(Cont, E1, E2, E3, E4, E5, E6, E7, E8),
maplist(Cont, E1s, E2s, E3s, E4s, E5s, E6s, E7s, E8s).
sum_list(Ls, S) :-
foldl(sum_, Ls, 0, S).
sum_(L, S0, S) :- S is S0 + L.
same_length([], []).
same_length([_|As], [_|Bs]) :-
same_length(As, Bs).
foldl(Goal_3, Ls, A0, A) :-
foldl_(Ls, Goal_3, A0, A).
foldl_([], _, A, A).
foldl_([L|Ls], G_3, A0, A) :-
call(G_3, L, A0, A1),
foldl_(Ls, G_3, A1, A).
foldl(Goal_4, Xs, Ys, A0, A) :-
foldl_(Xs, Ys, Goal_4, A0, A).
foldl_([], [], _, A, A).
foldl_([X|Xs], [Y|Ys], G_4, A0, A) :-
call(G_4, X, Y, A0, A1),
foldl_(Xs, Ys, G_4, A1, A).
transpose(Ls, Ts) :-
lists_transpose(Ls, Ts).
lists_transpose([], []).
lists_transpose([L|Ls], Ts) :-
maplist(same_length(L), Ls),
foldl(transpose_, L, Ts, [L|Ls], _).
transpose_(_, Fs, Lists0, Lists) :-
maplist(list_first_rest, Lists0, Fs, Lists).
list_first_rest([L|Ls], L, Ls).
list_to_set(Ls0, Ls) :-
maplist(with_var, Ls0, LVs0),
keysort(LVs0, LVs),
same_elements(LVs),
pick_firsts(LVs0, Ls).
pick_firsts([], []).
pick_firsts([E-V|EVs], Fs0) :-
( V == visited ->
Fs0 = Fs
; V = visited,
Fs0 = [E|Fs]
),
pick_firsts(EVs, Fs).
with_var(E, E-_).
same_elements([]).
same_elements([EV|EVs]) :-
foldl(unify_same, EVs, EV, _).
unify_same(E-V, Prev-Var, E-V) :-
( Prev == E ->
Var = V
; true
).
nth0(N, Es, E) :-
can_be(integer, N),
can_be(list, Es),
( integer(N) ->
nth0_index(N, Es, E)
; nth0_search(N, Es, E)
).
nth0_index(0, [E|_], E) :- !.
nth0_index(N, [_|Es], E) :-
N > 0,
N1 is N - 1,
nth0_index(N1, Es, E).
nth0_search(N, Es, E) :-
nth0_search(0, N, Es, E).
nth0_search(N, N, [E|_], E).
nth0_search(N0, N, [_|Es], E) :-
N1 is N0 + 1,
nth0_search(N1, N, Es, E).

625
src/lib/ordsets.pl Normal file
View File

@@ -0,0 +1,625 @@
/* Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (c) 2001-2014, University of Amsterdam
VU University Amsterdam
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(ordsets,
[ is_ordset/1, % @Term
list_to_ord_set/2, % +List, -OrdSet
ord_add_element/3, % +Set, +Element, -NewSet
ord_del_element/3, % +Set, +Element, -NewSet
ord_selectchk/3, % +Item, ?Set1, ?Set2
ord_intersect/2, % +Set1, +Set2 (test non-empty)
ord_intersect/3, % +Set1, +Set2, -Intersection
ord_intersection/3, % +Set1, +Set2, -Intersection
ord_intersection/4, % +Set1, +Set2, -Intersection, -Diff
ord_disjoint/2, % +Set1, +Set2
ord_subtract/3, % +Set, +Delete, -Remaining
ord_union/2, % +SetOfOrdSets, -Set
ord_union/3, % +Set1, +Set2, -Union
ord_union/4, % +Set1, +Set2, -Union, -New
ord_subset/2, % +Sub, +Super (test Sub is in Super)
% Non-Quintus extensions
ord_empty/1, % ?Set
ord_memberchk/2, % +Element, +Set,
ord_symdiff/3, % +Set1, +Set2, ?Diff
% SICSTus extensions
ord_seteq/2, % +Set1, +Set2
ord_intersection/2 % +PowerSet, -Intersection
]).
:- use_module(library(lists)).
/** <module> Ordered set manipulation
Ordered sets are lists with unique elements sorted to the standard order
of terms (see sort/2). Exploiting ordering, many of the set operations
can be expressed in order N rather than N^2 when dealing with unordered
sets that may contain duplicates. The library(ordsets) is available in a
number of Prolog implementations. Our predicates are designed to be
compatible with common practice in the Prolog community. The
implementation is incomplete and relies partly on library(oset), an
older ordered set library distributed with SWI-Prolog. New applications
are advised to use library(ordsets).
Some of these predicates match directly to corresponding list
operations. It is advised to use the versions from this library to make
clear you are operating on ordered sets. An exception is member/2. See
ord_memberchk/2.
The ordsets library is based on the standard order of terms. This
implies it can handle all Prolog terms, including variables. Note
however, that the ordering is not stable if a term inside the set is
further instantiated. Also note that variable ordering changes if
variables in the set are unified with each other or a variable in the
set is unified with a variable that is `older' than the newest variable
in the set. In practice, this implies that it is allowed to use
member(X, OrdSet) on an ordered set that holds variables only if X is a
fresh variable. In other cases one should cease using it as an ordset
because the order it relies on may have been changed.
*/
%! is_ordset(@Term) is semidet.
%
% True if Term is an ordered set. All predicates in this library
% expect ordered sets as input arguments. Failing to fullfil this
% assumption results in undefined behaviour. Typically, ordered
% sets are created by predicates from this library, sort/2 or
% setof/3.
is_ordset(Term) :-
'$skip_max_list'(_, -1, Term, Tail), Tail == [], %% is_list(Term),
is_ordset2(Term).
is_ordset2([]).
is_ordset2([H|T]) :-
is_ordset3(T, H).
is_ordset3([], _).
is_ordset3([H2|T], H) :-
H2 @> H,
is_ordset3(T, H2).
%! ord_empty(?List) is semidet.
%
% True when List is the empty ordered set. Simply unifies list
% with the empty list. Not part of Quintus.
ord_empty([]).
%! ord_seteq(+Set1, +Set2) is semidet.
%
% True if Set1 and Set2 have the same elements. As both are
% canonical sorted lists, this is the same as ==/2.
%
% @compat sicstus
ord_seteq(Set1, Set2) :-
Set1 == Set2.
%! list_to_ord_set(+List, -OrdSet) is det.
%
% Transform a list into an ordered set. This is the same as
% sorting the list.
list_to_ord_set(List, Set) :-
sort(List, Set).
%! ord_intersect(+Set1, +Set2) is semidet.
%
% True if both ordered sets have a non-empty intersection.
ord_intersect([H1|T1], L2) :-
ord_intersect_(L2, H1, T1).
ord_intersect_([H2|T2], H1, T1) :-
compare(Order, H1, H2),
ord_intersect__(Order, H1, T1, H2, T2).
ord_intersect__(<, _H1, T1, H2, T2) :-
ord_intersect_(T1, H2, T2).
ord_intersect__(=, _H1, _T1, _H2, _T2).
ord_intersect__(>, H1, T1, _H2, T2) :-
ord_intersect_(T2, H1, T1).
%! ord_disjoint(+Set1, +Set2) is semidet.
%
% True if Set1 and Set2 have no common elements. This is the
% negation of ord_intersect/2.
ord_disjoint(Set1, Set2) :-
\+ ord_intersect(Set1, Set2).
%! ord_intersect(+Set1, +Set2, -Intersection)
%
% Intersection holds the common elements of Set1 and Set2.
%
% @deprecated Use ord_intersection/3
ord_intersect(Set1, Set2, Intersection) :-
oset_int(Set1, Set2, Intersection).
%! ord_intersection(+PowerSet, -Intersection)
%
% Intersection of a powerset. True when Intersection is an ordered
% set holding all elements common to all sets in PowerSet.
%
% @compat sicstus
ord_intersection(PowerSet, Intersection) :-
key_by_length(PowerSet, Pairs),
keysort(Pairs, [_-S|Sorted]),
l_int(Sorted, S, Intersection).
key_by_length([], []).
key_by_length([H|T0], [L-H|T]) :-
length(H, L),
key_by_length(T0, T).
l_int([], S, S).
l_int([_-H|T], S0, S) :-
ord_intersection(S0, H, S1),
l_int(T, S1, S).
%! ord_intersection(+Set1, +Set2, -Intersection) is det.
%
% Intersection holds the common elements of Set1 and Set2. Uses
% ord_disjoint/2 if Intersection is bound to `[]` on entry.
ord_intersection(Set1, Set2, Intersection) :-
( Intersection == []
-> ord_disjoint(Set1, Set2)
; oset_int(Set1, Set2, Intersection)
).
%! ord_intersection(+Set1, +Set2, ?Intersection, ?Difference) is det.
%
% Intersection and difference between two ordered sets.
% Intersection is the intersection between Set1 and Set2, while
% Difference is defined by ord_subtract(Set2, Set1, Difference).
%
% @see ord_intersection/3 and ord_subtract/3.
ord_intersection([], L, [], L) :- !.
ord_intersection([_|_], [], [], []) :- !.
ord_intersection([H1|T1], [H2|T2], Intersection, Difference) :-
compare(Diff, H1, H2),
ord_intersection2(Diff, H1, T1, H2, T2, Intersection, Difference).
ord_intersection2(=, H1, T1, _H2, T2, [H1|T], Difference) :-
ord_intersection(T1, T2, T, Difference).
ord_intersection2(<, _, T1, H2, T2, Intersection, Difference) :-
ord_intersection(T1, [H2|T2], Intersection, Difference).
ord_intersection2(>, H1, T1, H2, T2, Intersection, [H2|HDiff]) :-
ord_intersection([H1|T1], T2, Intersection, HDiff).
%! ord_add_element(+Set1, +Element, ?Set2) is det.
%
% Insert an element into the set. This is the same as
% ord_union(Set1, [Element], Set2).
ord_add_element(Set1, Element, Set2) :-
oset_addel(Set1, Element, Set2).
%! ord_del_element(+Set, +Element, -NewSet) is det.
%
% Delete an element from an ordered set. This is the same as
% ord_subtract(Set, [Element], NewSet).
ord_del_element(Set, Element, NewSet) :-
oset_delel(Set, Element, NewSet).
%! ord_selectchk(+Item, ?Set1, ?Set2) is semidet.
%
% Selectchk/3, specialised for ordered sets. Is true when
% select(Item, Set1, Set2) and Set1, Set2 are both sorted lists
% without duplicates. This implementation is only expected to work
% for Item ground and either Set1 or Set2 ground. The "chk" suffix
% is meant to remind you of memberchk/2, which also expects its
% first argument to be ground. ord_selectchk(X, S, T) =>
% ord_memberchk(X, S) & \+ ord_memberchk(X, T).
%
% @author Richard O'Keefe
ord_selectchk(Item, [X|Set1], [X|Set2]) :-
X @< Item,
!,
ord_selectchk(Item, Set1, Set2).
ord_selectchk(Item, [Item|Set1], Set1) :-
( Set1 == []
-> true
; Set1 = [Y|_]
-> Item @< Y
).
%! ord_memberchk(+Element, +OrdSet) is semidet.
%
% True if Element is a member of OrdSet, compared using ==. Note
% that _enumerating_ elements of an ordered set can be done using
% member/2.
%
% Some Prolog implementations also provide ord_member/2, with the
% same semantics as ord_memberchk/2. We believe that having a
% semidet ord_member/2 is unacceptably inconsistent with the *_chk
% convention. Portable code should use ord_memberchk/2 or
% member/2.
%
% @author Richard O'Keefe
ord_memberchk(Item, [X1,X2,X3,X4|Xs]) :-
!,
compare(R4, Item, X4),
( R4 = (>) -> ord_memberchk(Item, Xs)
; R4 = (<) ->
compare(R2, Item, X2),
( R2 = (>) -> Item == X3
; R2 = (<) -> Item == X1
;/* R2 = (=), Item == X2 */ true
)
;/* R4 = (=) */ true
).
ord_memberchk(Item, [X1,X2|Xs]) :-
!,
compare(R2, Item, X2),
( R2 = (>) -> ord_memberchk(Item, Xs)
; R2 = (<) -> Item == X1
;/* R2 = (=) */ true
).
ord_memberchk(Item, [X1]) :-
Item == X1.
%! ord_subset(+Sub, +Super) is semidet.
%
% Is true if all elements of Sub are in Super
ord_subset([], _).
ord_subset([H1|T1], [H2|T2]) :-
compare(Order, H1, H2),
ord_subset_(Order, H1, T1, T2).
ord_subset_(>, H1, T1, [H2|T2]) :-
compare(Order, H1, H2),
ord_subset_(Order, H1, T1, T2).
ord_subset_(=, _, T1, T2) :-
ord_subset(T1, T2).
%! ord_subtract(+InOSet, +NotInOSet, -Diff) is det.
%
% Diff is the set holding all elements of InOSet that are not in
% NotInOSet.
ord_subtract(InOSet, NotInOSet, Diff) :-
oset_diff(InOSet, NotInOSet, Diff).
%! ord_union(+SetOfSets, -Union) is det.
%
% True if Union is the union of all elements in the superset
% SetOfSets. Each member of SetOfSets must be an ordered set, the
% sets need not be ordered in any way.
%
% @author Copied from YAP, probably originally by Richard O'Keefe.
ord_union([], []).
ord_union([Set|Sets], Union) :-
length([Set|Sets], NumberOfSets),
ord_union_all(NumberOfSets, [Set|Sets], Union, []).
ord_union_all(N, Sets0, Union, Sets) :-
( N =:= 1
-> Sets0 = [Union|Sets]
; N =:= 2
-> Sets0 = [Set1,Set2|Sets],
ord_union(Set1,Set2,Union)
; A is N>>1,
Z is N-A,
ord_union_all(A, Sets0, X, Sets1),
ord_union_all(Z, Sets1, Y, Sets),
ord_union(X, Y, Union)
).
%! ord_union(+Set1, +Set2, ?Union) is det.
%
% Union is the union of Set1 and Set2
ord_union(Set1, Set2, Union) :-
oset_union(Set1, Set2, Union).
%! ord_union(+Set1, +Set2, -Union, -New) is det.
%
% True iff ord_union(Set1, Set2, Union) and
% ord_subtract(Set2, Set1, New).
ord_union([], Set2, Set2, Set2).
ord_union([H|T], Set2, Union, New) :-
ord_union_1(Set2, H, T, Union, New).
ord_union_1([], H, T, [H|T], []).
ord_union_1([H2|T2], H, T, Union, New) :-
compare(Order, H, H2),
ord_union(Order, H, T, H2, T2, Union, New).
ord_union(<, H, T, H2, T2, [H|Union], New) :-
ord_union_2(T, H2, T2, Union, New).
ord_union(>, H, T, H2, T2, [H2|Union], [H2|New]) :-
ord_union_1(T2, H, T, Union, New).
ord_union(=, H, T, _, T2, [H|Union], New) :-
ord_union(T, T2, Union, New).
ord_union_2([], H2, T2, [H2|T2], [H2|T2]).
ord_union_2([H|T], H2, T2, Union, New) :-
compare(Order, H, H2),
ord_union(Order, H, T, H2, T2, Union, New).
%! ord_symdiff(+Set1, +Set2, ?Difference) is det.
%
% Is true when Difference is the symmetric difference of Set1 and
% Set2. I.e., Difference contains all elements that are not in the
% intersection of Set1 and Set2. The semantics is the same as the
% sequence below (but the actual implementation requires only a
% single scan).
%
% ==
% ord_union(Set1, Set2, Union),
% ord_intersection(Set1, Set2, Intersection),
% ord_subtract(Union, Intersection, Difference).
% ==
%
% For example:
%
% ==
% ?- ord_symdiff([1,2], [2,3], X).
% X = [1,3].
% ==
ord_symdiff([], Set2, Set2).
ord_symdiff([H1|T1], Set2, Difference) :-
ord_symdiff(Set2, H1, T1, Difference).
ord_symdiff([], H1, T1, [H1|T1]).
ord_symdiff([H2|T2], H1, T1, Difference) :-
compare(Order, H1, H2),
ord_symdiff(Order, H1, T1, H2, T2, Difference).
ord_symdiff(<, H1, Set1, H2, T2, [H1|Difference]) :-
ord_symdiff(Set1, H2, T2, Difference).
ord_symdiff(=, _, T1, _, T2, Difference) :-
ord_symdiff(T1, T2, Difference).
ord_symdiff(>, H1, T1, H2, Set2, [H2|Difference]) :-
ord_symdiff(Set2, H1, T1, Difference).
/* The osets library on which ordsets depends.
Author: Jon Jagger
E-mail: J.R.Jagger@shu.ac.uk
Copyright (c) 1993-2011, Jon Jagger
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
/** <module> Ordered set manipulation
This library defines set operations on sets represented as ordered
lists.
@author Jon Jagger
@deprecated Use the de-facto library ordsets.pl
*/
%% oset_is(+OSet)
% check that OSet in correct format (standard order)
oset_is(-) :- !, fail. % var filter
oset_is([]).
oset_is([H|T]) :-
oset_is(T, H).
oset_is(-, _) :- !, fail. % var filter
oset_is([], _H).
oset_is([H|T], H0) :-
H0 @< H, % use standard order
oset_is(T, H).
%% oset_union(+OSet1, +OSet2, -Union).
oset_union([], Union, Union).
oset_union([H1|T1], L2, Union) :-
union2(L2, H1, T1, Union).
union2([], H1, T1, [H1|T1]).
union2([H2|T2], H1, T1, Union) :-
compare(Order, H1, H2),
union3(Order, H1, T1, H2, T2, Union).
union3(<, H1, T1, H2, T2, [H1|Union]) :-
union2(T1, H2, T2, Union).
union3(=, H1, T1, _H2, T2, [H1|Union]) :-
oset_union(T1, T2, Union).
union3(>, H1, T1, H2, T2, [H2|Union]) :-
union2(T2, H1, T1, Union).
%% oset_int(+OSet1, +OSet2, -Int)
% ordered set intersection
oset_int([], _Int, []).
oset_int([H1|T1], L2, Int) :-
isect2(L2, H1, T1, Int).
isect2([], _H1, _T1, []).
isect2([H2|T2], H1, T1, Int) :-
compare(Order, H1, H2),
isect3(Order, H1, T1, H2, T2, Int).
isect3(<, _H1, T1, H2, T2, Int) :-
isect2(T1, H2, T2, Int).
isect3(=, H1, T1, _H2, T2, [H1|Int]) :-
oset_int(T1, T2, Int).
isect3(>, H1, T1, _H2, T2, Int) :-
isect2(T2, H1, T1, Int).
%% oset_diff(+InOSet, +NotInOSet, -Diff)
% ordered set difference
oset_diff([], _Not, []).
oset_diff([H1|T1], L2, Diff) :-
diff21(L2, H1, T1, Diff).
diff21([], H1, T1, [H1|T1]).
diff21([H2|T2], H1, T1, Diff) :-
compare(Order, H1, H2),
diff3(Order, H1, T1, H2, T2, Diff).
diff12([], _H2, _T2, []).
diff12([H1|T1], H2, T2, Diff) :-
compare(Order, H1, H2),
diff3(Order, H1, T1, H2, T2, Diff).
diff3(<, H1, T1, H2, T2, [H1|Diff]) :-
diff12(T1, H2, T2, Diff).
diff3(=, _H1, T1, _H2, T2, Diff) :-
oset_diff(T1, T2, Diff).
diff3(>, H1, T1, _H2, T2, Diff) :-
diff21(T2, H1, T1, Diff).
%% oset_dunion(+SetofSets, -DUnion)
% distributed union
oset_dunion([], []).
oset_dunion([H|T], DUnion) :-
oset_dunion(T, H, DUnion).
oset_dunion([], DUnion, DUnion).
oset_dunion([H|T], DUnion0, DUnion) :-
oset_union(H, DUnion0, DUnion1),
oset_dunion(T, DUnion1, DUnion).
%% oset_dint(+SetofSets, -DInt)
% distributed intersection
oset_dint([], []).
oset_dint([H|T], DInt) :-
dint(T, H, DInt).
dint([], DInt, DInt).
dint([H|T], DInt0, DInt) :-
oset_int(H, DInt0, DInt1),
dint(T, DInt1, DInt).
%! oset_power(+Set, -PSet)
%
% True when PSet is the powerset of Set. That is, Pset is a set of
% all subsets of Set, where each subset is a proper ordered set.
oset_power(S, PSet) :-
reverse(S, R),
pset(R, [[]], PSet0),
sort(PSet0, PSet).
% The powerset of a set is the powerset of a set of one smaller,
% together with the set of one smaller where each subset is extended
% with the new element. Note that this produces the elements of the set
% in reverse order. Hence the reverse in oset_power/2.
pset([], PSet, PSet).
pset([H|T], PSet0, PSet) :-
happ(PSet0, H, PSet1),
pset(T, PSet1, PSet).
happ([], _, []).
happ([S|Ss], H, [[H|S],S|Rest]) :-
happ(Ss, H, Rest).
%% oset_addel(+Set, +El, -Add)
% ordered set element addition
oset_addel([], El, [El]).
oset_addel([H|T], El, Add) :-
compare(Order, H, El),
addel(Order, H, T, El, Add).
addel(<, H, T, El, [H|Add]) :-
oset_addel(T, El, Add).
addel(=, H, T, _El, [H|T]).
addel(>, H, T, El, [El,H|T]).
%% oset_delel(+Set, +El, -Del)
% ordered set element deletion
oset_delel([], _El, []).
oset_delel([H|T], El, Del) :-
compare(Order, H, El),
delel(Order, H, T, El, Del).
delel(<, H, T, El, [H|Del]) :-
oset_delel(T, El, Del).
delel(=, _H, T, _El, T).
delel(>, H, T, _El, [H|T]).

33
src/lib/pairs.pl Normal file
View File

@@ -0,0 +1,33 @@
:- module(pairs, [pairs_keys_values/3,
pairs_keys/2,
pairs_values/2,
group_pairs_by_key/2,
map_list_to_pairs/3]).
pairs_keys_values([], [], []).
pairs_keys_values([A-B|ABs], [A|As], [B|Bs]) :-
pairs_keys_values(ABs, As, Bs).
pairs_keys(Ps, Ks) :- pairs_keys_values(Ps, Ks, _).
pairs_values(Ps, Vs) :- pairs_keys_values(Ps, _, Vs).
map_list_to_pairs(Pred, Ls, Ps) :-
map_list_to_pairs2(Ls, Pred, Ps).
map_list_to_pairs2([], _, []).
map_list_to_pairs2([H|T0], Pred, [K-H|T]) :-
call(Pred, H, K),
map_list_to_pairs2(T0, Pred, T).
group_pairs_by_key([], []).
group_pairs_by_key([K-V|KVs0], [K-[V|Vs]|KVs]) :-
same_key(K, KVs0, Vs, KVs1),
group_pairs_by_key(KVs1, KVs).
same_key(K0, [K1-V|KVs0], [V|Vs], KVs) :-
K0 == K1, !,
same_key(K0, KVs0, Vs, KVs).
same_key(_, KVs, [], KVs).

24
src/lib/pio.pl Normal file
View File

@@ -0,0 +1,24 @@
:- module(pio, [phrase_from_file/2,
phrase_from_file/3]).
:- use_module(library(dcgs)).
:- use_module(library(error)).
:- use_module(library(lists), [member/2]).
phrase_from_file(NT, File) :-
phrase_from_file(NT, File, []).
phrase_from_file(NT, File, Options) :-
( var(File) -> instantiation_error(phrase_from_file/3)
; (\+ atom(File) ; File = []) ->
domain_error(source_sink, File, phrase_from_file/3)
; must_be(list, Options),
( member(Var, Options), var(Var) -> instantiation_error(phrase_from_file/3)
; member(type(Type), Options) ->
must_be(atom, Type),
member(Type, [text,binary])
; Type = text
),
'$file_to_chars'(File, Chars, Type),
phrase(NT, Chars)
).

58
src/lib/queues.pl Normal file
View File

@@ -0,0 +1,58 @@
:- module(queues, [queue/1, queue/2, queue_head/3, queue_head_list/3,
queue_last/3, queue_last_list/3, list_queue/2,
queue_length/2]).
/* true when Queue is a queue with no elements. */
queue(q(0,B,B)).
/* true when Queue is a queue with one element. */
queue(X, q(s(0), [X|B], B)).
/* true when Queue0 and Queue1 have the same elements except that
* Queue0 has in addition X at the front. Use it for enqueuing and
* dequeuing both.
*/
queue_head(X, q(N, F, B), q(s(N), [X|F], B)).
/* true when append(List, Queue1, Queue0) would be true if only Queue1
* and Queue0 were lists instead of queues.
*/
queue_head_list([], Queue, Queue).
queue_head_list([X|Xs], Queue, Queue0) :-
queue_head(X, Queue1, Queue0),
queue_head_list(Xs, Queue, Queue1).
/* true when Queue0 and Queue1 have the same elements except that
* Queue0 has in addition to X at the end.
*/
queue_last(X, q(N, F, [X|B]), q(s(N), F, B)).
/* true when append(Queue1, List, Queue0) would be true if only Queue1
* and Queue0 were lists instead of queues.
*/
queue_last_list([], Queue, Queue).
queue_last_list([X|Xs], Queue1, Queue) :-
queue_last(X, Queue1, Queue2),
queue_last_list(Xs, Queue2, Queue).
/* true when List is a list and Queue is a queue and they represent
* the same sequence.
*/
list_queue(List, q(Count, Front, Back)) :-
list_queue(List, Count, Front, Back).
list_queue([], 0, B, B).
list_queue([X|Xs], s(N), [X|F], B) :-
list_queue(Xs, N, F, B).
/* is true when Length is (a binary length representing) the number of
* elements in (the queue represented by) Queue. This version cannot
* be used to generate a Queue, only to determine the Length.
*/
queue_length(q(Count, F, B), Length) :-
queue_length(Count, F, B, 0, Length).
queue_length(0, B, B, Length, Length).
queue_length(s(N), [_|Front], Back, L0, Length) :-
L1 is L0 + 1,
queue_length(N, Front, Back, L1, Length).

59
src/lib/random.pl Normal file
View File

@@ -0,0 +1,59 @@
:- module(random, [maybe/0, random/1, random_integer/3, set_random/1]).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
To retain desirable declarative properties, predicates that internally
use random numbers should be equipped with an argument that specifies
the random seed. This makes everything completely reproducible.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- use_module(library(error)).
% succeeds with probability 0.5.
maybe :- '$maybe'.
% The higher the precision, the slower it gets.
random_number_precision(64).
random(R) :-
var(R),
random_number_precision(N),
rnd(N, R).
random_integer(Lower, Upper, R) :-
var(R),
( (var(Lower) ; var(Upper)) ->
instantiation_error(random_integer/3)
; \+ integer(Lower) ->
domain_error(integer, Lower, random_integer/3)
; \+ integer(Upper) ->
domain_error(integer, Upper, random_integer/3)
; Upper > Lower,
random(R0),
R is floor((Upper - Lower) * R0 + Lower)
).
rnd(N, R) :-
rnd_(N, 0, R).
rnd_(0, R, R) :- !.
rnd_(N, R0, R) :-
maybe,
!,
N1 is N - 1,
rnd_(N1, R0, R).
rnd_(N, R0, R) :-
N1 is N - 1,
R1 is R0 + 1.0 / 2.0 ^ N,
rnd_(N1, R1, R).
set_random(Seed) :-
( nonvar(Seed) ->
( Seed = seed(S) ->
( var(S) -> instantiation_error(set_random/1)
; integer(S) -> '$set_seed'(S)
; type_error(integer, S, set_random/1)
)
)
; instantiation_error(set_random/1)
).

67
src/lib/reif.pl Normal file
View File

@@ -0,0 +1,67 @@
:- module(reif, [if_/3, (=)/3, (',')/3, (;)/3, cond_t/3, dif/3,
memberd_t/3, tfilter/3, tmember/2, tmember_t/3,
tpartition/4]).
:- use_module(library(dif)).
if_(If_1, Then_0, Else_0) :-
call(If_1, T),
( T == true -> call(Then_0)
; T == false -> call(Else_0)
; nonvar(T) -> throw(error(type_error(boolean, T), _))
; throw(error(instantiation_error, _))
).
=(X, Y, T) :-
( X == Y -> T = true
; X \= Y -> T = false
; T = true, X = Y
; T = false, dif(X, Y)
).
dif(X, Y, T) :-
=(X, Y, NT),
non(NT, T).
non(true, false).
non(false, true).
tfilter(C_2, Es, Fs) :-
i_tfilter(Es, C_2, Fs).
i_tfilter([], _, []).
i_tfilter([E|Es], C_2, Fs0) :-
if_(call(C_2, E), Fs0 = [E|Fs], Fs0 = Fs),
i_tfilter(Es, C_2, Fs).
tpartition(P_2, Xs, Ts, Fs) :-
i_tpartition(Xs, P_2, Ts, Fs).
i_tpartition([], _P_2, [], []).
i_tpartition([X|Xs], P_2, Ts0, Fs0) :-
if_( call(P_2, X)
, ( Ts0 = [X|Ts], Fs0 = Fs )
, ( Fs0 = [X|Fs], Ts0 = Ts ) ),
i_tpartition(Xs, P_2, Ts, Fs).
','(A_1, B_1, T) :-
if_(A_1, call(B_1, T), T = false).
';'(A_1, B_1, T) :-
if_(A_1, T = true, call(B_1, T)).
cond_t(If_1, Then_0, T) :-
if_(If_1, ( Then_0, T = true ), T = false ).
memberd_t(E, Xs, T) :-
i_memberd_t(Xs, E, T).
i_memberd_t([], _, false).
i_memberd_t([X|Xs], E, T) :-
if_( X = E, T = true, i_memberd_t(Xs, E, T) ).
tmember(P_2, [X|Xs]) :-
if_( call(P_2, X), true, tmember(P_2, Xs) ).
tmember_t(P_2, [X|Xs], T) :-
if_( call(P_2, X), T = true, tmember_t(P_2, Xs, T) ).

47
src/lib/si.pl Normal file
View File

@@ -0,0 +1,47 @@
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Safe type tests
===============
"si" stands for "sufficiently instantiated".
These predicates:
- throw instantiation errors if the argument is
not sufficiently instantiated to make a sound decision
- succeed if the argument is of the specified type
- fail otherwise.
For instance, atom_si(A) yields an *instantiation error* if A is a
variable. This is logically sound, since in that case the argument
is not sufficiently instantiated to make any decision.
The definitions are taken from:
https://stackoverflow.com/questions/27306453/safer-type-tests-in-prolog
"si" can also be read as "safe inference", so possibly also other
predicates are candidates for this library.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- module(si, [atom_si/1,
integer_si/1,
atomic_si/1,
list_si/1]).
:- use_module(library(lists)).
atom_si(A) :-
functor(A, _, 0), % for the instantiation error
atom(A).
integer_si(I) :-
functor(I, _, 0),
integer(I).
atomic_si(AC) :-
functor(AC,_,0).
list_si(L) :-
\+ \+ length(L, _),
sort(L, _).

67
src/lib/sockets.pl Normal file
View File

@@ -0,0 +1,67 @@
:- module(sockets, [socket_client_open/3,
socket_server_open/2,
socket_server_accept/4,
socket_server_close/1,
current_hostname/1]).
:- use_module(library(error)).
:- use_module(library(lists)).
parse_socket_options_(tls(TLS), tls-TLS) :-
must_be(boolean, TLS), !.
parse_socket_options_(Option, OptionPair) :-
builtins:parse_stream_options_(Option, OptionPair).
parse_socket_options(Options, OptionValues, Stub) :-
DefaultOptions = [alias-[], eof_action-eof_code, reposition-false, tls-false, type-text],
builtins:parse_options_list(Options, parse_socket_options_, DefaultOptions, OptionValues, Stub).
socket_client_open(Addr, Stream, Options) :-
( var(Addr) ->
throw(error(instantiation_error, socket_client_open/3))
;
true
),
must_be(var, Stream),
must_be(list, Options),
( Addr = Address:Port,
atom(Address),
( atom(Port) ; integer(Port) ) ->
true
;
throw(error(type_error(socket_address, Addr), socket_client_open/3))
),
parse_socket_options(Options,
[Alias, EOFAction, Reposition, TLS, Type],
socket_client_open/3),
'$socket_client_open'(Address, Port, Stream, Alias, EOFAction, Reposition, Type, TLS).
socket_server_open(Addr, ServerSocket) :-
must_be(var, ServerSocket),
( ( integer(Addr) ; var(Addr) ) ->
'$socket_server_open'([], Addr, ServerSocket)
;
Addr = Address:Port,
must_be(atom, Address),
can_be(integer, Port),
'$socket_server_open'(Address, Port, ServerSocket)
).
socket_server_accept(ServerSocket, Client, Stream, Options) :-
must_be(var, Client),
must_be(var, Stream),
builtins:parse_stream_options(Options,
[Alias, EOFAction, Reposition, Type],
socket_server_accept/4),
'$socket_server_accept'(ServerSocket, Client, Stream, Alias, EOFAction, Reposition, Type).
socket_server_close(ServerSocket) :-
'$socket_server_close'(ServerSocket).
current_hostname(HostName) :-
'$current_hostname'(HostName).

220
src/lib/tabling.pl Normal file
View File

@@ -0,0 +1,220 @@
:- module(tabling,
[ start_tabling/2, % +Wrapper, :Worker.
abolish_all_tables/0,
% (table)/1, % +PI ...
op(1150, fx, table)
]).
:- use_module('tabling/double_linked_list').
:- use_module('tabling/table_data_structure').
:- use_module('tabling/batched_worklist').
:- use_module('tabling/wrapper').
:- use_module('tabling/global_worklist').
:- use_module('tabling/table_link_manager').
:- use_module(library(cont)).
:- use_module(library(lists)).
%:- use_module(library(debug)).
:- use_module(library(iso_ext)).
%% :- meta_predicate
%% start_tabling(+, 0).
%% user:exception(+Exception, +Var, -Action)
%
% Realises lazy initialization of table variables.
%% user:exception(undefined_global_variable, Var, retry) :-
%% ( table_gvar(Var)
%% -> true
%% ; format('Creating global var ~q~n', [Var]),
%% nb_setval(Var, [])
%% ).
/*
table_gvar(trie_table_link) :-
table_datastructure_initialize.
table_gvar(newly_created_table_identifiers) :-
table_datastructure_initialize.
table_gvar(table_global_worklist) :-
bb_put(table_global_worklist, []).
table_gvar(table_leader) :-
bb_put(table_leader, []).
*/
%% abolish_all_tables
%
% Remove all tables. Should not be called when tabling is in
% progress.
%
% @bug Check whether tabling is in progress
abolish_all_tables :-
bb_put(trie_table_link, []),
bb_put(newly_created_table_identifiers, []),
bb_put(table_global_worklist,[]),
bb_put(table_leader, []).
% Find table and status for the given call variant.
%
table_and_status_for_variant(V,T,S) :-
% Order of the two calls really important: first create, then get status
table_for_variant(V,T),
tbd_table_status(T,S).
start_tabling(Wrapper,Worker) :-
put_new_trie_table_link,
put_new_global_worklist,
put_new_table_identifiers,
table_and_status_for_variant(Wrapper,T,S),
( S == complete ->
get_answer(T,Wrapper)
;
( exists_scheduling_component ->
run_leader(Wrapper,Worker,T),
% Now answer the original query!
get_answer(T,Wrapper)
;
run_follower(S,Wrapper,Worker,T)
)
).
run_follower(fresh,Wrapper,Worker,T) :-
activate(Wrapper,Worker,T),
shift(call_info(Wrapper,T)).
run_follower(active,Wrapper,_Worker,T) :-
shift(call_info(Wrapper,T)).
run_leader(Wrapper,Worker,T) :-
create_scheduling_component,
activate(Wrapper,Worker,T),
completion,
unset_scheduling_component.
exists_scheduling_component :-
bb_get(table_leader, Leader),
Leader == [].
create_scheduling_component :-
bb_b_put(table_leader, leaderCreated).
unset_scheduling_component :-
bb_put(table_leader, []).
set_all_complete :-
get_newly_created_table_identifiers(Ts, _),
set_all_complete_(Ts).
set_all_complete_([]).
set_all_complete_([T|Ts]) :-
set_complete_status(T),
set_all_complete_(Ts).
cleanup_all_complete :-
get_newly_created_table_identifiers(Ts,_),
cleanup_all_complete_(Ts).
cleanup_all_complete_([]).
cleanup_all_complete_([T|Ts]) :-
cleanup_after_complete(T),
cleanup_all_complete_(Ts).
activate(Wrapper,Worker,T) :-
set_active_status(T),
(
delim(Wrapper,Worker,T),
fail
;
true
).
delim(Wrapper,Worker,Table) :-
% debug(tabling, 'ACT: ~p on ~p', [Wrapper, Table]),
reset(Worker,SourceCall,Continuation),
( Continuation = none ->
( add_answer(Table,Wrapper)
-> true %debug(tabling, 'ADD: ~p', [Wrapper])
; %debug(tabling, 'DUP: ~p', [Wrapper]),
fail
)
;
Continuation = cont(Cont),
SourceCall = call_info(_,SourceTable),
TargetCall = call_info(Wrapper,Table),
Dependency = dependency(SourceCall,Cont,TargetCall),
%debug(tabling, 'DEP: ~p: ~p', [SourceTable,Dependency]),
store_dependency(SourceTable,Dependency)
).
completion :-
( worklist_empty ->
set_all_complete,
cleanup_all_complete,
% The place of the call to reset is really important: it must happen after the completion. If you do it before, you will wrongly remove yourself from the list of newly created table identifiers. On starting hProlog there are no newly created table identifiers, and nb_getval gives [] which is the perfect value.
reset_newly_created_table_identifiers
;
pop_worklist(Table),
completion_step(Table),
completion
).
completion_step(SourceTableID) :-
bb_get(SourceTableID, Table),
get_nb_identifiers(Table, NBWorklistID, _),
(
table_get_work(NBWorklistID,Answer,dependency(Source,Continuation,Target)),
Source = call_info(Answer,_),
Target = call_info(Wrapper,TargetTable),
delim(Wrapper,Continuation,TargetTable),
fail
;
true
).
table_get_work(NBWorklistID,Answer,Dependency) :-
% get_worklist(Table, Worklist),
% NOT IN PAPER (could be part of the definition of pop_worklist):
bb_get(NBWorklistID, table_nb_worklist(Worklist)),
unset_global_worklist_presence_flag(Worklist),
set_flag_executing_all_work(Worklist),
bb_put(NBWorklistID, table_nb_worklist(Worklist)),
table_get_work_(NBWorklistID,Answer,Dependency).
table_get_work_(NBWorklistID,Answer,Dependency) :-
worklist_do_all_work(NBWorklistID,Answer,Dependency0), % This will eventually fail
copy_term(Dependency0,Dependency).
table_get_work_(NBWorklistID,_Answer,_Dependency) :-
bb_get(NBWorklistID, table_nb_worklist(Worklist)),
unset_flag_executing_all_work(Worklist),
bb_put(NBWorklistID, table_nb_worklist(Worklist)),
fail.
worklist_do_all_work(NBWorklistID,Answer,Dependency) :-
( bb_get(NBWorklistID, table_nb_worklist(Worklist)),
wkl_worklist_work_done(Worklist) ->
fail
;
worklist_do_step(NBWorklistID,Answer,Dependency)
;
worklist_do_all_work(NBWorklistID,Answer,Dependency)
).
worklist_do_step(NBWorklistID,Answer,Dependency) :-
bb_get(NBWorklistID, table_nb_worklist(Worklist)),
wkl_p_get_rightmost_inner_answer_cluster_pointer(Worklist,ACP),
wkl_p_swap_answer_continuation(Worklist,ACP,SCP),
dll_get_data(ACP,wkl_answer_cluster(AListFlag)),
dll_get_data(SCP,wkl_suspension_cluster(SListFlag)),
get_atts(AListFlag, batched_worklist, wkl_answer_cluster(AList)),
get_atts(SListFlag, batched_worklist, wkl_suspension_cluster(SList)),
bb_put(NBWorklistID, table_nb_worklist(Worklist)),
member(Answer,AList),
member(Dependency,SList).
:- initialization(bb_put(table_leader, [])).

389
src/lib/tabling/batched_worklist.pl Normal file
View File

@@ -0,0 +1,389 @@
/* Part of SWI-Prolog
Author: Benoit Desouter <Benoit.Desouter@UGent.be>
Jan Wielemaker (SWI-Prolog port)
Copyright (c) 2016, Benoit Desouter
All rights reserved.
Ported to Scryer Prolog by Mark Thom (2019/2020).
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(batched_worklist,
[ wkl_add_answer/2, % +WorkList, +Answer
wkl_add_suspension/2, % +Worklist, +Suspension
wkl_new_worklist/2, % +TableID, -WorkList
unset_flag_executing_all_work/1, % +WorkList
unset_global_worklist_presence_flag/1, % +WorkList
set_flag_executing_all_work/1, % +WorkList
wkl_p_get_rightmost_inner_answer_cluster_pointer/2, % +WorkList, -Cluster
wkl_p_swap_answer_continuation/3, % +WorkList, +Cluster1, +Cluster2
wkl_worklist_work_done/1 % +WorkList
]).
:- use_module(global_worklist).
:- use_module(double_linked_list).
:- use_module(library(atts)).
:- use_module(library(lists)).
:- attribute executing_all_work/1, worklist_presence/1, wkl_answer_cluster/1, wkl_suspension_cluster/1, wkl_answer_cluster_pointer_flag/1.
/** <module> Tabling Worklist management
A batched worklist: a worklist that clusters suspensions and answers as
much as possible. The idea is to minimize the number of swaps. This
should be more efficient than the worklist implementation without
clustering.
Argument positions for nb_setarg:
1. double linked list
2. pointer to the list entry of the rightmost inner answer cluster
3. flag indicating the execution of wkl_unfolded_do_all_work
4. flag indicating whether the table identifier associated with this
worklist is already in the global worklist. This is because more
than one answer can be added due to the execution of other
worklists. 5: table identifier for the table this worklist belongs
to
Contents of a batched worklist:
- wkl_answer_cluster([Answer|RestAnswers]).
- wkl_suspension([Suspension|RestSuspension]).
The difficulty is that you should not add new entries to a cluster once
you started its execution. Probably the simplest way to do so is by
swapping the answer cluster AC and suspension cluster SC before you take
the cartesian product of all answers in AC with all suspensions in SC.
Illustration why you may need a complex procedure for finding the future
rightmost inner answer cluster.
Assume all clusters have 2 entries.
1. AA1 CC1
2. AA2 CC1 AA1 CC2 (swapped AA1 and CC1)
3. AA2 CC1 CC2 AA1 (swapped AA1 and CC2)
4. AA3 CC1 AA2 CC2 AA1 CC3 (swapped AA2 and CC1)
Now AA1 is the RIAC, but AA2 is the future RIAC.
Can you find the future RIAC smarter than by walking back? If you don't,
then it doesn't make sense to use a future RIAC at all. You could use a
stack, which should not grow too large because you use batches. But
walking back also should not take too long, since you use batches.
So let's not use a future RIAC in the first place, and just walk back
when we need a new RIAC. This is easy to implement, hence we can test
more quickly.
Abbreviations:
- RIAC = rightmost inner answer cluster
- FUTRIAC = future rightmost inner answer cluster
*/
%% wkl_new_worklist(+TableID, -WorkList) is det.
%
% Create a new worklist for TableID and add it to the global
% worklist list (global variable `table_global_worklist`.
wkl_new_worklist(TableIdentifier, wkl_worklist(List,AnswerClusterPointerFlag,ExecutingAllWork,WorklistPresence,TableIdentifier)) :-
dll_new_double_linked_list(List),
put_atts(AnswerClusterPointerFlag, wkl_answer_cluster_pointer_flag(List)),
% We set the RIAC to the dummy element at the start of the double linked list, which is List.
% Don't set all the rest for now.
put_atts(ExecutingAllWork, executing_all_work(false)),
put_atts(WorklistPresence, worklist_presence(true)),
add_to_global_worklist(TableIdentifier).
%% wkl_worklist_work_done(+WorkList) is semidet.
%
% The work is done if the RIAC pointer points to the unused cell
% at the beginning. The work is also done if the RIAC pointer
% points to the sole answer cluster in a list dll_start -
% wkl_answer_cluster, because in that case there are no
% suspensions to swap with. This is a special case, which we only
% discovered by testing. You can detect it by checking whether the
% NEXT-pointer of the RIAC is the dummy pointer.
wkl_worklist_work_done(Worklist) :-
wkl_p_get_rightmost_inner_answer_cluster_pointer(Worklist,RiacPointer),
( wkl_is_dummy_pointer(Worklist,RiacPointer) ->
true
;
dll_get_pointer_to_next(RiacPointer,NextPointer),
wkl_is_dummy_pointer(Worklist,NextPointer)
).
set_flag_executing_all_work(wkl_worklist(_,_,ExecutingAllWork,_,_)) :-
put_atts(ExecutingAllWork, executing_all_work(true)).
unset_flag_executing_all_work(wkl_worklist(_,_,ExecutingAllWork,_,_)) :-
put_atts(ExecutingAllWork, executing_all_work(false)).
% Swap answer cluster and the adjacent continuation cluster.
% Mode: + + -
wkl_p_swap_answer_continuation(Worklist,InnerAnswerClusterPointer,SuspensionClusterPointer) :-
% You can have a worklist containing only an answer cluster, but no continuations.
% In that case SuspensionClusterPointer will be dll_start. We must take our precautions elsewhere.
% Do not forget that the list of answers and the list of suspensions is wrapped in a predicate!
dll_get_pointer_to_next(InnerAnswerClusterPointer,SuspensionClusterPointer),
% For reasons of speed we don't use dll_swap: we only swap adjacent elements and we can be sure that they are in the order A,B.
% Therefore we can use dll_p_swap_adjacent_elements_
dll_p_swap_adjacent_elements_(InnerAnswerClusterPointer,SuspensionClusterPointer),
% Update the necessary pointers
wkl_p_update_righmost_inner_answer_cluster_pointer(Worklist,InnerAnswerClusterPointer).
% Update the pointer if the answer cluster it points to is no longer the rightmost inner answer cluster.
wkl_p_update_righmost_inner_answer_cluster_pointer(Worklist,InnerAnswerClusterPointer) :-
( wkl_p_answer_cluster_currently_moved_completely(Worklist,InnerAnswerClusterPointer) ->
wkl_p_find_new_rightmost_inner_answer_cluster_pointer(Worklist,InnerAnswerClusterPointer,NewRiacPointer),
wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,NewRiacPointer)
;
true
).
% Rationale for this implementation: see the top of the file.
% Unify NewRiacPointer to the first pointer satisfying the following conditions:
% - left of StartPointer (when viewing the list as DUMMY-ELEM POINTER POINTER POINTER START-POINTER)
% - either an anwer pointer or the dummy element
% When StartPointer is the dummy element, NewRiacPointer is also the dummy element. We never look "in front of" the dummy element.
wkl_p_find_new_rightmost_inner_answer_cluster_pointer(Worklist,StartPointer,NewRiacPointer) :-
( wkl_is_dummy_pointer(Worklist,StartPointer) ->
NewRiacPointer = StartPointer
;
dll_get_pointer_to_previous(StartPointer,FirstCandidatePointer),
wkl_p_find_new_riac_helper(Worklist,FirstCandidatePointer,NewRiacPointer)
).
wkl_p_find_new_riac_helper(Worklist,CandidatePointer,NewRiacPointer) :-
( is_answer_cluster_or_dummy_pointer(Worklist,CandidatePointer) ->
NewRiacPointer = CandidatePointer
;
dll_get_pointer_to_previous(CandidatePointer,NewCandidate),
wkl_p_find_new_riac_helper(Worklist,NewCandidate,NewRiacPointer)
).
is_answer_cluster_or_dummy_pointer(Worklist,Pointer) :-
( wkl_is_dummy_pointer(Worklist,Pointer) ->
true
;
wkl_p_dereference_pointer(Worklist,Pointer,A),
wkl_p_is_answer_cluster(A)
).
% Failure-driven loop
wkl_clusters_cartesian_product(AnswerCluster,SuspensionCluster) :-
( member(Answer,AnswerCluster),
member(Suspension,SuspensionCluster),
% The meat
run_worklist_helper(Suspension,Answer),
% Trigger loop
fail
;
% Loop base case
true
).
run_worklist_helper(_Suspension, _Answer) :- % FIXME: just silense
throw('not implemented').
wkl_both_flags_unset(wkl_worklist(_Dll,_Riac,ExecutingAllWork,WorklistPresence,_TableIdentifier)) :-
put_atts(ExecutingAllWork, executing_all_work(false)),
put_atts(WorklistPresence, worklist_presence(false)).
set_global_worklist_presence_flag(wkl_worklist(_,_,_,WorklistPresence,_)) :-
put_atts(WorklistPresence, worklist_presence(true)).
unset_global_worklist_presence_flag(wkl_worklist(_,_,_,WorklistPresence,_)) :-
put_atts(WorklistPresence, worklist_presence(false)).
potentially_add_to_global_worklist(Worklist) :-
( wkl_both_flags_unset(Worklist) ->
% Set the flag for presence in the metaworklist
set_global_worklist_presence_flag(Worklist),
% Should add to the metaworklist
arg(5,Worklist,TableIdentifier),
add_to_global_worklist(TableIdentifier)
;
% Nothing to do.
true
).
wkl_add_answer(Worklist,Answer) :-
% Add to global worklist if not executing during wkl_unfolded_do_all_work and not there yet as well.
potentially_add_to_global_worklist(Worklist),
( wkl_p_leftmost_cluster_is_answer_cluster(Worklist) ->
wkl_add_to_existing_answer_cluster(Worklist,Answer)
% If you add to an existing cluster, then obviously you should not change the RIAC.
;
wkl_add_to_new_answer_cluster(Worklist,Answer,AnswerClusterPointer),
% If the RIAC is the dummy pointer, we need to change that.
wkl_p_update_rightmost_inner_answer_cluster_pointer(Worklist,AnswerClusterPointer)
).
wkl_p_update_rightmost_inner_answer_cluster_pointer(Worklist,NewAnswerClusterPointer) :-
wkl_p_get_rightmost_inner_answer_cluster_pointer(Worklist,CurrentRiac),
( wkl_is_dummy_pointer(Worklist,CurrentRiac) -> %% <- debugging this.
wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,NewAnswerClusterPointer)
;
% Nothing to do.
true
).
wkl_add_suspension(Worklist,Suspension) :-
% Add to global worklist if not executing during wkl_unfolded_do_all_work and not there yet as well.
potentially_add_to_global_worklist(Worklist),
( wkl_p_rightmost_cluster_is_suspension_cluster(Worklist) ->
wkl_add_to_existing_suspension_cluster(Worklist,Suspension)
;
wkl_add_to_new_suspension_cluster(Worklist,Suspension,SuspensionClusterPointer),
% If added to a new suspension cluster, we may need to change the righmost inner answer pointer
wkl_p_potential_rias_update_add_contin(Worklist,SuspensionClusterPointer)
).
% This predicate should not fail.
wkl_p_potential_rias_update_add_contin(Worklist,SuspensionClusterPointer) :-
% Look back one entry of the freshly inserted SuspensionClusterPointer
dll_get_pointer_to_previous(SuspensionClusterPointer,PotentialNewRiacPointer),
( wkl_p_is_answer_cluster_pointer(Worklist,PotentialNewRiacPointer) ->
% We must indeed update the rightmost inner answer cluster pointer.
wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,PotentialNewRiacPointer)
;
% Nothing to do, but we should not fail.
true
).
wkl_add_to_existing_answer_cluster(Worklist, Answer) :-
arg(1,Worklist,Dll),
dll_get_pointer_to_next(Dll,AnswerClusterPointer),
wkl_p_dereference_pointer(Worklist,AnswerClusterPointer,AnswerCluster),
AnswerCluster = wkl_answer_cluster(AnswersFlag),
get_atts(AnswersFlag, wkl_answer_cluster(AnswersAlreadyInCluster)),
put_atts(AnswersFlag, wkl_answer_cluster([Answer|AnswersAlreadyInCluster])).
wkl_add_to_new_answer_cluster(
wkl_worklist(Dll,_Ria,_FlagExecutingWork,_AlreadyInMetaworklist,_TableIdentifier),
Answer,AnswerClusterPointer
) :-
dll_append_left(Dll,wkl_answer_cluster(AnswerFlag),AnswerClusterPointer),
put_atts(AnswerFlag, wkl_answer_cluster([Answer])).
wkl_add_to_existing_suspension_cluster(Worklist, Suspension) :-
arg(1,Worklist,Dll),
dll_get_pointer_to_previous(Dll,SuspensionClusterPointer),
wkl_p_dereference_pointer(Worklist,SuspensionClusterPointer,SuspensionCluster),
SuspensionCluster = wkl_suspension_cluster(SuspensionsFlag),
get_atts(SuspensionsFlag, wkl_suspension_cluster(SuspensionsAlreadyInCluster)),
put_atts(SuspensionsFlag, wkl_suspension_cluster([Suspension|SuspensionsAlreadyInCluster])).
%% nb_linkarg(1,SuspensionCluster,[Suspension|SuspensionsAlreadyInCluster]).
wkl_add_to_new_suspension_cluster(
wkl_worklist(Dll,_Ria,_FlagExecutingWork,_AlreadyInMetaworklist,_TableIdentifier),
Suspension,
SuspensionClusterPointer
) :-
put_atts(SuspensionFlag, wkl_suspension_cluster([Suspension])),
dll_append_right(Dll,wkl_suspension_cluster(SuspensionFlag),SuspensionClusterPointer).
wkl_p_is_answer_cluster(CandidateAnswerCluster) :-
nonvar(CandidateAnswerCluster),
CandidateAnswerCluster = wkl_answer_cluster(_).
wkl_p_is_suspension_cluster(CandidateSuspensionCluster) :-
nonvar(CandidateSuspensionCluster),
CandidateSuspensionCluster = wkl_suspension_cluster(_).
wkl_p_leftmost_cluster_is_answer_cluster(Worklist) :-
arg(1,Worklist,Dll),
dll_get_pointer_to_next(Dll,CandidateAnswerClusterPointer),
wkl_p_is_answer_cluster_pointer(Worklist,CandidateAnswerClusterPointer).
wkl_p_rightmost_cluster_is_suspension_cluster(Worklist) :-
arg(1,Worklist,Dll),
dll_get_pointer_to_previous(Dll,CandidateSuspensionClusterPointer),
wkl_p_is_suspension_cluster_pointer(Worklist,CandidateSuspensionClusterPointer).
wkl_p_get_rightmost_inner_answer_cluster_pointer(wkl_worklist(_Dll,InnerAnswerClusterPointerFlag,_FlagExecutingWork,_AlreadyInMetaworklist,_TableIdentifier), InnerAnswerClusterPointer) :-
get_atts(InnerAnswerClusterPointerFlag, wkl_answer_cluster_pointer_flag(InnerAnswerClusterPointer)).
% Succeed if there are currently no more continuation clusters on the right of the given position:
% Why 'currently' in the name? Another continuation can be added.
wkl_p_answer_cluster_currently_moved_completely(Worklist,AnswerClusterPointer) :-
( wkl_p_at_right(Worklist,AnswerClusterPointer) ->
true
;
wkl_p_answer_cluster_on_right(Worklist,AnswerClusterPointer)
).
% Succeeds if the given pointer points to the last element in the list. That is, if its next pointer is the dummy element in the double linked list.
wkl_p_at_right(Worklist,Pointer) :-
dll_get_pointer_to_next(Pointer,NextPointer),
wkl_is_dummy_pointer(Worklist,NextPointer).
wkl_p_answer_cluster_on_right(Worklist,Pointer) :-
dll_get_pointer_to_next(Pointer,NextPointer),
wkl_p_is_answer_cluster_pointer(Worklist,NextPointer).
wkl_is_dummy_pointer(Worklist,Pointer) :-
wkl_p_get_double_linked_list(Worklist,Dll),
dll_is_dummy_pointer(Dll,Pointer).
wkl_p_is_answer_cluster_pointer(Worklist,PointerCandidateAnswerCluster) :-
( wkl_is_dummy_pointer(Worklist,PointerCandidateAnswerCluster) ->
% Certainly not an answer cluster, should not dereference this
fail
;
wkl_p_dereference_pointer(Worklist,PointerCandidateAnswerCluster,CandidateAnswerCluster),
wkl_p_is_answer_cluster(CandidateAnswerCluster)
).
wkl_p_is_suspension_cluster_pointer(Worklist,PointerCandidateSuspensionCluster) :-
( wkl_is_dummy_pointer(Worklist,PointerCandidateSuspensionCluster) ->
% Certainly not an answer cluster, should not dereference this
fail
;
wkl_p_dereference_pointer(Worklist,PointerCandidateSuspensionCluster,CandidateSuspensionCluster),
wkl_p_is_suspension_cluster(CandidateSuspensionCluster)
).
wkl_p_get_double_linked_list(Worklist,Dll) :-
arg(1,Worklist,Dll).
% One should not attempt to dereference the dummy pointer in the double linked list.
wkl_p_dereference_pointer(_Worklist,Pointer,Data) :-
dll_get_data(Pointer,Data).
% SETTING POINTERS
%%%%%%%%%%%%%%%%%%
wkl_p_set_rightmost_inner_answer_cluster_pointer(Worklist,AnswerClusterPointer) :-
arg(2, Worklist, AnswerClusterPointerFlag),
put_atts(AnswerClusterPointerFlag, wkl_answer_cluster_pointer_flag(AnswerClusterPointer)).

210
src/lib/tabling/double_linked_list.pl Normal file
View File

@@ -0,0 +1,210 @@
/* Part of SWI-Prolog
Author: Benoit Desouter <Benoit.Desouter@UGent.be>
Jan Wielemaker (SWI-Prolog port)
Copyright (c) 2016, Benoit Desouter
All rights reserved.
Ported to Scryer Prolog by Mark Thom (2019/2020).
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(double_linked_list,
[ dll_new_double_linked_list/1, % -List
dll_append_right/2, % !List, +Element
dll_append_left/2, % !List, +Element
dll_append_right/3, % !List, +Element, -Pointer
dll_append_left/3, % !List, +Element, -Pointer
dll_get_data/2, % +List, -Head
dll_get_pointer_to_next/2, % +List, -Pointer
dll_get_pointer_to_previous/2, % +List, -Pointer
dll_is_dummy_pointer/2, % +List, +Pointer
dll_p_swap_adjacent_elements_/2, % +Pointer1, +Pointer2
dll_get_contents/2,
dll_get_reverse_contents/2
]).
:- use_module(library(atts)).
:- attribute dll_element/1, dll_next/1, dll_prev/1.
% A circular double linked list
% =============================
% Always have a unused-cell at the beginning.
% I do not always inline unifications because the head is then more readable for users who don't need to know the details.
% Due to lack of modules in hProlog, the following predicate names should not be used elsewhere:
% - the heads of all following rules (starting with dll_, I reserve "the namespace"!)
% dll_cell(Element,Next,Previous)
% The following is perhaps odd:
%
% Next link = more to the front (the left)
% Previous link = more to the back (the right)
%
% List structure
% --------------
% front-of-the-list | ... | back-of-the-list
dll_new_double_linked_list(List) :-
% Nonused cell dll_start at the beginning, points to itself (this is easy when adding elements).
List = dll_cell(Start),
put_atts(Start, [dll_next(List), dll_prev(List), dll_element(dll_start)]).
dll_append_right(List, Element) :-
dll_append_right(List, Element, _).
dll_append_left(List, Element) :-
dll_append_left(List, Element, _).
% Append at the back of the list
% Mode: + + -
dll_append_right(List, Element, Pointer) :-
% Get pointer to cell currently at the back. Done by taking the previous element from the unused element representing the list.
dll_get_pointer_to_previous(List, OldBack),
% Make the new cell point to OldBack as predecessor
% Make the new cell point to the unused cell as successor.
Pointer = dll_cell(NewCell),
put_atts(NewCell, [dll_element(Element), dll_next(List), dll_prev(OldBack)]),
% Make OldBack point to the new cell as successor
dll_p_set_next_pointer(OldBack, Pointer),
% Make the unused cell point to the new cell as predecessor
dll_p_set_previous_pointer(List, Pointer).
% Add to the front of the list
% Mode: + + -
dll_append_left(List, Element, Pointer) :-
% Get pointer to cell currently at the front. Done by taking the next element from the unused element representing the list.
dll_get_pointer_to_next(List, OldFront),
% Make the new cell point to OldFront as successor
% Make the new cell point to the unused cell as predecessor
Pointer = dll_cell(NewCell),
put_atts(NewCell, [dll_element(Element), dll_prev(List), dll_next(OldFront)]),
% Make OldFront point to the new cell as predecessor
dll_p_set_previous_pointer(OldFront, Pointer),
% Make the unused cell point to the new cell as successor
dll_p_set_next_pointer(List, Pointer).
% get_next_cell?
dll_get_pointer_to_next(dll_cell(Cell), PointerNext) :-
get_atts(Cell, dll_next(PointerNext)).
% get_previous_cell?
dll_get_pointer_to_previous(dll_cell(Cell), PointerPrevious) :-
get_atts(Cell, dll_prev(PointerPrevious)).
% Will happily give you the "data" from the unused cell at the beginning. (We use this odd behaviour below, f.e. in dll_p_foreach_element_/2.)
dll_get_data(dll_cell(Cell), Element) :-
get_atts(Cell, dll_element(Element)).
dll_is_dummy_pointer(List, Pointer) :-
dll_get_contents(List, ListContents),
dll_get_contents(Pointer, PointerContents),
\+ PointerContents \= ListContents.
% Special case of swapping - used in dll_swap/2.
% This is also the case used for swapping a freshly created list with itself.
%
% Sketch: APrevious <-> PointerA <-> PointerB <-> BNext etc.
dll_p_swap_adjacent_elements(PointerA, PointerB) :-
% Order B A?
( dll_get_pointer_to_next(PointerB, PointerA) ->
dll_p_swap_adjacent_elements_(PointerB, PointerA)
;
% Order A B!
dll_p_swap_adjacent_elements_(PointerA, PointerB)
).
% Assumes the order A B.
dll_p_swap_adjacent_elements_(PointerA, PointerB) :-
% Get A's previous and B's next
dll_get_pointer_to_previous(PointerA, PointerAPrevious),
dll_get_pointer_to_next(PointerB, PointerBNext),
% Set A's previous to B
dll_p_set_previous_pointer(PointerA, PointerB),
% Set B's next to A
dll_p_set_next_pointer(PointerB, PointerA),
% Set A's next to BNext
dll_p_set_next_pointer(PointerA, PointerBNext),
% Set B's previous to APrevious
dll_p_set_previous_pointer(PointerB, PointerAPrevious),
% Set APrevious' next to B !!
dll_p_set_next_pointer(PointerAPrevious, PointerB),
% Set BNext's previous to A !!
dll_p_set_previous_pointer(PointerBNext, PointerA).
% Private
% Careful: make sure this is called on the actual cell, and not some copy.
% Mode: + +
dll_p_set_previous_pointer(dll_cell(Cell), PointerToNewPrevious) :-
put_atts(Cell, dll_prev(PointerToNewPrevious)).
% Private
% Careful: make sure this is called on the actual cell, and not some copy.
% Mode: + +
dll_p_set_next_pointer(dll_cell(Cell), PointerToNewNext) :-
put_atts(Cell, dll_next(PointerToNewNext)).
dll_extract_element(ElementFlag, Element) :-
( ElementFlag = wkl_suspension_cluster(SuspensionClusterFlag) ->
get_atts(SuspensionClusterFlag, batched_worklist, wkl_suspension_cluster(SuspensionCluster)),
Element = wkl_suspension_cluster(SuspensionCluster)
; ElementFlag = wkl_answer_cluster(AnswerClusterFlag) ->
get_atts(AnswerClusterFlag, batched_worklist, wkl_answer_cluster(AnswerCluster)),
Element = wkl_answer_cluster(AnswerCluster)
).
dll_get_contents(List, Contents) :-
dll_get_pointer_to_next(List, Next),
dll_get_contents_(Next, Contents).
dll_get_contents_(List, Contents) :-
dll_get_data(List, ElementFlag),
( ElementFlag == dll_start ->
Contents = []
; dll_extract_element(ElementFlag, Element),
Contents = [Element | Rest],
dll_get_pointer_to_next(List, Next),
dll_get_contents_(Next, Rest)
).
dll_get_reverse_contents(List, Contents) :-
dll_get_pointer_to_previous(List, Prev),
dll_get_reverse_contents_(Prev, Contents).
dll_get_reverse_contents_(List, Contents) :-
dll_get_data(List, ElementFlag),
( ElementFlag == dll_start ->
Contents = []
; dll_extract_element(ElementFlag, Element),
Contents = [Element | Rest],
dll_get_pointer_to_previous(List, Prev),
dll_get_reverse_contents_(Prev, Rest)
).

40
src/lib/tabling/global_worklist.pl Normal file
View File

@@ -0,0 +1,40 @@
/* Ported to Scryer Prolog by Mark Thom (2019/2020).
*/
:- module(global_worklist,
[ put_new_global_worklist/0,
add_to_global_worklist/1,
worklist_empty/0,
pop_worklist/1
]).
:- use_module(library(atts)).
:- use_module(library(iso_ext)).
:- attribute table_global_worklist/1.
put_new_global_worklist :-
( bb_get(table_global_worklist_initialized, _) ->
true
; put_atts(Worklist, table_global_worklist([])),
bb_put(table_global_worklist, Worklist),
bb_b_put(table_global_worklist_initialized, [])
).
add_to_global_worklist(TableIdentifier) :-
bb_get(table_global_worklist, TableGlobalWorklistFlag),
get_atts(TableGlobalWorklistFlag, table_global_worklist(L1)),
put_atts(TableGlobalWorklistFlag, table_global_worklist([TableIdentifier|L1])),
bb_put(table_global_worklist, TableGlobalWorklistFlag).
worklist_empty :-
bb_get(table_global_worklist,TableGlobalWorklistFlag),
get_atts(TableGlobalWorklistFlag, table_global_worklist(L)),
L == [].
pop_worklist(TableIdentifier) :-
bb_get(table_global_worklist,TableGlobalWorklistFlag),
get_atts(TableGlobalWorklistFlag, table_global_worklist(L1)),
L1 = [TableIdentifier|L2],
put_atts(TableGlobalWorklistFlag, table_global_worklist(L2)),
bb_put(table_global_worklist, TableGlobalWorklistFlag).

253
src/lib/tabling/table_data_structure.pl Normal file
View File

@@ -0,0 +1,253 @@
:- module(table_datastructure,
[ get_answer/2, % +TableID, -Answer
add_answer/2, % +TableID, +Answer
get_call_variant/2, % +TableID, -CallVariant
set_complete_status/1, % +TableID
set_active_status/1, % +TableID
tbd_table_status/2, % +TableID, -Status
table_for_variant/2, % +Variant, -TableID
store_dependency/2, % +TableID, +Suspension
cleanup_after_complete/1, % +TableID
get_newly_created_table_identifiers/2, % NewlyCreatedTableIDs, NumIDs
reset_newly_created_table_identifiers/0,
answers_for_variant/2, % +Variant, -Answers
put_new_table_identifiers/0,
get_nb_identifiers/3 % +Table, -NbWorklistID, -NbAnswerTreeID
]).
:- use_module(table_link_manager).
:- use_module(trie).
/* Part of SWI-Prolog
Author: Benoit Desouter <Benoit.Desouter@UGent.be>
Jan Wielemaker (SWI-Prolog port)
Copyright (c) 2016, Benoit Desouter
All rights reserved.
Ported to Scryer Prolog by Mark Thom (2019/2020).
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- use_module(batched_worklist).
:- use_module(library(atts)).
:- use_module(library(gensym)).
:- use_module(library(iso_ext)).
:- attribute table_status/1, newly_created_table_identifiers/1.
% This file defines the table datastructure.
%
% The table datastructure contains the following sub-structures:
% - the answer trie
% - the worklist
%
% Structure for tables:
% table(CallVariant,Status,AnswerTrie,Worklist) or complete_table(CallVariant,AnswerTrie).
% where AnswerTrie contains a trie of unique answers
%
% Remember that a table may also be nonexistent!
% nb_getval(nonexistent,X) then gives [].
put_new_table_identifiers :-
( bb_get(newly_created_table_identifiers_initialized, _) ->
true
; put_atts(NewlyCreatedFlag, newly_created_table_identifiers([]-0)),
bb_b_put(newly_created_table_identifiers, NewlyCreatedFlag),
bb_b_put(newly_created_table_identifiers_initialized, [])
).
% Returns a list of newly created table identifiers since the last call to reset_newly_created_table_identifiers/0, as well as the length of the list.
get_newly_created_table_identifiers(NewlyCreatedTableIdentifiers,NumIdentifiers) :-
bb_get(newly_created_table_identifiers, NewlyCreatedFlag),
get_atts(NewlyCreatedFlag, newly_created_table_identifiers(NewlyCreatedTableIdentifiers-NumIdentifiers)).
reset_newly_created_table_identifiers :-
bb_get(newly_created_table_identifiers, NewlyCreatedFlag),
put_atts(NewlyCreatedFlag, newly_created_table_identifiers([]-0)).
add_to_newly_created_table_identifiers(TableIdentifier) :-
bb_get(newly_created_table_identifiers, NewlyCreatedFlag),
get_atts(NewlyCreatedFlag, newly_created_table_identifiers(L1-Num1)),
Num2 is Num1 + 1,
put_atts(NewlyCreatedFlag, newly_created_table_identifiers([TableIdentifier|L1]-Num2)).
% PRIVATE
% Mode: + -
%
% Created in the fresh status.
p_create_table(CallVariant,TableIdentifier) :-
% We use a copy_term here so that we can be sure not to corrupt our table if CallVariant is "changed" afterwards.
copy_term(CallVariant,CallVariant2),
% Generate a table identifier, create the table and do bookkeeping.
gensym(table,TableIdentifier),
% Create a trie and a worklist.
trie_new(EmptyTrie),
wkl_new_worklist(TableIdentifier,NewWorklist),
put_atts(StatusFlag, table_status(fresh)),
%% this is important! we don't want to copy the incomplete table every time we refer to it,
%% which would occur if we used bb_put here.
%% note that the complete_table variant is written to the blackboard using bb_get.
atom_concat(TableIdentifier, nb_worklist, NbWorklistID),
atom_concat(TableIdentifier, nb_answer_trie, NbAnswerTrieID),
bb_put(TableIdentifier, table(CallVariant2,StatusFlag,NbWorklistID,NbAnswerTrieID)),
bb_put(NbWorklistID, table_nb_worklist(NewWorklist)),
bb_put(NbAnswerTrieID, table_nb_answer_trie(EmptyTrie)),
p_link_variant_identifier(CallVariant2,TableIdentifier),
add_to_newly_created_table_identifiers(TableIdentifier).
% Get the Status for table TableIdentifier
% Throws exception if this table does not exist.
tbd_table_status(TableIdentifier,Status) :-
p_get_table_for_identifier(TableIdentifier,Table),
tbd_table_status_(Table,Status).
% Is also used in other predicates than tbd_table_status.
tbd_table_status_(table(_CallVariant,StatusFlag,_NbWorklistID, _NbAnswerTrieID),Status) :-
get_atts(StatusFlag, table_status(Status)).
tbd_table_status_(complete_table(_,_,_),complete).
% PRIVATE
% Table must already exist.
p_get_table_for_identifier(TableIdentifier,Table) :-
bb_get(TableIdentifier,Table).
% Get the table identifier (!!) for call variant V, creating a new one if necessary.
%
% More costly than directly passing the table identifier for already existing tables.
%
% Since this creates a new table, this predicate is NOT meant for users who should get access to existing tables - f.e. benchmark shortest_path.P
%
table_for_variant(V,TableIdentifier) :-
( p_existing_table(V,TableIdentifier) ->
true
;
p_create_table(V,TableIdentifier)
).
% Get call variant for this table
get_call_variant(TableIdentifier,CallVariant) :-
p_get_table_for_identifier(TableIdentifier,Table),
get_call_variant_(Table,CallVariant).
get_call_variant_(table(CallVariant,_Status,_NbWorklistID,_NbAnswerTrieID),CallVariant).
get_call_variant_(complete_table(CallVariant,_NbWorklistID,_NbAnswerTrieID),CallVariant).
add_answer(TableIdentifier,A) :-
p_get_table_for_identifier(TableIdentifier,Table),
% arg(1,Table,CallVariant),
arg(3,Table,NbWorklistID),
arg(4,Table,NbAnswerTrieID),
bb_get(NbWorklistID,table_nb_worklist(Worklist)),
bb_get(NbAnswerTrieID,table_nb_answer_trie(AnswerTrie)),
copy_term(A,A2),
% This predicate succeeds if the answer was new, otherwise it fails.
trie_insert(AnswerTrie,A2,A2), % Use answer both as key and as value. Having it as value uses memory, but greatly simplifies getting all the answers.
% We got here, so trie_insert added a new answer.
% We must also insert this answer in the worklist
wkl_add_answer(Worklist,A2),
bb_put(NbWorklistID, table_nb_worklist(Worklist)),
bb_put(NbAnswerTrieID, table_nb_answer_trie(AnswerTrie)).
get_answer(TableIdentifier,A) :-
p_get_table_for_identifier(TableIdentifier,Table),
get_answer_trie_(Table,AnswerTrie),
% The trick is that we have stored the answers as values of the trie and that there is a method to get all the values.
trie_get_all_values(AnswerTrie,A).
% get_answer_trie_(TableOrCompleteTable,AnswerTrie).
% First argument is not a TableIdentifier.
get_answer_trie_(table(_CallVariant,_Status,_NbWorklistID, NbAnswerTrieID),AnswerTrie) :-
bb_get(NbAnswerTrieID, table_nb_answer_trie(AnswerTrie)).
get_answer_trie_(complete_table(_CallVariant,_NbWorklistID, NbAnswerTrieID),AnswerTrie) :-
bb_get(NbAnswerTrieID, table_nb_answer_trie(AnswerTrie)).
get_nb_identifiers(table(_CallVariant, _Status, NbWorklistID, NbAnswerTrieID), NbWorklistID, NbAnswerTrieID).
get_nb_identifiers(complete_table(_CallVariant, NbWorklistID, NbAnswerTrieID), NbWorklistID, NbAnswerTrieID).
% Get a list of answers for the given call variant.
% Used in compare_expected_for_variant/3 in testlib.pl
% IMPORTANT: table must be filled already, this is not done in this predicate! Therefore can be called during execution.
% V = variant
% LA = list of answers.
%
% More costly operation than directly giving the table identifier.
answers_for_variant(V,LA) :-
table_for_variant(V,TableIdentifier),
p_get_table_for_identifier(TableIdentifier,Table),
get_answer_trie_(Table,AnswerTrie),
findall(Value,trie_get_all_values(AnswerTrie,Value),LA).
% Set status of table TableIdentifier to active
set_active_status(TableIdentifier) :-
tbd_status_transition(TableIdentifier,active,fresh,'set_active_status').
cleanup_after_complete(TableIdentifier) :-
p_get_table_for_identifier(TableIdentifier,Table),
cleanup_after_complete_(Table,TableIdentifier).
% Clause for a (noncomplete) table.
cleanup_after_complete_(
table(CallVariant,_ActualOldStatus, NbWorklistID, NbAnswerTrieID),
TableIdentifier
) :-
bb_put(TableIdentifier,complete_table(CallVariant, NbWorklistID, NbAnswerTrieID)).
% If necessary for debugging add second clause for complete_table.
% Set status of table TableIdentifier to complete.
set_complete_status(TableIdentifier) :-
% The transition must be active to complete, otherwise we have an invalid status transition.
% Preexisting tables should have been cleaned-up, thus not have the form table/5 anymore, thus complete -> complete is not possible there.
p_get_table_for_identifier(TableIdentifier,Table),
set_complete_status_(Table,TableIdentifier).
% set_complete_status_(Table,TableIdentifier).
set_complete_status_(table(_CallVariant,_OldStatus,_NbWorklistID, _NbAnswerTrieID),TableIdentifier) :-
tbd_status_transition(TableIdentifier,complete,active,'set_complete_status').
tbd_status_transition_no_check(TableIdentifier,NewStatus) :-
p_get_table_for_identifier(TableIdentifier,Table),
tbd_status_transition_no_check_(TableIdentifier,Table,NewStatus).
tbd_status_transition_no_check_(TableIdentifier,Table,NewStatus) :-
Table = table(_,StatusFlag,_,_),
put_atts(StatusFlag, table_status(NewStatus)),
bb_put(TableIdentifier, Table).
% Set Table's status to NewStatus if current status is RequiredOldStatus, otherwise throw an exception mentioning CallerAsString: attempt to set NewStatus for table TableIdentifier, but current status was ActualOldStatus instead of RequiredOldStatus
tbd_status_transition(TableIdentifier,NewStatus,_RequiredOldStatus,_CallerAsString) :-
p_get_table_for_identifier(TableIdentifier,Table),
tbd_status_transition_no_check_(TableIdentifier,Table,NewStatus).
store_dependency(TableIdentifier,Suspension) :-
p_get_table_for_identifier(TableIdentifier, Table),
get_nb_identifiers(Table, NbWorklistID, _NbAnswerTrieID),
copy_term(Suspension, SuspensionCopy),
bb_get(NbWorklistID, table_nb_worklist(Worklist)),
wkl_add_suspension(Worklist, SuspensionCopy),
bb_put(NbWorklistID, table_nb_worklist(Worklist)).

123
src/lib/tabling/table_link_manager.pl Normal file
View File

@@ -0,0 +1,123 @@
/* Part of SWI-Prolog
Author: Benoit Desouter <Benoit.Desouter@UGent.be>
Jan Wielemaker (SWI-Prolog port)
Copyright (c) 2016, Benoit Desouter
All rights reserved.
Ported to Scryer Prolog by Mark Thom (2019/2020).
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(table_link_manager,
[ get_existing_tables/1, % -Tables
p_existing_table/2, % +Variant, -TableID
p_link_variant_identifier/2, % +Variant, -TableID
num_tables/1, % -Count
get_trie_table_link/1, % -Trie
put_new_trie_table_link/0
]).
:- use_module(library(atts)).
:- use_module(library(lists)).
:- use_module(library(iso_ext)).
:- use_module(library(terms)).
:- use_module(trie).
:- attribute trie_table_link/1.
% This file defines a call pattern trie.
%
% This data structure keeps the relation between a variant and the
% corresponding table identifier using a trie. The trick is to make a
% canonical representation of a given variant using the numbervars/3
% predicate. The trie uses this canonical representation as key, and
% the table identifier as value.
% Uses the (private) global variable trie_table_link
% This predicate should be called exactly once.
% It throws an exception if it is called more than once.
%% table_link_manager_initialize
%
% Initializes the global variables `trie_table_link`. Normally
% called from table_datastructure_initialize/0.
put_new_trie_table_link :-
( bb_get(trie_table_link_initialized, _) ->
true
; trie_new(Trie),
put_atts(TrieFlag, trie_table_link(Trie)),
bb_put(trie_table_link, TrieFlag),
bb_put(trie_table_link_initialized, [])
).
get_trie_table_link(Trie) :-
bb_get(trie_table_link, TrieFlag),
get_atts(TrieFlag, trie_table_link(Trie)).
% PRIVATE
% mode: + -
% Variant is not modified
variant_canonical_representation(Variant, CanonicalRepresentation) :-
copy_term(Variant, CanonicalRepresentation),
numbervars(CanonicalRepresentation, 0 ,_).
% Succeeds if there is a table TableIdentifier in existance for the
% given call variant Variant.
p_existing_table(Variant, TableIdentifier) :-
get_trie_table_link(Trie),
variant_canonical_representation(Variant, CanonicalRepresentation),
trie_lookup(Trie, CanonicalRepresentation, TableIdentifier).
% Important remark: we cannot use an out-of-the-box association list,
% because we need a lookup based on variant checking, which is not
% available for such lists. Converting the association list to a
% regular list => why would you use an association list in the first
% place...
p_link_variant_identifier(Variant, TableIdentifier) :-
get_trie_table_link(Trie),
variant_canonical_representation(Variant, CanonicalRepresentation),
trie_insert_succeed(Trie, CanonicalRepresentation, TableIdentifier),
put_atts(TrieFlag, trie_table_link(Trie)),
bb_put(trie_table_link, TrieFlag).
% Returns a list of existing table identifiers.
% Rather costly.
get_existing_tables(Ts) :-
get_trie_table_link(Trie),
findall(T, trie_get_all_values(Trie, T), Ts).
% A very unefficient way of implementing this predicate. But it is
% only used for unit testing, so it doesn't really matter. Also, it
% doesn't require any additional bookkeeping during the actual
% execution.
num_tables(N) :-
get_existing_tables(Ts),
length(Ts, N).

225
src/lib/tabling/trie.pl Normal file
View File

@@ -0,0 +1,225 @@
/* Part of SWI-Prolog
Author: Benoit Desouter <Benoit.Desouter@UGent.be>
Jan Wielemaker (SWI-Prolog port)
Copyright (c) 2016, Benoit Desouter
All rights reserved.
Ported to Scryer Prolog by Mark Thom (2019/2020).
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(trie,
[ trie_new/1, % -Trie
trie_insert/3, % !Trie, +Key, +Value
trie_insert_succeed/3,
trie_lookup/3, % +Trie, +Key, -Value
trie_get_all_values/2 % +Trie, -Value
]).
:- use_module(library(assoc)).
:- use_module(library(atts)).
:- use_module(library(lists)).
:- attribute maybe_just/1, children/1.
% Implementation of a prefix tree, a.k.a. trie %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Desired complexity for lookup and insert: linear in the length of the key.
% ATTENTION: do not use the term functor_data/2; this is used internally here.
% Inspiration from http://en.wikipedia.org/wiki/Trie
% Structure of tries:
% trie_inner_node(MaybeValue,Children).
% where Children is an association list of nonvars to tries.
% and where MaybeValue is maybe_none/0 or maybe_just(Value).
% PRIVATE
% For a term of the form p(a,q(b)), "returns" functor_data(p,2) and [a,q(b)].
% p_trie_arity_univ(+Term,-FunctorData,-ArgumentsList).
p_trie_arity_univ(Term,functor_data(Name,Arity),Arguments) :-
( var(Term) ->
Name = var,
Arity = 0,
Arguments = []
; Term =.. [Name|Arguments],
functor(Term,_,Arity)
).
% Returns a new empty trie.
trie_new(Trie) :-
empty_assoc(Assoc),
put_atts(A, children(Assoc)),
Trie = trie_inner_node(_,A).
% Succeeds if given trie does not contain any key-value pair.
% trie_is_empty(+Trie)
trie_is_empty(trie_inner_node(X,A)) :-
get_atts(X, -maybe_just(_)),
get_atts(A, children(Assoc)),
empty_assoc(Assoc).
% For internal use.
% For now, Children is an association list that can be manipulated using the assoc_ predicates.
trie_get_children(trie_inner_node(_,ChildNode),Children) :-
get_atts(ChildNode, children(Children)).
% For internal use.
trie_get_maybe_value(trie_inner_node(MaybeNode,_),MaybeValue) :-
get_atts(MaybeNode, maybe_just(MaybeValue)).
% Destructive update of the association list Children.
% For internal use.
trie_set_children(trie_inner_node(_,ChildNode),Children) :-
put_atts(ChildNode, children(Children)).
trie_set_maybe_value(trie_inner_node(MaybeNode, _),MaybeValue) :-
put_atts(MaybeNode, MaybeValue).
trie_insert_succeed(Trie,Key,Value) :-
( trie_insert(Trie,Key,Value) ->
true
;
true
).
% Succeeds if the term was not present, fails if the term was present.
% The term will be present now, whatever the outcome.
% We don't use an extra argument to indicate earlier presence, as this increases the trail size.
trie_insert(Trie,Key,Value) :-
p_trie_arity_univ(Key,FunctorData,KeyList),
trie_insert_1(KeyList,FunctorData,Trie,Value).
trie_insert_1([],FunctorData,Trie,Value) :-
trie_get_children(Trie,Assoc),
% You need Assoc twice: once to traverse through it, once keeping it as a whole for insertion using put_assoc/4.
trie_insert_a(Assoc,Assoc,FunctorData,Trie,Value).
% Inline the failure and success continuation to avoid a growing trail stack.
trie_insert_1([First|Rest],FunctorData,Trie,Value) :-
trie_get_children(Trie,Assoc),
% You need Assoc twice: once to traverse through it, once keeping it as a whole for insertion using put_assoc/4.
trie_insert_1_1(Assoc,Assoc,FunctorData,Trie,First,Rest,Value).
% Else part, base case: empty assoc list.
trie_insert_a(t,Assoc,FunctorData,Trie,Value) :-
trie_new(Subtrie),
trie_set_maybe_value(Subtrie,maybe_just(Value)),
put_assoc(FunctorData,Assoc,Subtrie,NewAssoc),
trie_set_children(Trie,NewAssoc).
% Then part, nonempty assoc tree.
trie_insert_a(t(K,V,_,L,R),Assoc,FunctorData,Trie,Value) :-
compare(Rel,FunctorData,K),
trie_insert_b(Rel,V,L,R,Assoc,FunctorData,Trie,Value).
% Recursively look in the left part of the assoc tree.
trie_insert_b(<,_V,L,_R,Assoc,FunctorData,Trie,Value) :-
trie_insert_a(L,Assoc,FunctorData,Trie,Value).
% Recursively look in the right part of the assoc tree.
trie_insert_b(>,_V,_L,R,Assoc,FunctorData,Trie,Value) :-
trie_insert_a(R,Assoc,FunctorData,Trie,Value).
trie_insert_b(=,V,_L,_R,_Assoc,_FunctorData,_Trie,Value) :-
trie_get_maybe_value(V,MaybeValue), % V is the Subtrie
( MaybeValue == maybe_none ->
trie_set_maybe_value(V,maybe_just(Value))
% Use true to indicate that the answer was new.
;
MaybeValue = maybe_just(JustValue),
( JustValue == Value ->
% Fail to indicate earlier presence
fail
;
throw('trie: attempt to update the value for a key')
)
).
% Else part, base case: empty assoc list
trie_insert_1_1(t,Assoc,FunctorData,Trie,First,Rest,Value) :-
% Assoc = t, % t is the empty assoc tree
trie_new(Subtrie),
put_assoc(FunctorData,Assoc,Subtrie,NewAssoc),
trie_set_children(Trie,NewAssoc),
trie_insert_2(First,Rest,Subtrie,Value).
% Then part, lookup in assoc list.
trie_insert_1_1(t(K,V,_,L,R),Assoc,FunctorData,Trie,First,Rest,Value) :-
compare(Rel,FunctorData,K),
trie_insert_1_1_1(Rel,V,L,R,Assoc,FunctorData,Trie,First,Rest,Value).
trie_insert_1_1_1(=,V,_L,_R,_Assoc,_FunctorData,_Trie,First,Rest,Value) :-
trie_insert_2(First,Rest,V,Value). % V is the Subtrie
trie_insert_1_1_1(<,_V,L,_R,Assoc,FunctorData,Trie,First,Rest,Value) :-
% Look in the left part of the assoc tree.
trie_insert_1_1(L,Assoc,FunctorData,Trie,First,Rest,Value).
trie_insert_1_1_1(>,_V,_L,R,Assoc,FunctorData,Trie,First,Rest,Value) :-
% Look in the right part of the assoc tree.
trie_insert_1_1(R,Assoc,FunctorData,Trie,First,Rest,Value).
trie_insert_2(RegularTerm,Rest,Trie,Value) :-
p_trie_arity_univ(RegularTerm,FunctorData,KList),
append(KList,Rest,KList2),
trie_insert_1(KList2,FunctorData,Trie,Value).
trie_lookup(Trie,Key,Value) :-
p_trie_arity_univ(Key,FunctorData,KeyList),
trie_lookup_1(FunctorData,KeyList,Trie,Value).
trie_lookup_1(FunctorData,Rest,Trie,Value) :-
% Select right subtree, fail if it isn't there, and do recursive call.
trie_get_children(Trie,Assoc),
get_assoc(FunctorData,Assoc,Subtrie), % Fails if not present
trie_lookup_2(Rest,Subtrie,Value).
trie_lookup_2([],Trie,Value) :-
% If the value at this trie is maybe_just(X), then X is our Value.
% Otherwise, there is no value for this key, so we fail...
trie_get_maybe_value(Trie,Value).
% Regular term at the head, like p or p(a). Not functor_data/2.
trie_lookup_2([RegularTerm|Rest],Trie,Value) :-
% split RegularTerm
p_trie_arity_univ(RegularTerm,FunctorData,KList),
% Make a recursive call on KList ++ Rest.
% Since we cannot implement p_trie_arity_univ so that "its result", KList, has a free variable at the end, without resorting to techniques that require linear time, we need a call to append/3. However, since KList will in general be rather short, I don't expect this to be a large problem in practice.
append(KList,Rest,KList2),
trie_lookup_1(FunctorData,KList2,Trie,Value).
% Returns all values in the trie by backtracking - we don't provide any information about the associated key.
trie_get_all_values(Trie,Value) :-
trie_get_maybe_value(Trie,Value).
trie_get_all_values(Trie,Value) :-
trie_get_children(Trie,Children),
gen_assoc(_Key, Children, ChildTrie),
trie_get_all_values(ChildTrie,Value).

118
src/lib/tabling/wrapper.pl Normal file
View File

@@ -0,0 +1,118 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
Copyright (c) 2016, VU University Amsterdam
All rights reserved.
Ported to Scryer Prolog by Mark Thom (2019/2020).
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.
*/
:- module(table_wrapper,
[ %(table)/1, % +Predicates
op(1150, fx, table)
]).
:- use_module(library(dcgs)).
:- use_module(library(error)).
%%:- multifile
%% system:term_expansion/2,
%% tabled/2.
%%:- dynamic
%% system:term_expansion/2.
%% table(+PredicateIndicators)
%
% Prepare the given PredicateIndicators for tabling. Can only
% be used as a directive.
%% table(PIList) :-
%% throw(error(context_error(nodirective, table(PIList)), _)).
instantiation_error(Var) :-
throw(error(instantiation_error(Var), _)).
wrappers(Var) -->
{ var(Var), !,
instantiation_error(Var)
}.
wrappers((A,B)) --> !,
wrappers(A),
wrappers(B).
wrappers(Name//Arity) -->
{ atom(Name), integer(Arity), Arity >= 0, !,
Arity1 is Arity+2
},
wrappers(Name/Arity1).
wrappers(Name/Arity) -->
{ atom(Name), integer(Arity), Arity >= 0, !,
functor(Head, Name, Arity),
atom_concat(Name, ' tabled', WrapName),
Head =.. [Name|Args],
WrappedHead =.. [WrapName|Args],
'$module_of'(Module, Name) %prolog_load_context(module, Module)
},
[ ( Head :-
start_tabling(Module:Head, WrappedHead)
),
(:- multifile(table_wrapper:tabled/2)),
table_wrapper:tabled(Head, Module)
].
rename(M:Term0, M:Term, _) :-
atom(M), !,
rename(Term0, Term, M).
rename((Head :- Body), (NewHead :- Body), Module) :- !,
rename(Head, NewHead, Module).
rename((Head --> Body), (NewHead --> Body), Module) :- !,
functor(Head, Name, Arity),
PlainArity is Arity+1,
functor(PlainHead, Name, PlainArity),
table_wrapper:tabled(PlainHead, Module),
rename_term(Head, NewHead).
rename(Head, NewHead, Module) :-
table_wrapper:tabled(Head, Module), !,
rename_term(Head, NewHead).
rename_term(Compound0, Compound) :-
compound(Compound0), !,
Compound0 =.. [Name|Args],
atom_concat(Name, ' tabled', WrapName),
Compound =.. [WrapName|Args].
rename_term(Name, WrapName) :-
atom_concat(Name, ' tabled', WrapName).
user:term_expansion(Term0, Clauses) :-
nonvar(Term0),
Term0 = (:- table Preds),
phrase(wrappers(Preds), Clauses).
user:term_expansion(Clause, NewClause) :-
nonvar(Clause),
'$module_of'(Module, Clause),
rename(Clause, NewClause, Module).

19
src/lib/terms.pl Normal file
View File

@@ -0,0 +1,19 @@
:- module(terms, [numbervars/3]).
:- use_module(library(error)).
numbervars(Term, N0, N) :-
catch(internal_numbervars(Term, N0, N),
error(E,Ctx),
( ( var(Ctx) -> Ctx = numbervars/3 ; true ), throw(error(E,Ctx) ) ) ).
internal_numbervars(Term, N0, N) :-
must_be(integer, N0),
can_be(integer, N),
term_variables(Term, Vars),
numberlist(Vars, N0, N).
numberlist([], N, N).
numberlist(['$VAR'(N0)|Vars], N0, N) :-
N1 is N0+1,
numberlist(Vars, N1, N).

129
src/lib/time.pl Normal file
View File

@@ -0,0 +1,129 @@
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Written 2020 by Markus Triska (triska@metalevel.at)
Part of Scryer Prolog.
This library provides predicates for reasoning about time.
current_time(T) yields the current system time in an opaque form,
called a time stamp. Use format_time//2 to describe strings that
contain attributes of the time stamp.
The nonterminal format_time//2 describes a list of characters that
are formatted according to a format string. Usage:
phrase(format_time(FormatString, TimeStamp), Cs)
TimeStamp represents a moment in time in an opaque form, as for
example obtained by current_time/1.
FormatString is a list of characters that are interpreted literally,
except for the following specifiers (and possibly more in the future):
%Y year of the time stamp. Example: 2020.
%m month number (01-12), zero-padded to 2 digits
%d day number (01-31), zero-padded to 2 digits
%H hour number (00-24), zero-padded to 2 digits
%M minute number (00-59), zero-padded to 2 digits
%S second number (00-60), zero-padded to 2 digits
%b abbreviated month name, always 3 letters
%a abbreviated weekday name, always 3 letters
%A full weekday name
%j day of the year (001-366), zero-padded to 3 digits
%% the literal %
Example:
?- current_time(T), phrase(format_time("%d.%m.%Y (%H:%M:%S)", T), Cs).
T = [...], Cs = "11.06.2020 (00:24:32)"
; false.
sleep(S) sleeps for S seconds (a floating point number).
time(Goal) reports the execution time of Goal.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
:- module(time, [max_sleep_time/1, sleep/1, time/1, current_time/1, format_time//2]).
:- use_module(library(format)).
:- use_module(library(iso_ext)).
:- use_module(library(error)).
:- use_module(library(dcgs)).
:- use_module(library(lists)).
:- use_module(library(charsio), [read_term_from_chars/2]).
current_time(T) :-
'$current_time'(T0),
read_term_from_chars(T0, T).
format_time([], _) --> [].
format_time(['%','%'|Fs], T) --> !, "%", format_time(Fs, T).
format_time(['%',Spec|Fs], T) --> !,
( { member(Spec=Value, T) } ->
list(Value)
; { domain_error(time_specifier, Spec, format_time//2) }
),
format_time(Fs, T).
format_time([F|Fs], T) --> [F], format_time(Fs, T).
list([]) --> [].
list([L|Ls]) --> [L], list(Ls).
max_sleep_time(0xfffffffffffffbff).
sleep(T) :-
builtins:must_be_number(T, sleep),
( T < 0 ->
domain_error(not_less_than_zero, T, sleep/1)
; max_sleep_time(N), T > N ->
throw(error(representation_error(max_sleep_time), sleep/1))
; '$sleep'(T)
).
% '$cpu_now' can be replaced by statistics/2 once that is implemented.
time(Goal) :-
'$cpu_now'(T0),
setup_call_cleanup(true,
( Goal,
report_time(T0)
),
report_time(T0)).
report_time(T0) :-
'$cpu_now'(T),
Time is T - T0,
( bb_get('$first_answer', true) ->
format(" % CPU time: ~3f seconds~n", [Time])
; format("% CPU time: ~3f seconds~n ", [Time])
).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
?- time((true;false)).
% CPU time: 0.000 seconds
true
; % CPU time: 0.001 seconds
false.
:- time(use_module(library(clpz))).
% CPU time: 2.762 seconds
true
; false.
:- time(use_module(library(lists))).
% CPU time: 0.000 seconds
true
; % CPU time: 0.001 seconds
false.
?- time(member(X, [a,b,c])).
% CPU time: 0.000 seconds
X = a
; % CPU time: 0.002 seconds
X = b
; % CPU time: 0.004 seconds
X = c
; % CPU time: 0.007 seconds
false.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */