ref: 13efe91101a11f41caf6321a8b2fbdd96ef9927a
dir: pprolog/system.pl
:-(module(system, [])).
% Insert the standard operators
:-(op(1200, fx, :-)).
:- op(1200, fx, ?-).
:- op(1200, xfx, :-).
:- op(1200, xfx, -->).
:- op(1100, xfy, ;).
:- op(1050, xfy, ->).
:- op(1000, xfy, ',').
:- op(900, fy, \+).
:- op(700, xfx, =).
:- op(700, xfx, \=).
:- op(700, xfx, ==).
:- op(700, xfx, \==).
:- op(700, xfx, @<).
:- op(700, xfx, @=<).
:- op(700, xfx, @>).
:- op(700, xfx, @>=).
:- op(700, xfx, =..).
:- op(700, xfx, is).
:- op(700, xfx, =:=).
:- op(700, xfx, =\=).
:- op(700, xfx, <).
:- op(700, xfx, =<).
:- op(700, xfx, >).
:- op(700, xfx, >=).
:- op(600, xfy, :).
:- op(500, yfx, +).
:- op(500, yfx, -).
:- op(500, yfx, /\).
:- op(500, yfx, \/).
:- op(400, yfx, *).
:- op(400, yfx, /).
:- op(400, yfx, //).
:- op(400, yfx, rem).
:- op(400, yfx, mod).
:- op(400, yfx, <<).
:- op(400, yfx, >>).
:- op(200, xfx, **).
:- op(200, xfy, ^).
:- op(200, fy, -).
:- op(200, fy, \).
% Logic and control predicates
\+ Goal :- call(Goal), !, fail.
\+ _.
once(Goal) :-
call(Goal),
!.
repeat :- true ; repeat.
% Control structures.
If -> Then :-
If, !, Then.
If -> Then ; _ :-
If, !, Then.
_ -> _ ; Else :-
!, Else.
If ; _ :-
If.
_ ; Else :-
Else.
% Term unification
A = A.
A \= B :-
\+ A = B.
% Comparison of terms using the standard order
A == B :-
compare(=, A, B).
A \== B :-
\+ A == B.
A @< B :-
compare(<, A, B).
A @=< B :-
A == B.
A @=< B :-
A @< B.
A @> B :-
compare(>, A, B).
A @>= B :-
A == B.
A @>= B :-
A @> B.
% Input output
open(SourceSink, Mode, Stream) :-
open(SourceSink, Mode, Stream, []).
close(StreamOrAlias) :-
close(StreamOrAlias, []).
flush_output :-
current_output(S),
flush_output(S).
stream_property(S, P) :-
stream_properties(Props),
member(prop(S,P), Props).
at_end_of_stream :-
current_input(S),
stream_property(S, end_of_stream(E)),
!,
(E = at ; E = past),
!.
at_end_of_stream(S_or_a) :-
( atom(S_or_a)
-> stream_property(S, alias(S_or_a))
; S = S_or_a
),
stream_property(S, end_of_stream(E)),
!,
(E = at; E = past),
!.
% Standard exceptions
instantiation_error :-
throw(error(instantiation_error, _)).
type_error(ValidType, Culprit) :-
throw(error(type_error(ValidType, Culprit), _)).
domain_error(ValidDomain, Culprit) :-
throw(error(domain_error(ValidDomain, Culprit), _)).
existence_error(ObjectType, Culprit) :-
throw(error(existence_error(ObjectType, Culprit), _)).
permission_error(Operation, PermissionType, Culprit) :-
throw(error(permission_error(Operation, PermissionType, Culprit), _)).
representation_error(Flag) :-
throw(error(representation_error(Flag), _)).
evaluation_error(Error) :-
throw(error(evaluation_error(Error), _)).
resource_error(Resource) :-
throw(error(resource_error(Resource), _)).
syntax_error(Error) :-
throw(error(syntax_error(Error), _)).
% Input and output
parse_read_option(variables(Vs), options(variables, Vs)).
parse_read_option(variable_names(VNames), option(variable_names, VNames)).
parse_read_option(singletons(S), options(singletons, S)).
parse_read_options([], []).
parse_read_options([Op|Rest], [OpParsed|RestParsed]) :-
is_nonvar(Op),
parse_read_options(Rest, RestParsed),
( parse_read_option(Op, OpParsed)
-> true
; domain_error(read_option, Op)
).
read_term(S, Term, Options) :-
is_nonvar(Options),
is_list(Options),
parse_read_options(Options, ParsedOptions),
'$read_term'(S, Term, ParsedOptions).
read_term(Term, Options) :-
current_input(S),
read_term(S, Term, Options).
read(Term) :-
current_input(S),
read_term(S, Term, []).
read(S, Term) :-
read_term(S, Term, []).
parse_write_option(quoted(true), option(quoted, 1)).
parse_write_option(quoted(false), option(quoted, 0)).
parse_write_option(ignore_ops(true), option(ignore_ops, 1)).
parse_write_option(ignore_ops(false), option(ignore_ops, 0)).
parse_write_option(numbervars(true), option(numbervars, 1)).
parse_write_option(numbervars(false), option(numbervars, 0)).
parse_write_options([], []).
parse_write_options([Op|Rest], [OpParsed|RestParsed]) :-
is_nonvar(Op),
parse_write_options(Rest, RestParsed),
( parse_write_option(Op, OpParsed)
-> true
; domain_error(write_option, Op)
).
write_term(S, Term, Options) :-
is_nonvar(Options),
is_list(Options),
parse_write_options(Options, ParsedOptions),
'$write_term'(S, Term, ParsedOptions).
write_term(Term, Options) :-
current_output(S),
write_term(S, Term, Options).
write(Term) :-
current_output(S),
write_term(S, Term, [numbervars(true)]).
write(S, Term) :-
write_term(S, Term, [numbervars(true)]).
writeq(Term) :-
current_output(S),
write_term(S, Term, [quoted(true), numbervars(true)]).
writeq(S, Term) :-
write_term(S, Term, [quoted(true), numbervars(true)]).
write_canonical(Term) :-
current_output(S),
write_term(S, Term, [quoted(true), ignore_ops(true)]).
write_canonical(S, Term) :-
write_term(S, Term, [quoted(true), ignore_ops(true)]).
% Arithmetic comparisons defined in terms of >=. This is not the most effective way,
% but it is fine for now.
E1 =:= E2 :-
E1 >= E2,
E2 >= E1.
E1 =\= E2 :-
\+ E1 =:= E2.
E1 < E2 :-
E2 >= E1,
E1 =\= E2.
E1 =< E2 :-
E2 >= E1.
E1 > E2 :-
E2 < E1.
% Clause retrieval and information and removal
clause(Head, Body) :-
clause(Head, Body, Clauses),
member(clause(Head, Body), Clauses).
current_predicate(PI) :-
current_predicate(PI, Predicates),
member(PI, Predicates).
retract(Clause) :-
copy_term(Clause, ClauseCopy),
retract_one(ClauseCopy),
( Clause = ClauseCopy
; retract(Clause)
).
% Basic list predicates
member(X, [X|_]).
member(X, [_|Tail]) :-
member(X, Tail).
append([], Ys, Ys).
append([X|Xs], Ys, [X|Zs]) :-
append(Xs, Ys, Zs).
length([], 0).
length([_|T], Len) :-
length(T, Len0),
Len is Len0 + 1.
unique([], []).
unique([H|T], [H|Rest]) :-
findall(_, (member(X, T), X == H), []),
!,
unique(T, Rest).
unique([_|T], Rest) :-
unique(T, Rest).
union(A, B, C) :-
append(A, B, C0),
unique(C0, C).
difference(A, B, Diff) :-
append(A, B, AB),
unique_in(AB, AB, Diff).
unique_in([], _, []).
unique_in([H|T], L, [H|Rest]) :-
findall(_, (member(X, L), X == H), [_]),
!,
unique_in(T, L, Rest).
unique_in([_|T], L, Rest) :-
unique_in(T, L, Rest).
include(_, [], []).
include(Goal, [X|Xs], Included) :-
Goal =.. L,
append(L, [X], L1),
G =.. L1,
( call(G)
-> Included = [X|Included0]
; Included = Included0
),
include(Goal, Xs, Included0).
% Additional type tests
callable(T) :- atom(T) ; compound(T).
list([]).
list([_|T]) :- list(T).
partial_list(T) :- var(T).
partial_list([_|T]) :- partial_list(T).
atomic(T) :- atom(T) ; integer(T) ; float(T).
% type assertions (throws an error if false)
is_atom(T) :- (atom(T) ; type_error(atom, T)), !.
is_atom_or_var(T) :- (atom(T) ; var(T) ; type_error(atom, T)), !.
is_callable(T) :- (callable(T) ; type_error(callable, T)), !.
is_nonvar(T) :- (nonvar(T) ; instantiation_error), !.
is_list_or_partial_list(T) :- (list(T) ; partial_list(T) ; type_error(list, T)), !.
is_list(T) :- (list(T) ; type_error(list, T)), !.
is_integer(T) :- (integer(T) ; type_error(integer, T)), !.
is_predicate_indicator(T) :- ((nonvar(T), T = N/A, integer(A), atom(N)) ; type_error(predicate_indicator, T)), !.
% All solutions
findall(Template, Goal, Instances) :-
is_nonvar(Goal),
is_callable(Goal),
is_list_or_partial_list(Instances),
system:asserta('find all'([])),
call(Goal),
system:asserta('find all'(solution(Template))),
fail.
findall(_, _, Instances) :-
findall_collect([], Instances).
findall_collect(Acc, Instances) :-
system:retract('find all'(Item)),
!,
findall_collect(Item, Acc, Instances).
findall_collect([], Instances, Instances).
findall_collect(solution(T), Acc, Instances) :-
findall_collect([T|Acc], Instances).
bagof(Template, Goal, Instances) :-
free_variable_set(Goal, Template, Witness),
iterated_goal(Goal, G),
findall(Witness+Template, G, S),
bagof_loop(Witness, S, Instances).
bagof_loop(Witness, S, Instances) :-
[W+T|_] = S,
bagof_wt_list(S, W+T, WT_list),
bagof_split(WT_list, W_list, T_list),
( bagof_unify_list(Witness, W_list), Instances = T_list
; bagof_next_s(S, WT_list, S_next), bagof_loop(Witness, S_next, Instances)
).
bagof_wt_list([], _, []).
bagof_wt_list([W+T|Tail], W0+T0, Rest) :-
copy_term(W+T, W1+T1),
bagof_wt_list(Tail, W0+T0, Rest0),
( variant(W1, W0)
-> Rest = [W1+T1|Rest0]
; Rest = Rest0
).
copy_terms_list([], []).
copy_terms_list([H|T], [HH|TT]) :-
copy_term(H, HH),
copy_terms_list(T, TT).
bagof_split([], [], []).
bagof_split([WW+TT|RestWT], [WW|RestW], [TT|RestT]) :-
bagof_split(RestWT, RestW, RestT).
bagof_unify_list(_, []).
bagof_unify_list(W, [W|T]) :- bagof_unify_list(W, T).
bagof_next_s([], _, []).
bagof_next_s([H|T], WT_list, Rest) :-
bagof_next_s(T, WT_list, Rest0),
( findall(_, (member(X, WT_list), variant(X, H)), [])
-> Rest = [H|Rest0]
; Rest = Rest0
).
setof(Template, Goal, Instances) :-
bagof(Template, Goal, Instances_list),
sort(Instances_list, Instances).
% misc helpers
variable_set(Term, []) :-
atomic(Term).
variable_set(Term, [Term]) :-
var(Term).
variable_set(Term, Vars) :-
compound(Term),
Term =.. [_|Args],
variable_set(Args, [], Vars0),
unique(Vars0, Vars).
variable_set([], Acc, Acc).
variable_set([Arg|Rest], Acc0, Result) :-
variable_set(Arg, VarSet),
append(Acc0, VarSet, Acc),
variable_set(Rest, Acc, Result).
existential_variable_set(Term, []) :-
(atomic(Term) ; var(Term)),
!.
existential_variable_set(V^G, Vars) :-
!,
existential_variable_set(G, Vars0),
variable_set(V, Vars1),
union(Vars0, Vars1, Vars).
existential_variable_set(_, []).
free_variable_set(T, V, Vars) :-
variable_set(T, TVars),
variable_set(V, VVars),
existential_variable_set(T, TExVars),
union(VVars, TExVars, BV),
difference(TVars, BV, Vars).
iterated_goal(Goal, T) :-
compound(Goal),
_^G = Goal,
!,
iterated_goal(G, T).
iterated_goal(G, G).
variant(T1, T2) :-
var(T1), var(T2), !.
variant(T1, T2) :-
compound(T1),
compound(T2),
!,
T1 =.. [Name|Args1],
T2 =.. [Name|Args2],
variant_list(Args1, Args2).
variant(T1, T2) :-
T1 == T2.
variant_list([], []).
variant_list([H1|T1], [H2|T2]) :-
variant(H1, H2),
variant_list(T1, T2).
% Sorting, which also removes duplicates (should be implemented in C for speed I think).
sort(Ls0, Ls) :-
append(Lefts, [A,B|Rights], Ls0),
A @> B,
!,
append(Lefts, [B,A|Rights], Ls1),
sort(Ls1, Ls).
sort(Ls0, Ls) :-
append(Lefts, [A,B|Rights], Ls0),
A == B,
!,
append(Lefts, [A|Rights], Ls1),
sort(Ls1, Ls).
sort(Ls, Ls).
% Atomic term processing
atom_concat(A1, A2, A3) :-
is_atom_or_var(A1),
is_atom_or_var(A2),
is_atom_or_var(A3),
atom(A1), atom(A2),
!,
atom_codes(A1, Codes1),
atom_codes(A2, Codes2),
append(Codes1, Codes2, Codes),
atom_codes(A3, Codes).
atom_concat(A1, A2, A3) :-
is_atom_or_var(A1),
is_atom_or_var(A2),
is_atom_or_var(A3),
atom(A3),
!,
atom_codes(A3, Codes),
append(Codes1, Codes2, Codes),
atom_codes(A1, Codes1),
atom_codes(A2, Codes2).
atom_concat(_, _, _) :-
instantiation_error.
% Character input/output
get_char(Char) :-
current_input(S),
get_char(S, Char).
get_code(Code) :-
current_input(S),
get_code(S, Code).
get_code(S, Code) :-
get_char(S, Char),
( Char = end_of_file
-> Code = -1
; char_code(Char, Code)
).
peek_char(Char) :-
current_input(S),
peek_char(S, Char).
peek_code(Code) :-
current_input(S),
peek_code(S, Code).
peek_code(S, Code) :-
peek_char(S, Char),
( Char = end_of_file
-> Code = -1
; char_code(Char, Code)
).
put_char(Char) :-
current_output(S),
put_char(S, Char).
put_code(Code) :-
current_output(S),
put_code(S, Code).
put_code(S, Code) :-
char_code(Char, Code),
put_char(S, Char).
nl :-
current_output(S),
nl(S).
nl(S) :-
put_char(S, '
'). % This should really be \n
% flags
set_prolog_flag(Flag, Value) :-
is_nonvar(Flag),
is_nonvar(Value),
is_atom(Flag),
is_prolog_flag(Flag),
is_appropriate_flag_value(Flag, Value),
is_modifiable_flag(Flag),
'$set_prolog_flag'(Flag, Value).
current_prolog_flag(Flag, Value) :-
is_atom_or_var(Flag),
( atom(Flag)
-> is_prolog_flag(Flag)
; true
),
current_prolog_flags(FlagsAndValues),
member(flag(Flag, Value), FlagsAndValues).
is_prolog_flag(Flag) :-
member(Flag,
[ bounded
, max_integer
, min_integer
, integer_rounding_function
, char_conversion
, debug
, max_arity
, unknown
, double_quotes]),
!
; domain_error(prolog_flag, Flag).
is_modifiable_flag(Flag) :-
member(Flag, [char_conversion, debug, unknown, double_quotes]),
!
; permission_error(modify, flag, Flag).
is_appropriate_flag_value(Flag, Value) :-
appropriate_flag_values(Flag, Values),
member(Value, Values),
!
; domain_error(flag_value, Flag + Value).
appropriate_flag_values(bounded, [true, false]).
appropriate_flag_values(max_integer, [Val]) :-
current_prolog_flag(max_integer, Val).
appropriate_flag_values(min_integer, [Val]) :-
current_prolog_flag(min_integer, Val).
appropriate_flag_values(integer_rounding_function, [down, toward_zero]).
appropriate_flag_values(char_conversion, [on, off]).
appropriate_flag_values(debug, [on, off]).
appropriate_flag_values(max_arity, [Val]) :-
current_prolog_flag(max_arity, Val).
appropriate_flag_values(unknown, [error, fail, warning]).
appropriate_flag_values(double_quotes, [chars, codes, atom]).
% Operator table modification and inspection
op(Priority, Op_specifier, Operator) :-
is_nonvar(Priority),
is_integer(Priority),
is_nonvar(Op_specifier),
is_atom(Op_specifier),
( operator_priority(Priority), !
; domain_error(operator_priority, Priority)
),
( operator_specifier(Op_specifier), !
; domain_error(operator_specifier, Op_specifier)
),
is_nonvar(Operator),
( atom(Operator)
-> Ops = [Operator]
; Ops = Operator
),
is_list(Ops),
op_helper(Priority, Op_specifier, Ops).
op_helper(_, _, []).
op_helper(Priority, Op_specifier, [Op|Ops]) :-
is_nonvar(Op),
is_atom(Op),
'$op'(Priority, Op_specifier, Op),
op_helper(Priority, Op_specifier, Ops).
operator_priority(P) :-
integer(P),
P >= 0,
P =< 1200.
operator_specifier(S) :-
member(S, [xf, yf, xfx, xfy, yfx, fx, fy]).
current_op(Priority, Op_specifier, Operator) :-
( (var(Priority) ; operator_priority(Priority)), !
; domain_error(operator_priority, Priority)
),
( (var(Op_specifier) ; operator_specifier(Op_specifier)), !
; domain_error(operator_specifier, Op_specifier)
),
is_atom_or_var(Operator),
current_ops(Operators),
member(op(Priority, Op_specifier, Operator), Operators).
% Halting
halt(X) :-
is_nonvar(X),
is_integer(X),
'$halt'(X).
halt :-
halt(0).
% Loading prolog text
consult(File) :-
loader:load_module_from_file(File).
twice(!) :- '$write_term'(4, 'C ', []).
twice(true) :- '$write_term'(4, 'Moss ', []).