java/com/googlecode/prolog_cafe/builtin/builtins.pl [1:1896]: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Builtin Predicates of Prolog Cafe % % Mutsunori Banbara (banbara@kobe-u.ac.jp) % Naoyuki Tamura (tamura@kobe-u.ac.jp) % Kobe University %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- op(1150, fx, (package)). package(_). :- package 'com.googlecode.prolog_cafe.builtin'. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Control constructs %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public true/0, otherwise/0. :- public fail/0, false/0. :- public (!)/0. :- public (^)/2. :- public (',')/2. :- public (;)/2. :- public (->)/2. :- public call/1. true. otherwise. fail :- fail. false :- fail. !. (_ ^ G) :- call(G). (P, Q) :- call(P), call(Q). (P; _Q) :- P \= (_ -> _), call(P). (_P; Q) :- Q \= (_ -> _), call(Q). (IF -> THEN) :- call(IF), !, call(THEN). (IF -> THEN; _ELSE) :- call(IF), !, call(THEN). (_IF -> _THEN; ELSE) :- call(ELSE). call(Term) :- '$get_current_B'(Cut), '$meta_call'(Term, user, Cut, 0, interpret). '$meta_call'(X, _, _, _, _) :- var(X), !, illarg(var, call(X), 1). '$meta_call'(X, _, _, _, _) :- closure(X), !, '$call_closure'(X). '$meta_call'(true, _, _, _, _) :- !. '$meta_call'(_^X, P, Cut, Depth, Mode) :- !, '$meta_call'(X, P, Cut, Depth, Mode). '$meta_call'(P:X, _, Cut, Depth, Mode) :- !, '$meta_call'(X, P, Cut, Depth, Mode). '$meta_call'(!, _, no, _, _) :- !, illarg(context(if,cut), !, 0). '$meta_call'(!, _, Cut, _, _) :- !, '$cut'(Cut). '$meta_call'((X,Y), P, Cut, Depth, Mode) :- !, '$meta_call'(X, P, Cut, Depth, Mode), '$meta_call'(Y, P, Cut, Depth, Mode). '$meta_call'((X->Y;Z), P, Cut, Depth, Mode) :- !, ( '$meta_call'(X, P, no, Depth, Mode) -> '$meta_call'(Y, P, Cut, Depth, Mode) ; '$meta_call'(Z, P, Cut, Depth, Mode) ). '$meta_call'((X->Y), P, Cut, Depth, Mode) :- !, ( '$meta_call'(X, P, no, Depth, Mode) -> '$meta_call'(Y, P, Cut, Depth, Mode) ). '$meta_call'((X;Y), P, Cut, Depth, Mode) :- !, ( '$meta_call'(X, P, Cut, Depth, Mode) ; '$meta_call'(Y, P, Cut, Depth, Mode) ). '$meta_call'(\+(X), P, _, Depth, Mode) :- !, \+ '$meta_call'(X, P, no, Depth, Mode). '$meta_call'(findall(X,Y,Z), P, Cut, Depth, Mode) :- !, findall(X, '$meta_call'(Y, P, Cut, Depth, Mode), Z). '$meta_call'(bagof(X,Y,Z), P, Cut, Depth, Mode) :- !, bagof(X, '$meta_call'(Y, P, Cut, Depth, Mode), Z). '$meta_call'(setof(X,Y,Z), P, Cut, Depth, Mode) :- !, setof(X, '$meta_call'(Y, P, Cut, Depth, Mode), Z). '$meta_call'(once(X), P, Cut, Depth, Mode) :- !, once('$meta_call'(X, P, Cut, Depth, Mode)). '$meta_call'(on_exception(X,Y,Z), P, Cut, Depth, Mode) :- !, on_exception(X, '$meta_call'(Y, P, Cut, Depth, Mode), '$meta_call'(Z, P, Cut, Depth, Mode)). '$meta_call'(catch(X,Y,Z), P, Cut, Depth, Mode) :- !, catch('$meta_call'(X, P, Cut, Depth, Mode), Y, '$meta_call'(Z, P, Cut, Depth, Mode)). %'$meta_call'(freeze(X,Y), P, Cut, Depth, Mode) :- !, ??? % freeze(X, '$meta_call'(Y, P, Cut, Depth, Mode)). '$meta_call'(clause(X, Y), P, _, _, _) :- !, clause(P:X, Y). '$meta_call'(assert(X), P, _, _, _) :- !, assertz(P:X). '$meta_call'(assertz(X), P, _, _, _) :- !, assertz(P:X). '$meta_call'(asserta(X), P, _, _, _) :- !, asserta(P:X). '$meta_call'(retract(X), P, _, _, _) :- !, retract(P:X). '$meta_call'(abolish(X), P, _, _, _) :- !, abolish(P:X). '$meta_call'(retractall(X), P, _, _, _) :- !, retractall(P:X). '$meta_call'(X, P, _, Depth, Mode) :- atom(P), callable(X), !, '$meta_call'(Mode, Depth, P, X). '$meta_call'(X, P, _, _, _) :- illarg(type(callable), call(P:X), 1). '$meta_call'(trace, Depth, P, X) :- !, functor(X, F, A), '$call'('com.googlecode.prolog_cafe.builtin', '$trace_goal'(X, P, F/A, Depth)). '$meta_call'(interpret, Depth, P, X) :- functor(X, F, A), '$call_internal'(X, P, F/A, Depth, interpret). '$call_internal'(X, P, FA, Depth, Mode) :- '$new_internal_database'(P), hash_contains_key(P, FA), !, '$get_current_B'(Cut), Depth1 is Depth + 1, clause(P:X, Body), '$meta_call'(Body, P, Cut, Depth1, Mode). '$call_internal'(X, P, _, _, _) :- '$call'(P, X). :- public catch/3, throw/1. :- public on_exception/3. catch(Goal, Catch, Recovery) :- on_exception(Catch, Goal, Recovery). throw(Msg) :- raise_exception(Msg). on_exception(Catch, Goal, Recovery) :- callable(Goal), !, '$on_exception'(Catch, Goal, Recovery). on_exception(Catch, Goal, Recovery) :- illarg(type(callable), on_exception(Catch,Goal,Recovery), 2). '$on_exception'(_Catch, Goal, _Recovery) :- '$set_exception'('$none'), '$begin_exception'(L), call(Goal), '$end_exception'(L). '$on_exception'(Catch, _Goal, Recovery) :- '$get_exception'(Msg), Msg \== '$none', '$catch_and_throw'(Msg, Catch, Recovery). '$catch_and_throw'(Msg, Msg, Recovery) :- !, '$set_exception'('$none'), call(Recovery). '$catch_and_throw'(Msg, _, _) :- raise_exception(Msg). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term unification %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (=)/2, '$unify'/2. :- public (\=)/2, '$not_unifiable'/2. X = Y :- X = Y. '$unify'(X, Y) :- '$unify'(X, Y). X \= Y :- X \= Y. '$not_unifiable'(X, Y) :- '$not_unifiable'(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Type testing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public var/1, atom/1, integer/1, float/1, atomic/1, compound/1, nonvar/1, number/1. :- public java/1, java/2, closure/1. :- public ground/1, callable/1. var(X) :- var(X). atom(X) :- atom(X). integer(X) :- integer(X). float(X) :- float(X). atomic(X) :- atomic(X). nonvar(X) :- nonvar(X). number(X) :- number(X). java(X) :- java(X). java(X, Y) :- java(X, Y). closure(X) :- closure(X). ground(X) :- ground(X). compound(X) :- nonvar(X), functor(X, _, A), A > 0. callable(X) :- atom(X), !. callable(X) :- compound(X), !. callable(X) :- closure(X). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term comparison %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (==)/2, '$equality_of_term'/2. :- public (\==)/2, '$inequality_of_term'/2. :- public (@<)/2, '$before'/2. :- public (@>)/2, '$after'/2. :- public (@=<)/2, '$not_after'/2. :- public (@>=)/2, '$not_before'/2. :- public (?=)/2, '$identical_or_cannot_unify'/2. :- public compare/3. % :- public sort/2. witten in Java % :- public keysort/2. witten in Java % :- public merge/3. X == Y :- X == Y. '$equality_of_term'(X, Y) :- '$equality_of_term'(X, Y). X \== Y :- X \== Y. '$inequality_of_term'(X, Y) :- '$inequality_of_term'(X, Y). X @< Y :- X @< Y. '$before'(X, Y) :- '$before'(X, Y). X @> Y :- X @> Y. '$after'(X, Y) :- '$after'(X, Y). X @=< Y :- X @=< Y. '$not_after'(X, Y) :- '$not_after'(X, Y). X @>= Y :- X @>= Y. '$not_before'(X, Y) :- '$not_before'(X, Y). ?=(X, Y) :- ?=(X, Y). '$identical_or_cannot_unify'(X, Y) :- '$identical_or_cannot_unify'(X, Y). compare(Op, X, Y) :- '$compare0'(Op0, X, Y), '$map_compare_op'(Op0, Op). '$map_compare_op'(Op0, Op) :- Op0 =:= 0, !, Op = (=). '$map_compare_op'(Op0, Op) :- Op0 < 0, !, Op = (<). '$map_compare_op'(Op0, Op) :- Op0 > 0, !, Op = (>). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term creation and decomposition %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %:- public arg/3. --> written in Java %:- public functor/3. --> written in Java :- public (=..)/2. :- public copy_term/2. Term =.. List :- Term =.. List. copy_term(X, Y) :- copy_term(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Arithmetic evaluation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (is)/2. :- public '$abs'/2, '$asin'/2, '$acos'/2, '$atan'/2. :- public '$bitwise_conj'/3, '$bitwise_disj'/3, '$bitwise_exclusive_or'/3, '$bitwise_neg'/2. :- public '$ceil'/2, '$cos'/2. :- public '$degrees'/2. :- public '$exp'/2. :- public '$float'/2, '$float_integer_part'/2, '$float_fractional_part'/2, '$float_quotient'/3, '$floor'/2. :- public '$int_quotient'/3. :- public '$log'/2. :- public '$max'/3, '$min'/3, '$minus'/3, '$mod'/3, '$multi'/3. :- public '$plus'/3, '$pow'/3. :- public '$radians'/2, '$rint'/2, '$round'/2. :- public '$shift_left'/3, '$shift_right'/3, '$sign'/2, '$sin'/2, '$sqrt'/2. :- public '$tan'/2, '$truncate'/2. Z is Y :- Z is Y. '$abs'(X, Y) :- '$abs'(X, Y). '$asin'(X, Y) :- '$asin'(X, Y). '$acos'(X, Y) :- '$acos'(X, Y). '$atan'(X, Y) :- '$atan'(X, Y). '$bitwise_conj'(X, Y, Z) :- '$bitwise_conj'(X, Y, Z). '$bitwise_disj'(X, Y, Z) :- '$bitwise_disj'(X, Y, Z). '$bitwise_exclusive_or'(X, Y, Z) :- '$bitwise_exclusive_or'(X, Y, Z). '$bitwise_neg'(X, Y) :- '$bitwise_neg'(X, Y). '$ceil'(X, Y) :- '$ceil'(X, Y). '$cos'(X, Y) :- '$cos'(X, Y). '$degrees'(X, Y) :- '$degrees'(X, Y). '$exp'(X, Y) :- '$exp'(X, Y). '$float'(X, Y) :- '$float'(X, Y). '$float_integer_part'(X, Y) :- '$float_integer_part'(X, Y). '$float_fractional_part'(X, Y) :- '$float_fractional_part'(X, Y). '$float_quotient'(X, Y, Z) :- '$float_quotient'(X, Y, Z). '$floor'(X, Y) :- '$floor'(X, Y). '$int_quotient'(X, Y, Z) :- '$int_quotient'(X, Y, Z). '$log'(X, Y) :- '$log'(X, Y). '$max'(X, Y, Z) :- '$max'(X, Y, Z). '$min'(X, Y, Z) :- '$min'(X, Y, Z). '$minus'(X, Y, Z) :- '$minus'(X, Y, Z). '$mod'(X, Y, Z) :- '$mod'(X, Y, Z). '$multi'(X, Y, Z) :- '$multi'(X, Y, Z). '$plus'(X,Y,Z) :- '$plus'(X,Y,Z). '$pow'(X, Y, Z) :- '$pow'(X, Y, Z). '$radians'(X, Y) :- '$radians'(X, Y). '$rint'(X, Y) :- '$rint'(X, Y). '$round'(X, Y) :- '$round'(X, Y). '$shift_left'(X, Y, Z) :- '$shift_left'(X, Y, Z). '$shift_right'(X, Y, Z) :- '$shift_right'(X, Y, Z). '$sign'(X, Y) :- '$sign'(X, Y). '$sin'(X, Y) :- '$sin'(X, Y). '$sqrt'(X, Y) :- '$sqrt'(X, Y). '$tan'(X, Y) :- '$tan'(X, Y). '$truncate'(X, Y) :- '$truncate'(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Arithmetic comparison %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (=:=)/2, '$arith_equal'/2. :- public (=\=)/2, '$arith_not_equal'/2. :- public (<)/2, '$less_than'/2. :- public (=<)/2, '$less_or_equal'/2. :- public (>)/2, '$greater_than'/2. :- public (>=)/2, '$greater_or_equal'/2. X =:= Y :- X =:= Y. '$arith_equal'(X, Y) :- '$arith_equal'(X, Y). X =\= Y :- X =\= Y. '$arith_not_equal'(X, Y) :- '$arith_not_equal'(X, Y). X < Y :- X < Y. '$less_than'(X, Y) :- '$less_than'(X, Y). X =< Y :- X =< Y. '$less_or_equal'(X, Y) :- '$less_or_equal'(X, Y). X > Y :- X > Y. '$greater_than'(X, Y) :- '$greater_than'(X, Y). X >= Y :- X >= Y. '$greater_or_equal'(X, Y) :- '$greater_or_equal'(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Clause retrieval and information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public clause/2. :- public (initialization)/2. :- public '$new_indexing_hash'/3. clause(Head, B) :- '$head_to_term'(Head, H, P:PI, clause(Head,B)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, access, private_procedure, clause(Head, B)), '$clause_internal'(P, PI, H, Cl, _), %(ground(Cl) -> Cl = (H :- B) ; copy_term(Cl, (H :- B))). ??? copy_term(Cl, (H :- B)). % head --> term '$head_to_term'(H, T, Pkg:F/A, Goal) :- '$head_to_term'(H, T, user, Pkg, Goal), functor(T, F, A). '$head_to_term'(H, _, _, _, Goal) :- var(H), !, illarg(var, Goal, 1). '$head_to_term'(P:H, T, _, Pkg, Goal) :- !, '$head_to_term'(H, T, P, Pkg, Goal). '$head_to_term'(H, H, Pkg, Pkg, _) :- callable(H), atom(Pkg), !. '$head_to_term'(_, _, _, _, Goal) :- illarg(type(callable), Goal, 1). % creates an internal database for A if no exists. '$new_internal_database'(A) :- atom(A), '$get_hash_manager'(HM), '$new_internal_database'(HM, A). '$new_internal_database'(HM, A) :- hash_contains_key(HM, A), !. '$new_internal_database'(_, A) :- new_hash(_, [alias(A)]), '$init_internal_database'(A). '$init_internal_database'(A) :- '$compiled_predicate'(A, '$init', 0), call(A:'$init'), !. '$init_internal_database'(_). % checks if the internal database of A exists. '$defined_internal_database'(A) :- atom(A), '$get_hash_manager'(HM), hash_contains_key(HM, A). % repeatedly finds dynamic clauses. '$clause_internal'(P, PI, H, Cl, Ref) :- hash_contains_key(P, PI), '$get_indices'(P, PI, H, RevRefs), '$get_instances'(RevRefs, Cls_Refs), '$clause_internal0'(Cls_Refs, Cl, Ref). '$clause_internal0'([], _, _) :- fail. '$clause_internal0'([(Cl,Ref)], Cl, Ref) :- !. '$clause_internal0'(L, Cl, Ref) :- '$builtin_member'((Cl,Ref), L). '$get_indices'(P, PI, H, Refs) :- '$new_indexing_hash'(P, PI, IH), '$calc_indexing_key'(H, Key), ( hash_contains_key(IH, Key) -> hash_get(IH, Key, Refs) ; hash_get(IH, var, Refs) ). % finds the indexing hashtable for P:PI. creates it if no exist. '$new_indexing_hash'(P, PI, IH) :- hash_contains_key(P, PI), !, hash_get(P, PI, IH). '$new_indexing_hash'(P, PI, IH) :- new_hash(IH), hash_put(IH, all, []), hash_put(IH, var, []), hash_put(IH, lis, []), hash_put(IH, str, []), hash_put(P, PI, IH). '$calc_indexing_key'(H, all) :- atom(H), !. '$calc_indexing_key'(H, Key) :- arg(1, H, A1), '$calc_indexing_key0'(A1, Key). '$calc_indexing_key0'(A1, all) :- var(A1), !. '$calc_indexing_key0'(A1, lis) :- A1 = [_|_], !. '$calc_indexing_key0'(A1, str) :- compound(A1), !. '$calc_indexing_key0'(A1, Key) :- ground(A1), !, '$term_hash'(A1, Key). '$calc_indexing_key0'(A1, Key) :- illarg(type(term), '$calc_indexing_key0'(A1,Key), 1). % checks the permission of predicate P:F/A. '$check_procedure_permission'(P:F/A, _Operation, _ObjType, _Goal) :- hash_contains_key(P, F/A), !. '$check_procedure_permission'(P:F/A, Operation, ObjType, Goal) :- '$compiled_predicate_or_builtin'(P, F, A), !, illarg(permission(Operation,ObjType,P:F/A,_), Goal, _). '$check_procedure_permission'(_, _, _, _). % initialize internal databases of given packages. initialization([], Goal) :- !, once(Goal). initialization([P|Ps], Goal) :- '$new_internal_database'(P), initialization(Ps, Goal). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Clause creation and destruction %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public assert/1. :- public assertz/1. :- public asserta/1. :- public retract/1. :- public abolish/1. :- public retractall/1. assert(T) :-assertz(T). assertz(T) :- '$term_to_clause'(T, Cl, P:PI, assertz(T)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, modify, static_procedure, assertz(T)), copy_term(Cl, NewCl), '$insert'(NewCl, Ref), '$update_indexing'(P, PI, Cl, Ref, 'z'), fail. assertz(_). asserta(T) :- '$term_to_clause'(T, Cl, P:PI, asserta(T)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, modify, static_procedure, asserta(T)), copy_term(Cl, NewCl), '$insert'(NewCl, Ref), '$update_indexing'(P, PI, Cl, Ref, 'a'), fail. asserta(_). abolish(T) :- '$term_to_predicateindicator'(T, P:PI, abolish(T)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, modify, static_procedure, abolish(T)), '$new_indexing_hash'(P, PI, IH), hash_get(IH, all, Refs), '$erase_all'(Refs), hash_remove(P, PI), fail. abolish(_). retract(Cl) :- '$clause_to_term'(Cl, T, P:PI, retract(Cl)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, access, static_procedure, retract(Cl)), T = (H :- _), '$clause_internal'(P, PI, H, Cl0, Ref), copy_term(Cl0, T), '$erase'(Ref), '$rehash_indexing'(P, PI, Ref). retractall(Head) :- '$head_to_term'(Head, H, P:PI, retractall(Head)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, access, static_procedure, retractall(Head)), '$clause_internal'(P, PI, H, Cl, Ref), copy_term(Cl, (H :- _)), '$erase'(Ref), '$rehash_indexing'(P, PI, Ref), fail. retractall(_). % term --> clause (for assert) '$term_to_clause'(Cl0, Cl, Pkg:F/A, Goal) :- '$term_to_clause'(Cl0, Cl, user, Pkg, Goal), Cl = (H :- _), functor(H, F, A). '$term_to_clause'(Cl0, _, _, _, Goal) :- var(Cl0), !, illarg(var, Goal, 1). '$term_to_clause'(_, _, Pkg0, _, Goal) :- var(Pkg0), !, illarg(var, Goal, 1). '$term_to_clause'(P:Cl0, Cl, _, Pkg, Goal) :- !, '$term_to_clause'(Cl0, Cl, P, Pkg, Goal). '$term_to_clause'(_, _, Pkg0, _, Goal) :- \+(atom(Pkg0)), !, illarg(type(atom), Goal, 1). '$term_to_clause'((H0 :- B0), (H :- B), Pkg, Pkg, Goal) :- !, '$term_to_head'(H0, H, Pkg, Goal), '$term_to_body'(B0, B, Pkg, Goal). '$term_to_clause'(H0, (H :- true), Pkg, Pkg, Goal) :- '$term_to_head'(H0, H, Pkg, Goal). '$term_to_head'(H, H, _, _) :- atom(H), !. '$term_to_head'(H, H, _, _) :- compound(H), !. '$term_to_head'(_, _, _, Goal) :- illarg(type(callable), Goal, 1). '$term_to_body'(B0, B, Pkg, _) :- '$localize_body'(B0, Pkg, B). '$localize_body'(G, P, G1) :- var(G), !, '$localize_body'(call(G), P, G1). '$localize_body'(P:G, _, G1) :- !, '$localize_body'(G, P, G1). '$localize_body'((X,Y), P, (X1,Y1)) :- !, '$localize_body'(X, P, X1), '$localize_body'(Y, P, Y1). '$localize_body'((X->Y), P, (X1->Y1)) :- !, '$localize_body'(X, P, X1), '$localize_body'(Y, P, Y1). '$localize_body'((X;Y), P, (X1;Y1)) :- !, '$localize_body'(X, P, X1), '$localize_body'(Y, P, Y1). '$localize_body'(G, P, G1) :- functor(G, F, A), '$builtin_meta_predicates'(F, A, M), %??? !, G =.. [F|As], '$localize_args'(M, As, P, As1), G1 =.. [F|As1]. '$localize_body'(G, P, call(P:G)) :- var(P), !. '$localize_body'(G, user, G) :- !. '$localize_body'(G, _, G) :- system_predicate(G), !. '$localize_body'(G, P, P:G). '$localize_args'([], [], _, []) :- !. '$localize_args'([:|Ms], [A|As], P, [P:A|As1]) :- (var(A) ; A \= _:_), !, '$localize_args'(Ms, As, P, As1). '$localize_args'([_|Ms], [A|As], P, [A|As1]) :- '$localize_args'(Ms, As, P, As1). '$builtin_meta_predicates'((^), 2, [?,:]). '$builtin_meta_predicates'(call, 1, [:]). '$builtin_meta_predicates'(once, 1, [:]). '$builtin_meta_predicates'((\+), 1, [:]). '$builtin_meta_predicates'(findall, 3, [?,:,?]). '$builtin_meta_predicates'(setof, 3, [?,:,?]). '$builtin_meta_predicates'(bagof, 3, [?,:,?]). '$builtin_meta_predicates'(on_exception, 3, [?,:,:]). '$builtin_meta_predicates'(catch, 3, [:,?,:]). '$builtin_meta_predicates'(freeze, 2, [?,:]). % clause --> term (for retract) '$clause_to_term'(Cl, T, Pkg:F/A, Goal) :- '$clause_to_term'(Cl, T, user, Pkg, Goal), T = (H :- _), functor(H, F, A). '$clause_to_term'(Cl, _, _, _, Goal) :- var(Cl), !, illarg(var, Goal, 1). '$clause_to_term'(_, _, Pkg, _, Goal) :- var(Pkg), !, illarg(var, Goal, 1). '$clause_to_term'(P:Cl, T, _, Pkg, Goal) :- !, '$clause_to_term'(Cl, T, P, Pkg, Goal). '$clause_to_term'(_, _, Pkg, _, Goal) :- \+(atom(Pkg)), !, illarg(type(atom), Goal, 1). '$clause_to_term'((H0 :- B), (H :- B), Pkg, Pkg, Goal) :- !, '$head_to_term'(H0, H, _, Goal). %'$body_to_term'(B0, B, Goal). '$clause_to_term'(H0, (H :- true), Pkg, Pkg, Goal) :- '$head_to_term'(H0, H, _, Goal). % term --> predicate indicator (for abolish) '$term_to_predicateindicator'(T, Pkg:PI, Goal) :- '$term_to_predicateindicator'(T, PI, user, Pkg, Goal). '$term_to_predicateindicator'(T, _, _, _, Goal) :- var(T), !, illarg(var, Goal, 1). '$term_to_predicateindicator'(_, _, Pkg, _, Goal) :- var(Pkg), !, illarg(var, Goal, 1). '$term_to_predicateindicator'(P:T, PI, _, Pkg, Goal) :- !, '$term_to_predicateindicator'(T, PI, P, Pkg, Goal). '$term_to_predicateindicator'(T, _, _, _, Goal) :- T \= _/_, !, illarg(type('predicate_indicator'), Goal, 1). '$term_to_predicateindicator'(F/_, _, _, _, Goal) :- \+ atom(F), !, illarg(type(atom), Goal, 1). '$term_to_predicateindicator'(_/A, _, _, _, Goal) :- \+ integer(A), !, illarg(type(integer), Goal, 1). '$term_to_predicateindicator'(T, T, Pkg, Pkg, _). '$update_indexing'(P, PI, Cl, Ref, A_or_Z) :- '$new_indexing_hash'(P, PI, IH), '$gen_indexing_keys'(Cl, IH, Keys), '$update_indexing_hash'(A_or_Z, Keys, IH, Ref). '$gen_indexing_keys'((H :- _), _, [all]) :- atom(H), !. '$gen_indexing_keys'((H :- _), IT, Keys) :- arg(1, H, A1), '$gen_indexing_keys0'(A1, IT, Keys). '$gen_indexing_keys0'(A1, IT, Keys) :- var(A1), !, hash_keys(IT, Keys). '$gen_indexing_keys0'(A1, _, [all,lis]) :- A1 = [_|_], !. '$gen_indexing_keys0'(A1, _, [all,str]) :- compound(A1), !. '$gen_indexing_keys0'(A1, IT, [all,Key]) :- ground(A1), !, '$term_hash'(A1, Key), % get the hash code of A1 ( hash_contains_key(IT, Key) -> true ; hash_get(IT, var, L), hash_put(IT, Key, L) ). '$gen_indexing_keys0'(A1, IT, Keys) :- illarg(type(term), '$gen_indexing_keys0'(A1,IT,Keys), 1). '$update_indexing_hash'(a, Keys, IH, Ref) :- !, '$hash_addz_all'(Keys, IH, Ref). '$update_indexing_hash'(z, Keys, IH, Ref) :- !, '$hash_adda_all'(Keys, IH, Ref). '$hash_adda_all'([], _, _) :- !. '$hash_adda_all'([K|Ks], H, X) :- '$hash_adda'(H, K, X), '$hash_adda_all'(Ks, H, X). '$hash_addz_all'([], _, _) :- !. '$hash_addz_all'([K|Ks], H, X) :- '$hash_addz'(H, K, X), '$hash_addz_all'(Ks, H, X). '$erase_all'([]) :- !. '$erase_all'([R|Rs]) :- '$erase'(R), '$erase_all'(Rs). '$rehash_indexing'(P, PI, Ref) :- '$new_indexing_hash'(P, PI, IH), hash_keys(IH, Keys), '$remove_index_all'(Keys, IH, Ref). '$remove_index_all'([], _, _) :- !. '$remove_index_all'([K|Ks], IH, Ref) :- '$hash_remove_first'(IH, K, Ref), '$remove_index_all'(Ks, IH, Ref). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % All solutions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public findall/3. :- public bagof/3. :- public setof/3. % findall/3 findall(Template, Goal, Instances) :- callable(Goal), !, new_hash(H), '$findall'(H, Template, Goal, Instances). findall(Template, Goal, Instances) :- illarg(type(callable), findall(Template,Goal,Instances), 2). '$findall'(H, Template, Goal, _) :- call(Goal), copy_term(Template, CT), '$hash_adda'(H, '$FINDALL', CT), fail. '$findall'(H, _, _, Instances) :- hash_get(H, '$FINDALL', Vs), reverse(Vs, Instances). % bagof/3 & setof/3 bagof(Template, Goal, Instances) :- callable(Goal), !, '$bagof'(Template, Goal, Instances). bagof(Template, Goal, Instances) :- illarg(type(callable), bagof(Template,Goal,Instances), 2). setof(Template, Goal, Instances) :- callable(Goal), !, '$bagof'(Template, Goal, Instances0), sort(Instances0, Instances). setof(Template, Goal, Instances) :- illarg(type(callable), setof(Template,Goal,Instances), 2). '$bagof'(Template, Goal, Instances) :- '$free_variables_set'(Goal, Template, FV), %write('Goal = '), write(Goal), nl, %write('Free variables set = '), write(FV), nl, FV \== [], !, Witness =.. ['$witness'|FV], findall(Witness+Template, Goal, S), '$bagof_instances'(S, Witness, Instances0), Instances = Instances0. '$bagof'(Template, Goal, Instances) :- findall(Template, Goal, Instances), Instances \== []. '$bagof_instances'([], _Witness, _Instances) :- fail. '$bagof_instances'(S0, Witness, Instances) :- S0 = [W+T|S], '$variants_subset'(S, W, WT_list, T_list, S_next), '$bagof_instances0'(S_next, Witness, Instances, [W+T|WT_list], [T|T_list]). '$bagof_instances0'(_, Witness, Instances, WT_list, T_list) :- '$unify_witness'(WT_list, Witness), Instances = T_list. '$bagof_instances0'(S_next, Witness, Instances, _, _) :- '$bagof_instances'(S_next, Witness, Instances). '$variants_subset'([], _W, [], [], []) :- !. '$variants_subset'([W0+T0|S], W, [W0+T0|WT_list], [T0|T_list], S_next) :- '$term_variant'(W, W0), !, '$variants_subset'(S, W, WT_list, T_list, S_next). '$variants_subset'([WT|S], W, WT_list, T_list, [WT|S_next]) :- '$variants_subset'(S, W, WT_list, T_list, S_next). '$term_variant'(X, Y) :- new_hash(Hash), '$term_variant'(X, Y, Hash). '$term_variant'(X, Y, Hash) :- var(X), !, ( hash_contains_key(Hash, X) -> hash_get(Hash, X, V), Y == V ; var(Y), hash_put(Hash, X, Y) ). '$term_variant'(X, Y, _) :- ground(X), !, X == Y. '$term_variant'(_, Y, _) :- var(Y), !, fail. '$term_variant'([X|Xs], [Y|Ys], Hash) :- !, '$term_variant'(X, Y, Hash), '$term_variant'(Xs, Ys, Hash). '$term_variant'(X, Y, Hash) :- X =.. Xs, Y =.. Ys, '$term_variant'(Xs, Ys, Hash). '$unify_witness'([], _) :- !. '$unify_witness'([W+_|WT_list], W) :- '$unify_witness'(WT_list, W). % Variable set of a term '$variables_set'(X, Vs) :- '$variables_set'(X, [], Vs). '$variables_set'(X, Vs, Vs ) :- var(X), '$builtin_memq'(X, Vs), !. '$variables_set'(X, Vs, [X|Vs] ) :- var(X), !. '$variables_set'(X, Vs0, Vs0 ) :- atomic(X), !. '$variables_set'([X|Xs], Vs0, Vs) :- !, '$variables_set'(X, Vs0, Vs1), '$variables_set'(Xs, Vs1, Vs). '$variables_set'(X, Vs0, Vs ) :- X =.. Xs, '$variables_set'(Xs, Vs0, Vs). '$builtin_memq'(X, [Y|_]) :- X==Y, !. '$builtin_memq'(X, [_|Ys]) :- '$builtin_memq'(X, Ys). % Existential variables set of a term '$existential_variables_set'(X, Vs) :- '$existential_variables_set'(X, [], Vs). '$existential_variables_set'(X, Vs, Vs) :- var(X), !. '$existential_variables_set'(X, Vs, Vs) :- atomic(X), !. '$existential_variables_set'(_:X, Vs0, Vs) :- !, '$existential_variables_set'(X, Vs0, Vs). %'$existential_variables_set'((X;Y), Vs0, Vs) :- !, % '$existential_variables_set'(X, Vs0, Vs1), % '$existential_variables_set'(Y, Vs1, Vs). %'$existential_variables_set'((X->Y), Vs0, Vs) :- !, % '$existential_variables_set'(X, Vs0, Vs1), % '$existential_variables_set'(Y, Vs1, Vs). %'$existential_variables_set'((X,Y), Vs0, Vs) :- !, % '$existential_variables_set'(X, Vs0, Vs1), % '$existential_variables_set'(Y, Vs1, Vs). '$existential_variables_set'(^(V,G), Vs0, Vs) :- !, '$variables_set'(V, Vs0, Vs1), '$existential_variables_set'(G, Vs1, Vs). '$existential_variables_set'('$meta_call'(G,_,_,_,_), Vs0, Vs) :- !, %??? '$existential_variables_set'(G, Vs0, Vs). '$existential_variables_set'(_, Vs, Vs). % Free variables set of a term '$free_variables_set'(T, V, FV) :- '$variables_set'(T, TV), '$variables_set'(V, VV), '$existential_variables_set'(T, VV, BV), '$builtin_set_diff'(TV, BV, FV), !. '$builtin_set_diff'(L1, L2, L) :- sort(L1, SL1), sort(L2, SL2), '$builtin_set_diff0'(SL1, SL2, L). '$builtin_set_diff0'([], _, []) :- !. '$builtin_set_diff0'(L1, [], L1) :- !. '$builtin_set_diff0'([X|Xs], [Y|Ys], L) :- X == Y, !, '$builtin_set_diff0'(Xs, Ys, L). '$builtin_set_diff0'([X|Xs], [Y|Ys], [X|L]) :- X @< Y, !, '$builtin_set_diff0'(Xs, [Y|Ys], L). '$builtin_set_diff0'([X|Xs], [Y|Ys], [Y|L]) :- '$builtin_set_diff0'([X|Xs], Ys, [Y|L]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term input/output (read) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public read/2. :- public read_with_variables/3. %:- public read_line/2. (written in Java) :- dynamic '$tokens'/1. read(S_or_a, X) :- read_tokens(S_or_a, Tokens, _), parse_tokens(X, Tokens), !. read_with_variables(S_or_a, X, Vs) :- read_tokens(S_or_a, Tokens, Vs), parse_tokens(X, Tokens), !. % read_token(S_or_a, Token) reads one token from the input, % and unifies Token with: % error(Atom), % end_of_file, % '.', ' ', '(', ')', '[', ']', '{', '}', ',', '|', % number(Integer_or_Float), % atom(Atom), % var(Atom), % string(CharCodeList) read_token(S_or_a, Token) :- '$read_token0'(S_or_a, Type, Token0), '$read_token1'([Type], Token0, Token). '$read_token1'([-2], T, error(T)) :- !. % error('message') '$read_token1'("I", T, number(T)) :- !. % number(intvalue) '$read_token1'("D", T, number(T)) :- !. % number(floatvalue) '$read_token1'("A", T, atom(T)) :- !. % atom('name') '$read_token1'("V", T, var(T)) :- !. % var('name') '$read_token1'("S", T, string(T)) :- !. % string("chars") '$read_token1'(_, T, T) :- !. % others % read_tokens(Tokens, Vs) reads tokens from the input % until full-stop-mark ('.') or end_of_file, % unifies Tokens with a list of tokens. % Token for a variable has a form of var(Name,Variable). % Vs is a list of Name=Variable pairs. read_tokens(Stream, Tokens, Vs) :- '$read_tokens'(Stream, Tokens, Vs, []), !. '$read_tokens'(Stream, Tokens, Vs, VI) :- read_token(Stream, Token), '$read_tokens1'(Stream, Token, Tokens, Vs, VI). '$read_tokens1'(Stream, error(Message), [], _, _) :- !, '$read_tokens_until_fullstop'(Stream), raise_exception(syntax_error(Message)), fail. '$read_tokens1'(_Stream, end_of_file, [end_of_file,'.'], [], _) :- !. '$read_tokens1'(_Stream, '.', ['.'], [], _) :- !. '$read_tokens1'(Stream, var('_'), [var('_',V)|Tokens], ['_'=V|Vs], VI0) :- !, '$read_tokens'(Stream, Tokens, Vs, ['_'=V|VI0]). '$read_tokens1'(Stream, var(Name), [var(Name,V)|Tokens], Vs, VI) :- '$mem_pair'(Name=V, VI), !, '$read_tokens'(Stream, Tokens, Vs, VI). '$read_tokens1'(Stream, var(Name), [var(Name,V)|Tokens], [Name=V|Vs], VI0) :- !, '$read_tokens'(Stream, Tokens, Vs, [Name=V|VI0]). '$read_tokens1'(Stream, Token, [Token|Tokens], Vs, VI) :- '$read_tokens'(Stream, Tokens, Vs, VI). '$mem_pair'(X1=V1, [X2=V2|_]) :- X1 == X2, !, V1 = V2. '$mem_pair'(X, [_|L]) :- '$mem_pair'(X, L). %'$mem_pair'(X, [_|L]) :- member(X, L). '$read_tokens_until_fullstop'(Stream) :- read_token(Stream, Token), '$read_tokens_until_fullstop'(Stream, Token). '$read_tokens_until_fullstop'(_Stream, end_of_file) :- !. '$read_tokens_until_fullstop'(_Stream, '.') :- !. '$read_tokens_until_fullstop'(Stream, _) :- read_token(Stream, Token), '$read_tokens_until_fullstop'(Stream, Token). parse_tokens(X, Tokens) :- retractall('$tokens'(_)), assertz('$tokens'(Tokens)), '$parse_tokens'(X, 1201, Tokens, ['.']), retract('$tokens'(Tokens)), !. % '$parse_tokens'(X, Prec) parses the input whose precedecence =< Prec. '$parse_tokens'(X, Prec0) --> '$parse_tokens_skip_spaces', '$parse_tokens1'(Prec0, X1, Prec1), !, '$parse_tokens_skip_spaces', '$parse_tokens2'(Prec0, X1, Prec1, X, _Prec), !. '$parse_tokens1'(Prec0, X1, Prec1) --> '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_starter'(Next)}, !, '$parse_tokens_before_op'(Prec0, X1, Prec1). '$parse_tokens1'(_, _, _) --> '$parse_tokens_peep_next'(Next), '$parse_tokens_error'([Next,cannot,start,an,expression]). '$parse_tokens2'(Prec0, X, Prec, X, Prec) --> '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_terminator'(Next)}, {Prec =< Prec0}, !. '$parse_tokens2'(Prec0, X1, Prec1, X, Prec) --> '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_post_in_op'(Next)}, !, '$parse_tokens_post_in_ops'(Prec0, X1, Prec1, X, Prec). '$parse_tokens2'(_, _, _, _, _) --> '$parse_tokens_error'([operator,expected,after,expression]). % '$parse_tokens_before_op'(Prec0, X, Prec) % parses the input until infix or postfix operator, % and returns X and Prec '$parse_tokens_before_op'(Prec0, X, Prec) --> [' '], !, '$parse_tokens_before_op'(Prec0, X, Prec). '$parse_tokens_before_op'(_, end_of_file, 0) --> [end_of_file], !. '$parse_tokens_before_op'(_, N, 0) --> [number(N)], !. '$parse_tokens_before_op'(_, N, 0) --> [atom('-')], [number(N0)], !, {N is -N0}. '$parse_tokens_before_op'(_, V, 0) --> [var(_,V)], !. '$parse_tokens_before_op'(_, S, 0) --> [string(S)], !. '$parse_tokens_before_op'(_, X, 0) --> ['('], !, '$parse_tokens'(X, 1201), '$parse_tokens_expect'(')'). '$parse_tokens_before_op'(_, X, 0) --> ['{'], !, '$parse_tokens_skip_spaces', '$parse_tokens_brace'(X). '$parse_tokens_before_op'(_, X, 0) --> ['['], !, '$parse_tokens_skip_spaces', '$parse_tokens_list'(X). '$parse_tokens_before_op'(_, X, 0) --> [atom(F)], ['('], !, '$parse_tokens_skip_spaces', '$parse_tokens_args'(Args), {X =.. [F|Args]}. '$parse_tokens_before_op'(Prec0, X, PrecOp) --> [atom(F)], {current_op(PrecOp,fx,F)}, {PrecOp =< Prec0}, '$parse_tokens_skip_spaces', '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_starter'(Next)}, {\+ '$parse_tokens_is_post_in_op'(Next)}, !, {Prec1 is PrecOp - 1}, '$parse_tokens'(Arg, Prec1), {functor(X, F, 1)}, {arg(1, X, Arg)}. '$parse_tokens_before_op'(Prec0, X, PrecOp) --> [atom(F)], {current_op(PrecOp,fy,F)}, {PrecOp =< Prec0}, '$parse_tokens_skip_spaces', '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_starter'(Next)}, {\+ '$parse_tokens_is_post_in_op'(Next)}, !, '$parse_tokens'(Arg, PrecOp), {functor(X, F, 1)}, {arg(1, X, Arg)}. '$parse_tokens_before_op'(_, A, 0) --> [atom(A)]. '$parse_tokens_brace'('{}') --> ['}'], !. '$parse_tokens_brace'(X) --> '$parse_tokens'(X1, 1201), '$parse_tokens_expect'('}'), {X = {X1}}. '$parse_tokens_list'('[]') --> [']'], !. '$parse_tokens_list'([X|Xs]) --> '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_list_rest'(Xs). '$parse_tokens_list_rest'(Xs) --> ['|'], !, '$parse_tokens'(Xs, 999), '$parse_tokens_expect'(']'). '$parse_tokens_list_rest'([X|Xs]) --> [','], !, '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_list_rest'(Xs). '$parse_tokens_list_rest'('[]') --> '$parse_tokens_expect'(']'). '$parse_tokens_args'('[]') --> [')'], !. '$parse_tokens_args'([X|Xs]) --> '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_args_rest'(Xs). '$parse_tokens_args_rest'([X|Xs]) --> [','], !, '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_args_rest'(Xs). '$parse_tokens_args_rest'('[]') --> '$parse_tokens_expect'(')'). % '$parse_tokens_post_in_op'(Prec0, X1, Prec1, X, Prec) % parses the input beginning from infix or postfix operator, % and returns X and Prec '$parse_tokens_post_in_ops'(Prec0, X1, Prec1, X, Prec) --> '$parse_tokens_skip_spaces', [Op], '$parse_tokens_op'(Op, Prec0, X1, Prec1, X2, Prec2), '$parse_tokens_post_in_ops'(Prec0, X2, Prec2, X, Prec). '$parse_tokens_post_in_ops'(Prec0, X, Prec, X, Prec) --> {Prec =< Prec0}. '$parse_tokens_op'(',', Prec0, X1, Prec1, X, PrecOp) --> !, '$parse_tokens_op'(atom(','), Prec0, X1, Prec1, X, PrecOp). '$parse_tokens_op'('|', Prec0, X1, Prec1, X, PrecOp) --> !, '$parse_tokens_op'(atom(';'), Prec0, X1, Prec1, X, PrecOp). '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, xf, Op)}, {PrecOp =< Prec0}, {Prec1 < PrecOp}, {functor(X, Op, 1)}, {arg(1, X, X1)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, yf, Op)}, {PrecOp =< Prec0}, {Prec1 =< PrecOp}, {functor(X, Op, 1)}, {arg(1, X, X1)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, xfx, Op)}, {PrecOp =< Prec0}, {Prec1 < PrecOp}, {Prec2 is PrecOp - 1}, '$parse_tokens'(X2, Prec2), !, {functor(X, Op, 2)}, {arg(1, X, X1)}, {arg(2, X, X2)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, xfy, Op)}, {PrecOp =< Prec0}, {Prec1 < PrecOp}, {Prec2 is PrecOp}, '$parse_tokens'(X2, Prec2), !, {functor(X, Op, 2)}, {arg(1, X, X1)}, {arg(2, X, X2)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, yfx, Op)}, {PrecOp =< Prec0}, {Prec1 =< PrecOp}, {Prec2 is PrecOp - 1}, '$parse_tokens'(X2, Prec2), !, {functor(X, Op, 2)}, {arg(1, X, X1)}, {arg(2, X, X2)}. '$parse_tokens_is_starter'(end_of_file). '$parse_tokens_is_starter'('('). '$parse_tokens_is_starter'('['). '$parse_tokens_is_starter'('{'). '$parse_tokens_is_starter'(number(_)). '$parse_tokens_is_starter'(atom(_)). '$parse_tokens_is_starter'(var(_,_)). '$parse_tokens_is_starter'(string(_)). '$parse_tokens_is_terminator'(')'). '$parse_tokens_is_terminator'(']'). '$parse_tokens_is_terminator'('}'). '$parse_tokens_is_terminator'('.'). '$parse_tokens_is_post_in_op'(',') :- !. '$parse_tokens_is_post_in_op'('|') :- !. '$parse_tokens_is_post_in_op'(atom(Op)) :- current_op(_, Type, Op), '$parse_tokens_post_in_type'(Type), !. '$parse_tokens_post_in_type'(xfx). '$parse_tokens_post_in_type'(xfy). '$parse_tokens_post_in_type'(yfx). '$parse_tokens_post_in_type'(xf). '$parse_tokens_post_in_type'(yf). '$parse_tokens_expect'(Token) --> '$parse_tokens_skip_spaces', [Token], !. '$parse_tokens_expect'(Token) --> '$parse_tokens_error'([Token,expected]). '$parse_tokens_skip_spaces' --> [' '], !, '$parse_tokens_skip_spaces'. '$parse_tokens_skip_spaces' --> []. '$parse_tokens_peep_next'(Next, S, S) :- S = [Next|_]. '$parse_tokens_error'(Message, S0, _S) :- clause('$tokens'(Tokens), _), raise_exception(syntax_error(Message, at(Tokens))), fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term input/output (write) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public write/2. :- public writeq/2. :- public write_canonical/2. :- public write_term/3. write(S_or_a, Term) :- write_term(S_or_a, Term, [numbervars(true)]). writeq(S_or_a, Term) :- write_term(S_or_a, Term, [quoted(true),numbervars(true)]). write_canonical(S_or_a, Term) :- write_term(S_or_a, Term, [quoted(true),ignore_ops(true)]). write_term(S_or_a, Term, Options) :- '$write_term'(S_or_a, Term, Options), fail. write_term(_, _, _). '$write_term'(S_or_a, Term, Options) :- '$write_term0'(Term, 1200, punct, _, Options, S_or_a), !. '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- var(Term), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$fast_write'(S_or_a, Term). '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- java(Term), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$fast_write'(S_or_a, Term). '$write_term0'(Term, _Prec, Type0, alpha, Style, S_or_a) :- Term = '$VAR'(VN), integer(VN), VN >= 0, '$builtin_member'(numbervars(true), Style), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$write_VAR'(VN, S_or_a). '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- number(Term), Term < 0, !, '$write_space_if_needed'(Type0, symbol, S_or_a), '$fast_write'(S_or_a, Term). '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- number(Term), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$fast_write'(S_or_a, Term). %'$write_term0'(Term, Prec, Type0, punct, _, S_or_a) :- % atom(Term), % current_op(PrecOp, OpType, Term), % (OpType = fx ; OpType = fy), % PrecOp =< Prec, % !, % '$write_space_if_needed'(Type0, punct, S_or_a), % put_char(S_or_a, '('), % '$write_atom'(Term, punct, _, _, S_or_a), % put_char(S_or_a, ')'). '$write_term0'(Term, _Prec, Type0, Type, Style, S_or_a) :- atom(Term), !, '$write_atom'(Term, Type0, Type, Style, S_or_a). '$write_term0'(Term, Prec, Type0, Type, Style, S_or_a) :- \+ '$builtin_member'(ignore_ops(true), Style), '$write_is_operator'(Term, Op, Args, OpType), !, '$write_term_op'(Op, OpType, Args, Prec, Type0, Type, Style, S_or_a). '$write_term0'(Term, _Prec, Type0, punct, Style, S_or_a) :- Term = [_|_], \+ '$builtin_member'(ignore_ops(true), Style), !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, '['), '$write_term_list_args'(Term, punct, _, Style, S_or_a), put_char(S_or_a, ']'). '$write_term0'(Term, _Prec, Type0, _Type, Style, S_or_a) :- Term = {Term1}, \+ '$builtin_member'(ignore_ops(true), Style), !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, '{'), '$write_term0'(Term1, 1200, punct, _, Style, S_or_a), put_char(S_or_a, '}'). '$write_term0'(Term, _Prec, Type0, punct, Style, S_or_a) :- Term =.. [F|Args], '$write_atom'(F, Type0, _, Style, S_or_a), put_char(S_or_a, '('), '$write_term_args'(Args, punct, _, Style, S_or_a), put_char(S_or_a, ')'). '$write_space_if_needed'(punct, _, _ ) :- !. '$write_space_if_needed'(X, X, S_or_a) :- !, put_char(S_or_a, ' '). '$write_space_if_needed'(other, alpha, S_or_a) :- !, put_char(S_or_a, ' '). '$write_space_if_needed'(_, _, _ ). '$write_VAR'(VN, S_or_a) :- VN < 26, !, Letter is VN mod 26 + "A", put_code(S_or_a, Letter). '$write_VAR'(VN, S_or_a) :- Letter is VN mod 26 + "A", put_code(S_or_a, Letter), Rest is VN//26, '$fast_write'(S_or_a, Rest). '$write_atom'(Atom, Type0, Type, Style, S_or_a) :- '$builtin_member'(quoted(true), Style), !, '$atom_type'(Atom, Type), '$write_space_if_needed'(Type0, Type, S_or_a), '$fast_writeq'(S_or_a, Atom). '$write_atom'(Atom, Type0, Type, _, S_or_a) :- '$atom_type'(Atom, Type), '$write_space_if_needed'(Type0, Type, S_or_a), '$fast_write'(S_or_a, Atom). '$atom_type'(X, alpha ) :- '$atom_type0'(X, 0), !. '$atom_type'(X, symbol) :- '$atom_type0'(X, 1), !. '$atom_type'(X, punct ) :- '$atom_type0'(X, 2), !. '$atom_type'(X, other ) :- '$atom_type0'(X, 3), !. '$write_is_operator'(Term, Op, Args, OpType) :- functor(Term, Op, Arity), '$write_op_type'(Arity, OpType), current_op(_, OpType, Op), Term =.. [_|Args], !. '$write_op_type'(1, fx). '$write_op_type'(1, fy). '$write_op_type'(1, xf). '$write_op_type'(1, yf). '$write_op_type'(2, xfx). '$write_op_type'(2, xfy). '$write_op_type'(2, yfx). '$write_term_op'(Op, OpType, Args, Prec, Type0, punct, Style, S_or_a) :- current_op(PrecOp, OpType, Op), PrecOp > Prec, !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, '('), '$write_term_op1'(Op, OpType, Args, PrecOp, punct, _, Style, S_or_a), put_char(S_or_a, ')'). '$write_term_op'(Op, OpType, Args, _Prec, Type0, Type, Style, S_or_a) :- current_op(PrecOp, OpType, Op), '$write_term_op1'(Op, OpType, Args, PrecOp, Type0, Type, Style, S_or_a). '$write_term_op1'(Op, fx, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, '$write_atom'(Op, Type0, Type1, Style, S_or_a), Prec1 is PrecOp - 1, '$write_term0'(A1, Prec1, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, fy, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, '$write_atom'(Op, Type0, Type1, Style, S_or_a), Prec1 is PrecOp, '$write_term0'(A1, Prec1, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, xf, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp - 1, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_atom'(Op, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, yf, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_atom'(Op, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, xfx, [A1,A2], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp - 1, Prec2 is PrecOp - 1, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_term_infix_op'(Op, Type1, Type2, Style, S_or_a), '$write_term0'(A2, Prec2, Type2, Type, Style, S_or_a). '$write_term_op1'(Op, xfy, [A1,A2], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp - 1, Prec2 is PrecOp, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_term_infix_op'(Op, Type1, Type2, Style, S_or_a), '$write_term0'(A2, Prec2, Type2, Type, Style, S_or_a). '$write_term_op1'(Op, yfx, [A1,A2], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp, Prec2 is PrecOp - 1, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_term_infix_op'(Op, Type1, Type2, Style, S_or_a), '$write_term0'(A2, Prec2, Type2, Type, Style, S_or_a). '$write_term_infix_op'(',', Type0, punct, _, S_or_a) :- !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, ','). '$write_term_infix_op'(Op, Type0, Type, Style, S_or_a) :- '$write_atom'(Op, Type0, Type, Style, S_or_a). '$write_term_list_args'([A|As], Type0, Type, Style, S_or_a) :- nonvar(As), As = [_|_], !, '$write_term0'(A, 999, Type0, Type1, Style, S_or_a), '$write_space_if_needed'(Type1, punct, S_or_a), put_char(S_or_a, ','), '$write_term_list_args'(As, punct, Type, Style, S_or_a). '$write_term_list_args'([A|As], Type0, Type, Style, S_or_a) :- nonvar(As), As = [], !, '$write_term0'(A, 999, Type0, Type, Style, S_or_a). '$write_term_list_args'([A|As], Type0, Type, Style, S_or_a) :- '$write_term0'(A, 999, Type0, Type1, Style, S_or_a), '$write_space_if_needed'(Type1, punct, S_or_a), put_char(S_or_a, '|'), '$write_term0'(As, 999, punct, Type, Style, S_or_a). '$write_term_args'([], Type, Type, _, _) :- !. '$write_term_args'([A], Type0, Type, Style, S_or_a) :- !, '$write_term0'(A, 999, Type0, Type, Style, S_or_a). '$write_term_args'([A|As], Type0, Type, Style, S_or_a) :- !, '$write_term0'(A, 999, Type0, Type1, Style, S_or_a), '$write_space_if_needed'(Type1, punct, S_or_a), put_char(S_or_a, ','), '$write_term_args'(As, punct, Type, Style, S_or_a). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term input/output (others) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public op/3. :- public current_op/3. :- dynamic '$current_operator'/3. op(Priority, Op_specifier, Operator) :- integer(Priority), 0 =)). '$current_operator'( 1200, fx, (:-)). '$current_operator'( 1200, fx, (?-)). '$current_operator'( 1150, fx, (package)). '$current_operator'( 1150, fx, (import)). '$current_operator'( 1150, fx, (public)). '$current_operator'( 1150, fx, (dynamic)). '$current_operator'( 1150, fx, (meta_predicate)). '$current_operator'( 1150, fx, (mode)). '$current_operator'( 1150, fx, (multifile)). '$current_operator'( 1150, fx, (block)). '$current_operator'( 1100, xfy, (;)). '$current_operator'( 1050, xfy, (->)). '$current_operator'( 1000, xfy, (',')). '$current_operator'( 900, fy, (\+)). '$current_operator'( 700, xfx, (=)). '$current_operator'( 700, xfx, (\=)). '$current_operator'( 700, xfx, (==)). '$current_operator'( 700, xfx, (\==)). '$current_operator'( 700, xfx, (@<)). '$current_operator'( 700, xfx, (@>)). '$current_operator'( 700, xfx, (@=<)). '$current_operator'( 700, xfx, (@>=)). '$current_operator'( 700, xfx, (=..)). '$current_operator'( 700, xfx, (is)). '$current_operator'( 700, xfx, (=:=)). '$current_operator'( 700, xfx, (=\=)). '$current_operator'( 700, xfx, (<)). '$current_operator'( 700, xfx, (>)). '$current_operator'( 700, xfx, (=<)). '$current_operator'( 700, xfx, (>=)). '$current_operator'( 550, xfy, (:)). '$current_operator'( 500, yfx, (+)). '$current_operator'( 500, yfx, (-)). '$current_operator'( 500, yfx, (#)). '$current_operator'( 500, yfx, (/\)). '$current_operator'( 500, yfx, (\/)). '$current_operator'( 500, fx, (+)). '$current_operator'( 400, yfx, (*)). '$current_operator'( 400, yfx, (/)). '$current_operator'( 400, yfx, (//)). '$current_operator'( 400, yfx, (mod)). '$current_operator'( 400, yfx, (rem)). '$current_operator'( 400, yfx, (<<)). '$current_operator'( 400, yfx, (>>)). '$current_operator'( 300, xfx, (~)). '$current_operator'( 200, xfx, (**)). '$current_operator'( 200, xfy, (^)). '$current_operator'( 200, fy, (\)). '$current_operator'( 200, fy, (-)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Logic and control %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (\+)/1. :- public once/1. :- public repeat/0. \+(G) :- call(G), !, fail. \+(_). repeat. repeat :- repeat. once(G) :- call(G), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Atomic term processing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %:- public atom_length/2. written in Java %:- public atom_concat/3. written in Java :- public sub_atom/5. %:- public atom_chars/2, atom_codes/2. written in Java %:- public char_code/2. written in Java %:- public number_chars/2, number_codes/2. written in Java :- public name/2. %:- public regex_compile/2. written in Java %:- public regex_match/3. written in Java :- public regex_matches/3. :- public regex_matches/2. sub_atom(Atom, Before, Length, After, Sub_atom) :- atom_concat(AtomL, X, Atom), atom_length(AtomL, Before), atom_concat(Sub_atom, AtomR, X), atom_length(Sub_atom, Length), atom_length(AtomR, After). name(Constant, Chars) :- nonvar(Constant), ( number(Constant) -> number_codes(Constant, Chars) ; atomic(Constant) -> atom_codes(Constant, Chars) ; illarg(type(atomic), name(Constant,Chars), 1) ). name(Constant, Chars) :- var(Constant), ( number_codes(Constant0, Chars) -> Constant = Constant0 ; atom_codes(Constant0, Chars) -> Constant = Constant0 ; illarg(type(list(char)), name(Constant,Chars), 2) ). regex_matches(_, [], _) :- !, fail. regex_matches(Pattern, List, Result) :- List = [_ | _], !, regex_list(Pattern, List, Result). regex_matches(Pattern, String, Result) :- atom(String), regex_compile(Pattern, Matcher), regex_match(Matcher, String, Result). regex_matches(Pattern, String) :- once(regex_matches(Pattern, String, _)). regex_list(Pattern, [H | _ ], Result) :- regex_matches(Pattern, H, Result). regex_list(Pattern, [_ | Ls], Result) :- regex_list(Pattern, Ls, Result). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Implementation defined hooks %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public set_prolog_flag/2. :- public current_prolog_flag/2. set_prolog_flag(Flag, Value) :- var(Flag), !, illarg(var, set_prolog_flag(Flag,Value), 1). set_prolog_flag(Flag, Value) :- var(Value), !, illarg(var, set_prolog_flag(Flag,Value), 2). set_prolog_flag(Flag, Value) :- atom(Flag), !, '$set_prolog_flag0'(Flag, Value). set_prolog_flag(Flag, Value) :- illarg(type(atom), set_prolog_flag(Flag,Value), 1). '$set_prolog_flag0'(Flag, Value) :- '$prolog_impl_flag'(Flag, Mode, changeable(YN)), !, '$set_prolog_flag0'(YN, Flag, Value, Mode). '$set_prolog_flag0'(Flag, Value) :- illarg(domain(atom,prolog_flag), set_prolog_flag(Flag,Value), 1). '$set_prolog_flag0'(no, Flag, Value, _) :- !, illarg(permission(modify,flag,Flag,_), set_prolog_flag(Flag,Value), _). '$set_prolog_flag0'(_, Flag, Value, Mode) :- '$builtin_member'(Value, Mode), !, '$set_prolog_impl_flag'(Flag, Value). '$set_prolog_flag0'(_, Flag, Value, _) :- illarg(domain(atom,flag_value), set_prolog_flag(Flag,Value), 2). current_prolog_flag(Flag, Term) :- var(Flag), !, '$prolog_impl_flag'(Flag, _, _), '$get_prolog_impl_flag'(Flag, Term). current_prolog_flag(Flag, Term) :- atom(Flag), !, ( '$prolog_impl_flag'(Flag, _, _) -> '$get_prolog_impl_flag'(Flag, Term) ; illarg(domain(atom,prolog_flag), current_prolog_flag(Flag,Term), 1) ). current_prolog_flag(Flag, Term) :- illarg(type(atom), current_prolog_flag(Flag,Term), 1). '$prolog_impl_flag'(debug, [on,off], changeable(yes)). '$prolog_impl_flag'(max_arity, _, changeable(no)). :- public halt/0. :- public abort/0. halt :- halt(0). abort :- raise_exception('Execution aborted'). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DCG %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public 'C'/3, expand_term/2. 'C'([X|S], X, S). expand_term(Dcg, Cl) :- var(Dcg), !, Dcg = Cl. expand_term(Dcg, Cl) :- '$dcg_expansion'(Dcg, Cl0), !, Cl0 = Cl. expand_term(Dcg, Dcg). '$dcg_expansion'(Dcg, Cl) :- var(Dcg), !, Dcg = Cl. '$dcg_expansion'((Head --> B), (H1 :- G1, G2)) :- nonvar(Head), Head = (H, List), List = [_|_], !, '$dcg_translation_atom'(H, H1, S0, S1), '$dcg_translation'(B, G1, S0, S), '$dcg_translation'(List, G2, S1, S). '$dcg_expansion'((H --> B), (H1 :- B1)) :- '$dcg_translation_atom'(H, H1, S0, S), '$dcg_translation'(B, B1, S0, S). '$dcg_translation_atom'(X, phrase(X,S0,S), S0, S) :- var(X), !. '$dcg_translation_atom'(M:X, M:X1, S0, S) :- !, '$dcg_translation_atom'(X, X1, S0, S). '$dcg_translation_atom'(X, X1, S0, S) :- X =.. [F|As], '$builtin_append'(As, [S0,S], As1), X1 =.. [F|As1]. '$dcg_translation'(X, Y, S0, S) :- '$dcg_trans'(X, Y0, T, S0, S), '$dcg_trans0'(Y0, Y, T, S0, S). '$dcg_trans0'(Y, Y, T, S0, T) :- T \== S0, !. '$dcg_trans0'(Y0, Y, T, _, S) :- '$dcg_concat'(Y0, S=T, Y). '$dcg_concat'(X, Y, Z) :- X == true, !, Z = Y. '$dcg_concat'(X, Y, Z) :- Y == true, !, Z = X. '$dcg_concat'(X, Y, (X,Y)). '$dcg_trans'(X, X1, S, S0, S) :- var(X), !, '$dcg_translation_atom'(X, X1, S0, S). '$dcg_trans'(M:X, M:Y, T, S0, S) :- !, '$dcg_trans'(X, Y, T, S0, S). '$dcg_trans'([], true, S0, S0, _) :- !. '$dcg_trans'([X|Y], Z, T, S0, S) :- !, '$dcg_trans'(Y, Y1, T, S1, S), '$dcg_concat'('C'(S0,X,S1), Y1, Z). '$dcg_trans'(\+X, (X1 -> fail; S=S0), S, S0, S) :- !, '$dcg_trans'(X, X1, S1, S0, S1). '$dcg_trans'((X,Y), Z, T, S0, S) :- !, '$dcg_trans'(X, X1, S1, S0, S1), '$dcg_trans'(Y, Y1, T, S1, S), '$dcg_concat'(X1, Y1, Z). '$dcg_trans'((X->Y), (X1->Y1), T, S0, S) :- !, '$dcg_trans'(X, X1, S1, S0, S1), '$dcg_trans'(Y, Y1, T, S1, S). '$dcg_trans'((X;Y), (X1;Y1), S, S0, S) :- !, '$dcg_translation'(X, X1, S0, S), '$dcg_translation'(Y, Y1, S0, S). '$dcg_trans'(!, !, S0, S0, _) :- !. '$dcg_trans'({G}, call(G), S0, S0, _) :- var(G), !. '$dcg_trans'({G}, G, S0, S0, _) :- !. '$dcg_trans'(X, X1, S, S0, S) :- '$dcg_translation_atom'(X, X1, S0, S). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Hash creation and control %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public new_hash/1. :- public hash_map/2. :- public hash_exists/1. new_hash(Hash) :- new_hash(Hash, []). hash_map(H_or_a, List) :- hash_keys(H_or_a, Ks0), sort(Ks0, Ks), hash_map(Ks, List, H_or_a). hash_map([], [], _) :- !. hash_map([K|Ks], [(K,V)|Ls], H_or_a) :- hash_get(H_or_a, K, V), hash_map(Ks, Ls, H_or_a). hash_exists(Alias) :- atom(Alias), '$get_hash_manager'(HM), hash_contains_key(HM, Alias). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Prolog interpreter %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- op(1170, xfx, (:-)). :- op(1170, xfx, (-->)). :- op(1170, fx, (:-)). :- op(1170, fx, (?-)). :- op(1150, fx, (package)). :- op(1150, fx, (import)). :- op(1150, fx, (public)). :- op(1150, fx, (dynamic)). :- op(1150, fx, (meta_predicate)). :- op(1150, fx, (mode)). :- op(1150, fx, (multifile)). :- op(1150, fx, (block)). :- public consult_stream/1. :- dynamic '$consulted_file'/1. :- dynamic '$consulted_import'/2. :- dynamic '$consulted_package'/1. :- dynamic '$consulted_predicate'/3. %%% Read Program consult_stream(File, In) :- '$consult_init'(File), repeat, read(In, Cl), '$consult_clause'(Cl), Cl == end_of_file, !. '$consult_init'(File) :- retractall('$consulted_file'(_)), retractall('$consulted_package'(_)), retractall('$consulted_import'(File, _)), retract('$consulted_predicate'(P,PI,File)), abolish(P:PI), fail. '$consult_init'(File) :- assertz('$consulted_file'(File)), assertz('$consulted_package'(user)). '$consult_clause'(end_of_file ) :- !. '$consult_clause'((:- module(P,_)) ) :- !, '$assert_consulted_package'(P). '$consult_clause'((:- package P) ) :- !, '$assert_consulted_package'(P). '$consult_clause'((:- import P) ) :- !, '$assert_consulted_import'(P). '$consult_clause'((:- dynamic _) ) :- !. '$consult_clause'((:- public _) ) :- !. '$consult_clause'((:- meta_predicate _)) :- !. '$consult_clause'((:- mode _) ) :- !. '$consult_clause'((:- multifile _) ) :- !. '$consult_clause'((:- block _) ) :- !. '$consult_clause'((:- G) ) :- !, clause('$consulted_package'(P), _), once(P:G). '$consult_clause'(Clause0) :- '$consult_preprocess'(Clause0, Clause), '$consult_cls'(Clause). '$assert_consulted_package'(P) :- clause('$consulted_package'(P), _), !. '$assert_consulted_package'(P) :- retractall('$consulted_package'(_)), assertz('$consulted_package'(P)). '$assert_consulted_import'(P) :- clause('$consulted_file'(File), _), assertz('$consulted_import'(File, P)). '$consult_preprocess'(Clause0, Clause) :- expand_term(Clause0, Clause). '$consult_cls'((H :- G)) :- !, '$assert_consulted_clause'((H :- G)). '$consult_cls'(H) :- '$assert_consulted_clause'((H :- true)). '$assert_consulted_clause'(Clause) :- Clause = (H :- _), functor(H, F, A), clause('$consulted_file'(File), _), clause('$consulted_package'(P), _), assertz(P:Clause), assertz('$consulted_predicate'(P,F/A,File)), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Misc %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public reverse/2. :- public length/2. :- public numbervars/3. :- public statistics/2. reverse(Xs, Zs) :- reverse(Xs, [], Zs). reverse([], Zs, Zs). reverse([X|Xs], Tmp, Zs) :- reverse(Xs, [X|Tmp], Zs). length(L, N) :- var(N), !, '$length'(L, 0, N). length(L, N) :- '$length0'(L, 0, N). '$length'([], I, I). '$length'([_|L], I0, I) :- I1 is I0+1, '$length'(L, I1, I). '$length0'([], I, I) :- !. '$length0'([_|L], I0, I) :- I0 < I, I1 is I0+1, '$length0'(L, I1, I). numbervars(X, VI, VN) :- integer(VI), VI >= 0, !, '$numbervars'(X, VI, VN). '$numbervars'(X, VI, VN) :- var(X), !, X = '$VAR'(VI), % This structure is checked in write VN is VI + 1. '$numbervars'(X, VI, VI) :- atomic(X), !. '$numbervars'(X, VI, VI) :- java(X), !. '$numbervars'(X, VI, VN) :- functor(X, _, N), '$numbervars_str'(1, N, X, VI, VN). '$numbervars_str'(I, I, X, VI, VN) :- !, arg(I, X, A), '$numbervars'(A, VI, VN). '$numbervars_str'(I, N, X, VI, VN) :- arg(I, X, A), '$numbervars'(A, VI, VN1), I1 is I + 1, '$numbervars_str'(I1, N, X, VN1, VN). statistics(Key, Value) :- nonvar(Key), '$statistics_mode'(Key), !, '$statistics'(Key, Value). statistics(Key, Value) :- findall(M, '$statistics_mode'(M), Domain), illarg(domain(atom,Domain), statistics(Key,Value), 1). '$statistics_mode'(runtime). '$statistics_mode'(trail). '$statistics_mode'(choice). illarg(Msg, Goal, ArgNo) :- var(Msg), !, illarg(var, Goal, ArgNo). illarg(var, Goal, ArgNo) :- raise_exception(instantiation_error(Goal, ArgNo)). illarg(type(Type), Goal, ArgNo) :- arg(ArgNo, Goal, Arg), ( nonvar(Arg) -> Error = type_error(Goal,ArgNo,Type,Arg) ; Error = instantiation_error(Goal,ArgNo) ), raise_exception(Error). illarg(domain(Type,ExpDomain), Goal, ArgNo) :- arg(ArgNo, Goal, Arg), ( '$match_type'(Type, Arg) -> Error = domain_error(Goal,ArgNo,ExpDomain,Arg) ; nonvar(Arg) -> Error = type_error(Goal,ArgNo,Type,Arg) ; Error = instantiation_error(Goal,ArgNo) ), raise_exception(Error). illarg(existence(ObjType,Culprit,Message), Goal, ArgNo) :- raise_exception(existence_error(Goal,ArgNo,ObjType,Culprit,Message)). illarg(permission(Operation, ObjType, Culprit, Message), Goal, _) :- raise_exception(permission_error(Goal,Operation,ObjType,Culprit,Message)). illarg(representation(Flag), Goal, ArgNo) :- raise_exception(representation_error(Goal,ArgNo,Flag)). illarg(evaluation(Type), Goal, ArgNo) :- raise_exception(evaluation_error(Goal,ArgNo,Type)). illarg(syntax(Type,Culprit,Message), Goal, ArgNo) :- raise_exception(syntax_error(Goal,ArgNo,Type,Culprit,Message)). illarg(system(Message), _, _) :- raise_exception(system_error(Message)). illarg(internal(Message), _, _) :- raise_exception(internal_error(Message)). illarg(java(Exception), Goal, ArgNo) :- raise_exception(java_error(Goal,ArgNo,Exception)). illarg(Msg, _, _) :- raise_exception(Msg). '$match_type'(term, _). '$match_type'(variable, X) :- var(X). '$match_type'(atom, X) :- atom(X). '$match_type'(atomic, X) :- atomic(X). '$match_type'(byte, X) :- integer(X), 0 =< X, X =< 255. '$match_type'(in_byte, X) :- integer(X), -1 =< X, X =< 255. '$match_type'(character, X) :- atom(X), atom_length(X, 1). '$match_type'(in_character, X) :- (X == 'end_of_file' ; '$match_type'(character,X)). '$match_type'(number, X) :- number(X). '$match_type'(integer, X) :- integer(X). '$match_type'(float, X) :- float(X). '$match_type'(callable, X) :- callable(X). '$match_type'(compound, X) :- compound(X). '$match_type'(list, X) :- nonvar(X), (X = [] ; X = [_|_]). '$match_type'(java, X) :- java(X). '$match_type'(stream, X) :- (java(X, 'java.io.PushbackReader') ; java(X, 'java.io.PrintWriter')). '$match_type'(stream_or_alias, X) :- (atom(X) ; '$match_type'(stream, X)). '$match_type'(hash, X) :- java(X, 'com.googlecode.prolog_cafe.lang.HashtableOfTerm'). '$match_type'(hash_or_alias,X) :- (atom(X) ; '$match_type'(hash, X)). '$match_type'(predicate_indicator, X) :- nonvar(X), X = P:F/A, atom(P), atom(F), integer(A). %'$match_type'(evaluable, X). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Utilities %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$builtin_append'([], Zs, Zs). '$builtin_append'([X|Xs], Ys, [X|Zs]) :- '$builtin_append'(Xs, Ys, Zs). '$builtin_member'(X, [X|_]). '$builtin_member'(X, [_|L]) :- '$builtin_member'(X, L). '$member_in_reverse'(X, [_|L]) :- '$member_in_reverse'(X, L). '$member_in_reverse'(X, [X|_]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % END - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - src/builtin/builtins.pl [1:1896]: - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Builtin Predicates of Prolog Cafe % % Mutsunori Banbara (banbara@kobe-u.ac.jp) % Naoyuki Tamura (tamura@kobe-u.ac.jp) % Kobe University %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- op(1150, fx, (package)). package(_). :- package 'com.googlecode.prolog_cafe.builtin'. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Control constructs %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public true/0, otherwise/0. :- public fail/0, false/0. :- public (!)/0. :- public (^)/2. :- public (',')/2. :- public (;)/2. :- public (->)/2. :- public call/1. true. otherwise. fail :- fail. false :- fail. !. (_ ^ G) :- call(G). (P, Q) :- call(P), call(Q). (P; _Q) :- P \= (_ -> _), call(P). (_P; Q) :- Q \= (_ -> _), call(Q). (IF -> THEN) :- call(IF), !, call(THEN). (IF -> THEN; _ELSE) :- call(IF), !, call(THEN). (_IF -> _THEN; ELSE) :- call(ELSE). call(Term) :- '$get_current_B'(Cut), '$meta_call'(Term, user, Cut, 0, interpret). '$meta_call'(X, _, _, _, _) :- var(X), !, illarg(var, call(X), 1). '$meta_call'(X, _, _, _, _) :- closure(X), !, '$call_closure'(X). '$meta_call'(true, _, _, _, _) :- !. '$meta_call'(_^X, P, Cut, Depth, Mode) :- !, '$meta_call'(X, P, Cut, Depth, Mode). '$meta_call'(P:X, _, Cut, Depth, Mode) :- !, '$meta_call'(X, P, Cut, Depth, Mode). '$meta_call'(!, _, no, _, _) :- !, illarg(context(if,cut), !, 0). '$meta_call'(!, _, Cut, _, _) :- !, '$cut'(Cut). '$meta_call'((X,Y), P, Cut, Depth, Mode) :- !, '$meta_call'(X, P, Cut, Depth, Mode), '$meta_call'(Y, P, Cut, Depth, Mode). '$meta_call'((X->Y;Z), P, Cut, Depth, Mode) :- !, ( '$meta_call'(X, P, no, Depth, Mode) -> '$meta_call'(Y, P, Cut, Depth, Mode) ; '$meta_call'(Z, P, Cut, Depth, Mode) ). '$meta_call'((X->Y), P, Cut, Depth, Mode) :- !, ( '$meta_call'(X, P, no, Depth, Mode) -> '$meta_call'(Y, P, Cut, Depth, Mode) ). '$meta_call'((X;Y), P, Cut, Depth, Mode) :- !, ( '$meta_call'(X, P, Cut, Depth, Mode) ; '$meta_call'(Y, P, Cut, Depth, Mode) ). '$meta_call'(\+(X), P, _, Depth, Mode) :- !, \+ '$meta_call'(X, P, no, Depth, Mode). '$meta_call'(findall(X,Y,Z), P, Cut, Depth, Mode) :- !, findall(X, '$meta_call'(Y, P, Cut, Depth, Mode), Z). '$meta_call'(bagof(X,Y,Z), P, Cut, Depth, Mode) :- !, bagof(X, '$meta_call'(Y, P, Cut, Depth, Mode), Z). '$meta_call'(setof(X,Y,Z), P, Cut, Depth, Mode) :- !, setof(X, '$meta_call'(Y, P, Cut, Depth, Mode), Z). '$meta_call'(once(X), P, Cut, Depth, Mode) :- !, once('$meta_call'(X, P, Cut, Depth, Mode)). '$meta_call'(on_exception(X,Y,Z), P, Cut, Depth, Mode) :- !, on_exception(X, '$meta_call'(Y, P, Cut, Depth, Mode), '$meta_call'(Z, P, Cut, Depth, Mode)). '$meta_call'(catch(X,Y,Z), P, Cut, Depth, Mode) :- !, catch('$meta_call'(X, P, Cut, Depth, Mode), Y, '$meta_call'(Z, P, Cut, Depth, Mode)). %'$meta_call'(freeze(X,Y), P, Cut, Depth, Mode) :- !, ??? % freeze(X, '$meta_call'(Y, P, Cut, Depth, Mode)). '$meta_call'(clause(X, Y), P, _, _, _) :- !, clause(P:X, Y). '$meta_call'(assert(X), P, _, _, _) :- !, assertz(P:X). '$meta_call'(assertz(X), P, _, _, _) :- !, assertz(P:X). '$meta_call'(asserta(X), P, _, _, _) :- !, asserta(P:X). '$meta_call'(retract(X), P, _, _, _) :- !, retract(P:X). '$meta_call'(abolish(X), P, _, _, _) :- !, abolish(P:X). '$meta_call'(retractall(X), P, _, _, _) :- !, retractall(P:X). '$meta_call'(X, P, _, Depth, Mode) :- atom(P), callable(X), !, '$meta_call'(Mode, Depth, P, X). '$meta_call'(X, P, _, _, _) :- illarg(type(callable), call(P:X), 1). '$meta_call'(trace, Depth, P, X) :- !, functor(X, F, A), '$call'('com.googlecode.prolog_cafe.builtin', '$trace_goal'(X, P, F/A, Depth)). '$meta_call'(interpret, Depth, P, X) :- functor(X, F, A), '$call_internal'(X, P, F/A, Depth, interpret). '$call_internal'(X, P, FA, Depth, Mode) :- '$new_internal_database'(P), hash_contains_key(P, FA), !, '$get_current_B'(Cut), Depth1 is Depth + 1, clause(P:X, Body), '$meta_call'(Body, P, Cut, Depth1, Mode). '$call_internal'(X, P, _, _, _) :- '$call'(P, X). :- public catch/3, throw/1. :- public on_exception/3. catch(Goal, Catch, Recovery) :- on_exception(Catch, Goal, Recovery). throw(Msg) :- raise_exception(Msg). on_exception(Catch, Goal, Recovery) :- callable(Goal), !, '$on_exception'(Catch, Goal, Recovery). on_exception(Catch, Goal, Recovery) :- illarg(type(callable), on_exception(Catch,Goal,Recovery), 2). '$on_exception'(_Catch, Goal, _Recovery) :- '$set_exception'('$none'), '$begin_exception'(L), call(Goal), '$end_exception'(L). '$on_exception'(Catch, _Goal, Recovery) :- '$get_exception'(Msg), Msg \== '$none', '$catch_and_throw'(Msg, Catch, Recovery). '$catch_and_throw'(Msg, Msg, Recovery) :- !, '$set_exception'('$none'), call(Recovery). '$catch_and_throw'(Msg, _, _) :- raise_exception(Msg). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term unification %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (=)/2, '$unify'/2. :- public (\=)/2, '$not_unifiable'/2. X = Y :- X = Y. '$unify'(X, Y) :- '$unify'(X, Y). X \= Y :- X \= Y. '$not_unifiable'(X, Y) :- '$not_unifiable'(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Type testing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public var/1, atom/1, integer/1, float/1, atomic/1, compound/1, nonvar/1, number/1. :- public java/1, java/2, closure/1. :- public ground/1, callable/1. var(X) :- var(X). atom(X) :- atom(X). integer(X) :- integer(X). float(X) :- float(X). atomic(X) :- atomic(X). nonvar(X) :- nonvar(X). number(X) :- number(X). java(X) :- java(X). java(X, Y) :- java(X, Y). closure(X) :- closure(X). ground(X) :- ground(X). compound(X) :- nonvar(X), functor(X, _, A), A > 0. callable(X) :- atom(X), !. callable(X) :- compound(X), !. callable(X) :- closure(X). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term comparison %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (==)/2, '$equality_of_term'/2. :- public (\==)/2, '$inequality_of_term'/2. :- public (@<)/2, '$before'/2. :- public (@>)/2, '$after'/2. :- public (@=<)/2, '$not_after'/2. :- public (@>=)/2, '$not_before'/2. :- public (?=)/2, '$identical_or_cannot_unify'/2. :- public compare/3. % :- public sort/2. witten in Java % :- public keysort/2. witten in Java % :- public merge/3. X == Y :- X == Y. '$equality_of_term'(X, Y) :- '$equality_of_term'(X, Y). X \== Y :- X \== Y. '$inequality_of_term'(X, Y) :- '$inequality_of_term'(X, Y). X @< Y :- X @< Y. '$before'(X, Y) :- '$before'(X, Y). X @> Y :- X @> Y. '$after'(X, Y) :- '$after'(X, Y). X @=< Y :- X @=< Y. '$not_after'(X, Y) :- '$not_after'(X, Y). X @>= Y :- X @>= Y. '$not_before'(X, Y) :- '$not_before'(X, Y). ?=(X, Y) :- ?=(X, Y). '$identical_or_cannot_unify'(X, Y) :- '$identical_or_cannot_unify'(X, Y). compare(Op, X, Y) :- '$compare0'(Op0, X, Y), '$map_compare_op'(Op0, Op). '$map_compare_op'(Op0, Op) :- Op0 =:= 0, !, Op = (=). '$map_compare_op'(Op0, Op) :- Op0 < 0, !, Op = (<). '$map_compare_op'(Op0, Op) :- Op0 > 0, !, Op = (>). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term creation and decomposition %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %:- public arg/3. --> written in Java %:- public functor/3. --> written in Java :- public (=..)/2. :- public copy_term/2. Term =.. List :- Term =.. List. copy_term(X, Y) :- copy_term(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Arithmetic evaluation %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (is)/2. :- public '$abs'/2, '$asin'/2, '$acos'/2, '$atan'/2. :- public '$bitwise_conj'/3, '$bitwise_disj'/3, '$bitwise_exclusive_or'/3, '$bitwise_neg'/2. :- public '$ceil'/2, '$cos'/2. :- public '$degrees'/2. :- public '$exp'/2. :- public '$float'/2, '$float_integer_part'/2, '$float_fractional_part'/2, '$float_quotient'/3, '$floor'/2. :- public '$int_quotient'/3. :- public '$log'/2. :- public '$max'/3, '$min'/3, '$minus'/3, '$mod'/3, '$multi'/3. :- public '$plus'/3, '$pow'/3. :- public '$radians'/2, '$rint'/2, '$round'/2. :- public '$shift_left'/3, '$shift_right'/3, '$sign'/2, '$sin'/2, '$sqrt'/2. :- public '$tan'/2, '$truncate'/2. Z is Y :- Z is Y. '$abs'(X, Y) :- '$abs'(X, Y). '$asin'(X, Y) :- '$asin'(X, Y). '$acos'(X, Y) :- '$acos'(X, Y). '$atan'(X, Y) :- '$atan'(X, Y). '$bitwise_conj'(X, Y, Z) :- '$bitwise_conj'(X, Y, Z). '$bitwise_disj'(X, Y, Z) :- '$bitwise_disj'(X, Y, Z). '$bitwise_exclusive_or'(X, Y, Z) :- '$bitwise_exclusive_or'(X, Y, Z). '$bitwise_neg'(X, Y) :- '$bitwise_neg'(X, Y). '$ceil'(X, Y) :- '$ceil'(X, Y). '$cos'(X, Y) :- '$cos'(X, Y). '$degrees'(X, Y) :- '$degrees'(X, Y). '$exp'(X, Y) :- '$exp'(X, Y). '$float'(X, Y) :- '$float'(X, Y). '$float_integer_part'(X, Y) :- '$float_integer_part'(X, Y). '$float_fractional_part'(X, Y) :- '$float_fractional_part'(X, Y). '$float_quotient'(X, Y, Z) :- '$float_quotient'(X, Y, Z). '$floor'(X, Y) :- '$floor'(X, Y). '$int_quotient'(X, Y, Z) :- '$int_quotient'(X, Y, Z). '$log'(X, Y) :- '$log'(X, Y). '$max'(X, Y, Z) :- '$max'(X, Y, Z). '$min'(X, Y, Z) :- '$min'(X, Y, Z). '$minus'(X, Y, Z) :- '$minus'(X, Y, Z). '$mod'(X, Y, Z) :- '$mod'(X, Y, Z). '$multi'(X, Y, Z) :- '$multi'(X, Y, Z). '$plus'(X,Y,Z) :- '$plus'(X,Y,Z). '$pow'(X, Y, Z) :- '$pow'(X, Y, Z). '$radians'(X, Y) :- '$radians'(X, Y). '$rint'(X, Y) :- '$rint'(X, Y). '$round'(X, Y) :- '$round'(X, Y). '$shift_left'(X, Y, Z) :- '$shift_left'(X, Y, Z). '$shift_right'(X, Y, Z) :- '$shift_right'(X, Y, Z). '$sign'(X, Y) :- '$sign'(X, Y). '$sin'(X, Y) :- '$sin'(X, Y). '$sqrt'(X, Y) :- '$sqrt'(X, Y). '$tan'(X, Y) :- '$tan'(X, Y). '$truncate'(X, Y) :- '$truncate'(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Arithmetic comparison %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (=:=)/2, '$arith_equal'/2. :- public (=\=)/2, '$arith_not_equal'/2. :- public (<)/2, '$less_than'/2. :- public (=<)/2, '$less_or_equal'/2. :- public (>)/2, '$greater_than'/2. :- public (>=)/2, '$greater_or_equal'/2. X =:= Y :- X =:= Y. '$arith_equal'(X, Y) :- '$arith_equal'(X, Y). X =\= Y :- X =\= Y. '$arith_not_equal'(X, Y) :- '$arith_not_equal'(X, Y). X < Y :- X < Y. '$less_than'(X, Y) :- '$less_than'(X, Y). X =< Y :- X =< Y. '$less_or_equal'(X, Y) :- '$less_or_equal'(X, Y). X > Y :- X > Y. '$greater_than'(X, Y) :- '$greater_than'(X, Y). X >= Y :- X >= Y. '$greater_or_equal'(X, Y) :- '$greater_or_equal'(X, Y). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Clause retrieval and information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public clause/2. :- public (initialization)/2. :- public '$new_indexing_hash'/3. clause(Head, B) :- '$head_to_term'(Head, H, P:PI, clause(Head,B)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, access, private_procedure, clause(Head, B)), '$clause_internal'(P, PI, H, Cl, _), %(ground(Cl) -> Cl = (H :- B) ; copy_term(Cl, (H :- B))). ??? copy_term(Cl, (H :- B)). % head --> term '$head_to_term'(H, T, Pkg:F/A, Goal) :- '$head_to_term'(H, T, user, Pkg, Goal), functor(T, F, A). '$head_to_term'(H, _, _, _, Goal) :- var(H), !, illarg(var, Goal, 1). '$head_to_term'(P:H, T, _, Pkg, Goal) :- !, '$head_to_term'(H, T, P, Pkg, Goal). '$head_to_term'(H, H, Pkg, Pkg, _) :- callable(H), atom(Pkg), !. '$head_to_term'(_, _, _, _, Goal) :- illarg(type(callable), Goal, 1). % creates an internal database for A if no exists. '$new_internal_database'(A) :- atom(A), '$get_hash_manager'(HM), '$new_internal_database'(HM, A). '$new_internal_database'(HM, A) :- hash_contains_key(HM, A), !. '$new_internal_database'(_, A) :- new_hash(_, [alias(A)]), '$init_internal_database'(A). '$init_internal_database'(A) :- '$compiled_predicate'(A, '$init', 0), call(A:'$init'), !. '$init_internal_database'(_). % checks if the internal database of A exists. '$defined_internal_database'(A) :- atom(A), '$get_hash_manager'(HM), hash_contains_key(HM, A). % repeatedly finds dynamic clauses. '$clause_internal'(P, PI, H, Cl, Ref) :- hash_contains_key(P, PI), '$get_indices'(P, PI, H, RevRefs), '$get_instances'(RevRefs, Cls_Refs), '$clause_internal0'(Cls_Refs, Cl, Ref). '$clause_internal0'([], _, _) :- fail. '$clause_internal0'([(Cl,Ref)], Cl, Ref) :- !. '$clause_internal0'(L, Cl, Ref) :- '$builtin_member'((Cl,Ref), L). '$get_indices'(P, PI, H, Refs) :- '$new_indexing_hash'(P, PI, IH), '$calc_indexing_key'(H, Key), ( hash_contains_key(IH, Key) -> hash_get(IH, Key, Refs) ; hash_get(IH, var, Refs) ). % finds the indexing hashtable for P:PI. creates it if no exist. '$new_indexing_hash'(P, PI, IH) :- hash_contains_key(P, PI), !, hash_get(P, PI, IH). '$new_indexing_hash'(P, PI, IH) :- new_hash(IH), hash_put(IH, all, []), hash_put(IH, var, []), hash_put(IH, lis, []), hash_put(IH, str, []), hash_put(P, PI, IH). '$calc_indexing_key'(H, all) :- atom(H), !. '$calc_indexing_key'(H, Key) :- arg(1, H, A1), '$calc_indexing_key0'(A1, Key). '$calc_indexing_key0'(A1, all) :- var(A1), !. '$calc_indexing_key0'(A1, lis) :- A1 = [_|_], !. '$calc_indexing_key0'(A1, str) :- compound(A1), !. '$calc_indexing_key0'(A1, Key) :- ground(A1), !, '$term_hash'(A1, Key). '$calc_indexing_key0'(A1, Key) :- illarg(type(term), '$calc_indexing_key0'(A1,Key), 1). % checks the permission of predicate P:F/A. '$check_procedure_permission'(P:F/A, _Operation, _ObjType, _Goal) :- hash_contains_key(P, F/A), !. '$check_procedure_permission'(P:F/A, Operation, ObjType, Goal) :- '$compiled_predicate_or_builtin'(P, F, A), !, illarg(permission(Operation,ObjType,P:F/A,_), Goal, _). '$check_procedure_permission'(_, _, _, _). % initialize internal databases of given packages. initialization([], Goal) :- !, once(Goal). initialization([P|Ps], Goal) :- '$new_internal_database'(P), initialization(Ps, Goal). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Clause creation and destruction %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public assert/1. :- public assertz/1. :- public asserta/1. :- public retract/1. :- public abolish/1. :- public retractall/1. assert(T) :-assertz(T). assertz(T) :- '$term_to_clause'(T, Cl, P:PI, assertz(T)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, modify, static_procedure, assertz(T)), copy_term(Cl, NewCl), '$insert'(NewCl, Ref), '$update_indexing'(P, PI, Cl, Ref, 'z'), fail. assertz(_). asserta(T) :- '$term_to_clause'(T, Cl, P:PI, asserta(T)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, modify, static_procedure, asserta(T)), copy_term(Cl, NewCl), '$insert'(NewCl, Ref), '$update_indexing'(P, PI, Cl, Ref, 'a'), fail. asserta(_). abolish(T) :- '$term_to_predicateindicator'(T, P:PI, abolish(T)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, modify, static_procedure, abolish(T)), '$new_indexing_hash'(P, PI, IH), hash_get(IH, all, Refs), '$erase_all'(Refs), hash_remove(P, PI), fail. abolish(_). retract(Cl) :- '$clause_to_term'(Cl, T, P:PI, retract(Cl)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, access, static_procedure, retract(Cl)), T = (H :- _), '$clause_internal'(P, PI, H, Cl0, Ref), copy_term(Cl0, T), '$erase'(Ref), '$rehash_indexing'(P, PI, Ref). retractall(Head) :- '$head_to_term'(Head, H, P:PI, retractall(Head)), '$new_internal_database'(P), '$check_procedure_permission'(P:PI, access, static_procedure, retractall(Head)), '$clause_internal'(P, PI, H, Cl, Ref), copy_term(Cl, (H :- _)), '$erase'(Ref), '$rehash_indexing'(P, PI, Ref), fail. retractall(_). % term --> clause (for assert) '$term_to_clause'(Cl0, Cl, Pkg:F/A, Goal) :- '$term_to_clause'(Cl0, Cl, user, Pkg, Goal), Cl = (H :- _), functor(H, F, A). '$term_to_clause'(Cl0, _, _, _, Goal) :- var(Cl0), !, illarg(var, Goal, 1). '$term_to_clause'(_, _, Pkg0, _, Goal) :- var(Pkg0), !, illarg(var, Goal, 1). '$term_to_clause'(P:Cl0, Cl, _, Pkg, Goal) :- !, '$term_to_clause'(Cl0, Cl, P, Pkg, Goal). '$term_to_clause'(_, _, Pkg0, _, Goal) :- \+(atom(Pkg0)), !, illarg(type(atom), Goal, 1). '$term_to_clause'((H0 :- B0), (H :- B), Pkg, Pkg, Goal) :- !, '$term_to_head'(H0, H, Pkg, Goal), '$term_to_body'(B0, B, Pkg, Goal). '$term_to_clause'(H0, (H :- true), Pkg, Pkg, Goal) :- '$term_to_head'(H0, H, Pkg, Goal). '$term_to_head'(H, H, _, _) :- atom(H), !. '$term_to_head'(H, H, _, _) :- compound(H), !. '$term_to_head'(_, _, _, Goal) :- illarg(type(callable), Goal, 1). '$term_to_body'(B0, B, Pkg, _) :- '$localize_body'(B0, Pkg, B). '$localize_body'(G, P, G1) :- var(G), !, '$localize_body'(call(G), P, G1). '$localize_body'(P:G, _, G1) :- !, '$localize_body'(G, P, G1). '$localize_body'((X,Y), P, (X1,Y1)) :- !, '$localize_body'(X, P, X1), '$localize_body'(Y, P, Y1). '$localize_body'((X->Y), P, (X1->Y1)) :- !, '$localize_body'(X, P, X1), '$localize_body'(Y, P, Y1). '$localize_body'((X;Y), P, (X1;Y1)) :- !, '$localize_body'(X, P, X1), '$localize_body'(Y, P, Y1). '$localize_body'(G, P, G1) :- functor(G, F, A), '$builtin_meta_predicates'(F, A, M), %??? !, G =.. [F|As], '$localize_args'(M, As, P, As1), G1 =.. [F|As1]. '$localize_body'(G, P, call(P:G)) :- var(P), !. '$localize_body'(G, user, G) :- !. '$localize_body'(G, _, G) :- system_predicate(G), !. '$localize_body'(G, P, P:G). '$localize_args'([], [], _, []) :- !. '$localize_args'([:|Ms], [A|As], P, [P:A|As1]) :- (var(A) ; A \= _:_), !, '$localize_args'(Ms, As, P, As1). '$localize_args'([_|Ms], [A|As], P, [A|As1]) :- '$localize_args'(Ms, As, P, As1). '$builtin_meta_predicates'((^), 2, [?,:]). '$builtin_meta_predicates'(call, 1, [:]). '$builtin_meta_predicates'(once, 1, [:]). '$builtin_meta_predicates'((\+), 1, [:]). '$builtin_meta_predicates'(findall, 3, [?,:,?]). '$builtin_meta_predicates'(setof, 3, [?,:,?]). '$builtin_meta_predicates'(bagof, 3, [?,:,?]). '$builtin_meta_predicates'(on_exception, 3, [?,:,:]). '$builtin_meta_predicates'(catch, 3, [:,?,:]). '$builtin_meta_predicates'(freeze, 2, [?,:]). % clause --> term (for retract) '$clause_to_term'(Cl, T, Pkg:F/A, Goal) :- '$clause_to_term'(Cl, T, user, Pkg, Goal), T = (H :- _), functor(H, F, A). '$clause_to_term'(Cl, _, _, _, Goal) :- var(Cl), !, illarg(var, Goal, 1). '$clause_to_term'(_, _, Pkg, _, Goal) :- var(Pkg), !, illarg(var, Goal, 1). '$clause_to_term'(P:Cl, T, _, Pkg, Goal) :- !, '$clause_to_term'(Cl, T, P, Pkg, Goal). '$clause_to_term'(_, _, Pkg, _, Goal) :- \+(atom(Pkg)), !, illarg(type(atom), Goal, 1). '$clause_to_term'((H0 :- B), (H :- B), Pkg, Pkg, Goal) :- !, '$head_to_term'(H0, H, _, Goal). %'$body_to_term'(B0, B, Goal). '$clause_to_term'(H0, (H :- true), Pkg, Pkg, Goal) :- '$head_to_term'(H0, H, _, Goal). % term --> predicate indicator (for abolish) '$term_to_predicateindicator'(T, Pkg:PI, Goal) :- '$term_to_predicateindicator'(T, PI, user, Pkg, Goal). '$term_to_predicateindicator'(T, _, _, _, Goal) :- var(T), !, illarg(var, Goal, 1). '$term_to_predicateindicator'(_, _, Pkg, _, Goal) :- var(Pkg), !, illarg(var, Goal, 1). '$term_to_predicateindicator'(P:T, PI, _, Pkg, Goal) :- !, '$term_to_predicateindicator'(T, PI, P, Pkg, Goal). '$term_to_predicateindicator'(T, _, _, _, Goal) :- T \= _/_, !, illarg(type('predicate_indicator'), Goal, 1). '$term_to_predicateindicator'(F/_, _, _, _, Goal) :- \+ atom(F), !, illarg(type(atom), Goal, 1). '$term_to_predicateindicator'(_/A, _, _, _, Goal) :- \+ integer(A), !, illarg(type(integer), Goal, 1). '$term_to_predicateindicator'(T, T, Pkg, Pkg, _). '$update_indexing'(P, PI, Cl, Ref, A_or_Z) :- '$new_indexing_hash'(P, PI, IH), '$gen_indexing_keys'(Cl, IH, Keys), '$update_indexing_hash'(A_or_Z, Keys, IH, Ref). '$gen_indexing_keys'((H :- _), _, [all]) :- atom(H), !. '$gen_indexing_keys'((H :- _), IT, Keys) :- arg(1, H, A1), '$gen_indexing_keys0'(A1, IT, Keys). '$gen_indexing_keys0'(A1, IT, Keys) :- var(A1), !, hash_keys(IT, Keys). '$gen_indexing_keys0'(A1, _, [all,lis]) :- A1 = [_|_], !. '$gen_indexing_keys0'(A1, _, [all,str]) :- compound(A1), !. '$gen_indexing_keys0'(A1, IT, [all,Key]) :- ground(A1), !, '$term_hash'(A1, Key), % get the hash code of A1 ( hash_contains_key(IT, Key) -> true ; hash_get(IT, var, L), hash_put(IT, Key, L) ). '$gen_indexing_keys0'(A1, IT, Keys) :- illarg(type(term), '$gen_indexing_keys0'(A1,IT,Keys), 1). '$update_indexing_hash'(a, Keys, IH, Ref) :- !, '$hash_addz_all'(Keys, IH, Ref). '$update_indexing_hash'(z, Keys, IH, Ref) :- !, '$hash_adda_all'(Keys, IH, Ref). '$hash_adda_all'([], _, _) :- !. '$hash_adda_all'([K|Ks], H, X) :- '$hash_adda'(H, K, X), '$hash_adda_all'(Ks, H, X). '$hash_addz_all'([], _, _) :- !. '$hash_addz_all'([K|Ks], H, X) :- '$hash_addz'(H, K, X), '$hash_addz_all'(Ks, H, X). '$erase_all'([]) :- !. '$erase_all'([R|Rs]) :- '$erase'(R), '$erase_all'(Rs). '$rehash_indexing'(P, PI, Ref) :- '$new_indexing_hash'(P, PI, IH), hash_keys(IH, Keys), '$remove_index_all'(Keys, IH, Ref). '$remove_index_all'([], _, _) :- !. '$remove_index_all'([K|Ks], IH, Ref) :- '$hash_remove_first'(IH, K, Ref), '$remove_index_all'(Ks, IH, Ref). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % All solutions %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public findall/3. :- public bagof/3. :- public setof/3. % findall/3 findall(Template, Goal, Instances) :- callable(Goal), !, new_hash(H), '$findall'(H, Template, Goal, Instances). findall(Template, Goal, Instances) :- illarg(type(callable), findall(Template,Goal,Instances), 2). '$findall'(H, Template, Goal, _) :- call(Goal), copy_term(Template, CT), '$hash_adda'(H, '$FINDALL', CT), fail. '$findall'(H, _, _, Instances) :- hash_get(H, '$FINDALL', Vs), reverse(Vs, Instances). % bagof/3 & setof/3 bagof(Template, Goal, Instances) :- callable(Goal), !, '$bagof'(Template, Goal, Instances). bagof(Template, Goal, Instances) :- illarg(type(callable), bagof(Template,Goal,Instances), 2). setof(Template, Goal, Instances) :- callable(Goal), !, '$bagof'(Template, Goal, Instances0), sort(Instances0, Instances). setof(Template, Goal, Instances) :- illarg(type(callable), setof(Template,Goal,Instances), 2). '$bagof'(Template, Goal, Instances) :- '$free_variables_set'(Goal, Template, FV), %write('Goal = '), write(Goal), nl, %write('Free variables set = '), write(FV), nl, FV \== [], !, Witness =.. ['$witness'|FV], findall(Witness+Template, Goal, S), '$bagof_instances'(S, Witness, Instances0), Instances = Instances0. '$bagof'(Template, Goal, Instances) :- findall(Template, Goal, Instances), Instances \== []. '$bagof_instances'([], _Witness, _Instances) :- fail. '$bagof_instances'(S0, Witness, Instances) :- S0 = [W+T|S], '$variants_subset'(S, W, WT_list, T_list, S_next), '$bagof_instances0'(S_next, Witness, Instances, [W+T|WT_list], [T|T_list]). '$bagof_instances0'(_, Witness, Instances, WT_list, T_list) :- '$unify_witness'(WT_list, Witness), Instances = T_list. '$bagof_instances0'(S_next, Witness, Instances, _, _) :- '$bagof_instances'(S_next, Witness, Instances). '$variants_subset'([], _W, [], [], []) :- !. '$variants_subset'([W0+T0|S], W, [W0+T0|WT_list], [T0|T_list], S_next) :- '$term_variant'(W, W0), !, '$variants_subset'(S, W, WT_list, T_list, S_next). '$variants_subset'([WT|S], W, WT_list, T_list, [WT|S_next]) :- '$variants_subset'(S, W, WT_list, T_list, S_next). '$term_variant'(X, Y) :- new_hash(Hash), '$term_variant'(X, Y, Hash). '$term_variant'(X, Y, Hash) :- var(X), !, ( hash_contains_key(Hash, X) -> hash_get(Hash, X, V), Y == V ; var(Y), hash_put(Hash, X, Y) ). '$term_variant'(X, Y, _) :- ground(X), !, X == Y. '$term_variant'(_, Y, _) :- var(Y), !, fail. '$term_variant'([X|Xs], [Y|Ys], Hash) :- !, '$term_variant'(X, Y, Hash), '$term_variant'(Xs, Ys, Hash). '$term_variant'(X, Y, Hash) :- X =.. Xs, Y =.. Ys, '$term_variant'(Xs, Ys, Hash). '$unify_witness'([], _) :- !. '$unify_witness'([W+_|WT_list], W) :- '$unify_witness'(WT_list, W). % Variable set of a term '$variables_set'(X, Vs) :- '$variables_set'(X, [], Vs). '$variables_set'(X, Vs, Vs ) :- var(X), '$builtin_memq'(X, Vs), !. '$variables_set'(X, Vs, [X|Vs] ) :- var(X), !. '$variables_set'(X, Vs0, Vs0 ) :- atomic(X), !. '$variables_set'([X|Xs], Vs0, Vs) :- !, '$variables_set'(X, Vs0, Vs1), '$variables_set'(Xs, Vs1, Vs). '$variables_set'(X, Vs0, Vs ) :- X =.. Xs, '$variables_set'(Xs, Vs0, Vs). '$builtin_memq'(X, [Y|_]) :- X==Y, !. '$builtin_memq'(X, [_|Ys]) :- '$builtin_memq'(X, Ys). % Existential variables set of a term '$existential_variables_set'(X, Vs) :- '$existential_variables_set'(X, [], Vs). '$existential_variables_set'(X, Vs, Vs) :- var(X), !. '$existential_variables_set'(X, Vs, Vs) :- atomic(X), !. '$existential_variables_set'(_:X, Vs0, Vs) :- !, '$existential_variables_set'(X, Vs0, Vs). %'$existential_variables_set'((X;Y), Vs0, Vs) :- !, % '$existential_variables_set'(X, Vs0, Vs1), % '$existential_variables_set'(Y, Vs1, Vs). %'$existential_variables_set'((X->Y), Vs0, Vs) :- !, % '$existential_variables_set'(X, Vs0, Vs1), % '$existential_variables_set'(Y, Vs1, Vs). %'$existential_variables_set'((X,Y), Vs0, Vs) :- !, % '$existential_variables_set'(X, Vs0, Vs1), % '$existential_variables_set'(Y, Vs1, Vs). '$existential_variables_set'(^(V,G), Vs0, Vs) :- !, '$variables_set'(V, Vs0, Vs1), '$existential_variables_set'(G, Vs1, Vs). '$existential_variables_set'('$meta_call'(G,_,_,_,_), Vs0, Vs) :- !, %??? '$existential_variables_set'(G, Vs0, Vs). '$existential_variables_set'(_, Vs, Vs). % Free variables set of a term '$free_variables_set'(T, V, FV) :- '$variables_set'(T, TV), '$variables_set'(V, VV), '$existential_variables_set'(T, VV, BV), '$builtin_set_diff'(TV, BV, FV), !. '$builtin_set_diff'(L1, L2, L) :- sort(L1, SL1), sort(L2, SL2), '$builtin_set_diff0'(SL1, SL2, L). '$builtin_set_diff0'([], _, []) :- !. '$builtin_set_diff0'(L1, [], L1) :- !. '$builtin_set_diff0'([X|Xs], [Y|Ys], L) :- X == Y, !, '$builtin_set_diff0'(Xs, Ys, L). '$builtin_set_diff0'([X|Xs], [Y|Ys], [X|L]) :- X @< Y, !, '$builtin_set_diff0'(Xs, [Y|Ys], L). '$builtin_set_diff0'([X|Xs], [Y|Ys], [Y|L]) :- '$builtin_set_diff0'([X|Xs], Ys, [Y|L]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term input/output (read) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public read/2. :- public read_with_variables/3. %:- public read_line/2. (written in Java) :- dynamic '$tokens'/1. read(S_or_a, X) :- read_tokens(S_or_a, Tokens, _), parse_tokens(X, Tokens), !. read_with_variables(S_or_a, X, Vs) :- read_tokens(S_or_a, Tokens, Vs), parse_tokens(X, Tokens), !. % read_token(S_or_a, Token) reads one token from the input, % and unifies Token with: % error(Atom), % end_of_file, % '.', ' ', '(', ')', '[', ']', '{', '}', ',', '|', % number(Integer_or_Float), % atom(Atom), % var(Atom), % string(CharCodeList) read_token(S_or_a, Token) :- '$read_token0'(S_or_a, Type, Token0), '$read_token1'([Type], Token0, Token). '$read_token1'([-2], T, error(T)) :- !. % error('message') '$read_token1'("I", T, number(T)) :- !. % number(intvalue) '$read_token1'("D", T, number(T)) :- !. % number(floatvalue) '$read_token1'("A", T, atom(T)) :- !. % atom('name') '$read_token1'("V", T, var(T)) :- !. % var('name') '$read_token1'("S", T, string(T)) :- !. % string("chars") '$read_token1'(_, T, T) :- !. % others % read_tokens(Tokens, Vs) reads tokens from the input % until full-stop-mark ('.') or end_of_file, % unifies Tokens with a list of tokens. % Token for a variable has a form of var(Name,Variable). % Vs is a list of Name=Variable pairs. read_tokens(Stream, Tokens, Vs) :- '$read_tokens'(Stream, Tokens, Vs, []), !. '$read_tokens'(Stream, Tokens, Vs, VI) :- read_token(Stream, Token), '$read_tokens1'(Stream, Token, Tokens, Vs, VI). '$read_tokens1'(Stream, error(Message), [], _, _) :- !, '$read_tokens_until_fullstop'(Stream), raise_exception(syntax_error(Message)), fail. '$read_tokens1'(_Stream, end_of_file, [end_of_file,'.'], [], _) :- !. '$read_tokens1'(_Stream, '.', ['.'], [], _) :- !. '$read_tokens1'(Stream, var('_'), [var('_',V)|Tokens], ['_'=V|Vs], VI0) :- !, '$read_tokens'(Stream, Tokens, Vs, ['_'=V|VI0]). '$read_tokens1'(Stream, var(Name), [var(Name,V)|Tokens], Vs, VI) :- '$mem_pair'(Name=V, VI), !, '$read_tokens'(Stream, Tokens, Vs, VI). '$read_tokens1'(Stream, var(Name), [var(Name,V)|Tokens], [Name=V|Vs], VI0) :- !, '$read_tokens'(Stream, Tokens, Vs, [Name=V|VI0]). '$read_tokens1'(Stream, Token, [Token|Tokens], Vs, VI) :- '$read_tokens'(Stream, Tokens, Vs, VI). '$mem_pair'(X1=V1, [X2=V2|_]) :- X1 == X2, !, V1 = V2. '$mem_pair'(X, [_|L]) :- '$mem_pair'(X, L). %'$mem_pair'(X, [_|L]) :- member(X, L). '$read_tokens_until_fullstop'(Stream) :- read_token(Stream, Token), '$read_tokens_until_fullstop'(Stream, Token). '$read_tokens_until_fullstop'(_Stream, end_of_file) :- !. '$read_tokens_until_fullstop'(_Stream, '.') :- !. '$read_tokens_until_fullstop'(Stream, _) :- read_token(Stream, Token), '$read_tokens_until_fullstop'(Stream, Token). parse_tokens(X, Tokens) :- retractall('$tokens'(_)), assertz('$tokens'(Tokens)), '$parse_tokens'(X, 1201, Tokens, ['.']), retract('$tokens'(Tokens)), !. % '$parse_tokens'(X, Prec) parses the input whose precedecence =< Prec. '$parse_tokens'(X, Prec0) --> '$parse_tokens_skip_spaces', '$parse_tokens1'(Prec0, X1, Prec1), !, '$parse_tokens_skip_spaces', '$parse_tokens2'(Prec0, X1, Prec1, X, _Prec), !. '$parse_tokens1'(Prec0, X1, Prec1) --> '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_starter'(Next)}, !, '$parse_tokens_before_op'(Prec0, X1, Prec1). '$parse_tokens1'(_, _, _) --> '$parse_tokens_peep_next'(Next), '$parse_tokens_error'([Next,cannot,start,an,expression]). '$parse_tokens2'(Prec0, X, Prec, X, Prec) --> '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_terminator'(Next)}, {Prec =< Prec0}, !. '$parse_tokens2'(Prec0, X1, Prec1, X, Prec) --> '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_post_in_op'(Next)}, !, '$parse_tokens_post_in_ops'(Prec0, X1, Prec1, X, Prec). '$parse_tokens2'(_, _, _, _, _) --> '$parse_tokens_error'([operator,expected,after,expression]). % '$parse_tokens_before_op'(Prec0, X, Prec) % parses the input until infix or postfix operator, % and returns X and Prec '$parse_tokens_before_op'(Prec0, X, Prec) --> [' '], !, '$parse_tokens_before_op'(Prec0, X, Prec). '$parse_tokens_before_op'(_, end_of_file, 0) --> [end_of_file], !. '$parse_tokens_before_op'(_, N, 0) --> [number(N)], !. '$parse_tokens_before_op'(_, N, 0) --> [atom('-')], [number(N0)], !, {N is -N0}. '$parse_tokens_before_op'(_, V, 0) --> [var(_,V)], !. '$parse_tokens_before_op'(_, S, 0) --> [string(S)], !. '$parse_tokens_before_op'(_, X, 0) --> ['('], !, '$parse_tokens'(X, 1201), '$parse_tokens_expect'(')'). '$parse_tokens_before_op'(_, X, 0) --> ['{'], !, '$parse_tokens_skip_spaces', '$parse_tokens_brace'(X). '$parse_tokens_before_op'(_, X, 0) --> ['['], !, '$parse_tokens_skip_spaces', '$parse_tokens_list'(X). '$parse_tokens_before_op'(_, X, 0) --> [atom(F)], ['('], !, '$parse_tokens_skip_spaces', '$parse_tokens_args'(Args), {X =.. [F|Args]}. '$parse_tokens_before_op'(Prec0, X, PrecOp) --> [atom(F)], {current_op(PrecOp,fx,F)}, {PrecOp =< Prec0}, '$parse_tokens_skip_spaces', '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_starter'(Next)}, {\+ '$parse_tokens_is_post_in_op'(Next)}, !, {Prec1 is PrecOp - 1}, '$parse_tokens'(Arg, Prec1), {functor(X, F, 1)}, {arg(1, X, Arg)}. '$parse_tokens_before_op'(Prec0, X, PrecOp) --> [atom(F)], {current_op(PrecOp,fy,F)}, {PrecOp =< Prec0}, '$parse_tokens_skip_spaces', '$parse_tokens_peep_next'(Next), {'$parse_tokens_is_starter'(Next)}, {\+ '$parse_tokens_is_post_in_op'(Next)}, !, '$parse_tokens'(Arg, PrecOp), {functor(X, F, 1)}, {arg(1, X, Arg)}. '$parse_tokens_before_op'(_, A, 0) --> [atom(A)]. '$parse_tokens_brace'('{}') --> ['}'], !. '$parse_tokens_brace'(X) --> '$parse_tokens'(X1, 1201), '$parse_tokens_expect'('}'), {X = {X1}}. '$parse_tokens_list'('[]') --> [']'], !. '$parse_tokens_list'([X|Xs]) --> '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_list_rest'(Xs). '$parse_tokens_list_rest'(Xs) --> ['|'], !, '$parse_tokens'(Xs, 999), '$parse_tokens_expect'(']'). '$parse_tokens_list_rest'([X|Xs]) --> [','], !, '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_list_rest'(Xs). '$parse_tokens_list_rest'('[]') --> '$parse_tokens_expect'(']'). '$parse_tokens_args'('[]') --> [')'], !. '$parse_tokens_args'([X|Xs]) --> '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_args_rest'(Xs). '$parse_tokens_args_rest'([X|Xs]) --> [','], !, '$parse_tokens'(X, 999), '$parse_tokens_skip_spaces', '$parse_tokens_args_rest'(Xs). '$parse_tokens_args_rest'('[]') --> '$parse_tokens_expect'(')'). % '$parse_tokens_post_in_op'(Prec0, X1, Prec1, X, Prec) % parses the input beginning from infix or postfix operator, % and returns X and Prec '$parse_tokens_post_in_ops'(Prec0, X1, Prec1, X, Prec) --> '$parse_tokens_skip_spaces', [Op], '$parse_tokens_op'(Op, Prec0, X1, Prec1, X2, Prec2), '$parse_tokens_post_in_ops'(Prec0, X2, Prec2, X, Prec). '$parse_tokens_post_in_ops'(Prec0, X, Prec, X, Prec) --> {Prec =< Prec0}. '$parse_tokens_op'(',', Prec0, X1, Prec1, X, PrecOp) --> !, '$parse_tokens_op'(atom(','), Prec0, X1, Prec1, X, PrecOp). '$parse_tokens_op'('|', Prec0, X1, Prec1, X, PrecOp) --> !, '$parse_tokens_op'(atom(';'), Prec0, X1, Prec1, X, PrecOp). '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, xf, Op)}, {PrecOp =< Prec0}, {Prec1 < PrecOp}, {functor(X, Op, 1)}, {arg(1, X, X1)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, yf, Op)}, {PrecOp =< Prec0}, {Prec1 =< PrecOp}, {functor(X, Op, 1)}, {arg(1, X, X1)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, xfx, Op)}, {PrecOp =< Prec0}, {Prec1 < PrecOp}, {Prec2 is PrecOp - 1}, '$parse_tokens'(X2, Prec2), !, {functor(X, Op, 2)}, {arg(1, X, X1)}, {arg(2, X, X2)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, xfy, Op)}, {PrecOp =< Prec0}, {Prec1 < PrecOp}, {Prec2 is PrecOp}, '$parse_tokens'(X2, Prec2), !, {functor(X, Op, 2)}, {arg(1, X, X1)}, {arg(2, X, X2)}. '$parse_tokens_op'(atom(Op), Prec0, X1, Prec1, X, PrecOp) --> {current_op(PrecOp, yfx, Op)}, {PrecOp =< Prec0}, {Prec1 =< PrecOp}, {Prec2 is PrecOp - 1}, '$parse_tokens'(X2, Prec2), !, {functor(X, Op, 2)}, {arg(1, X, X1)}, {arg(2, X, X2)}. '$parse_tokens_is_starter'(end_of_file). '$parse_tokens_is_starter'('('). '$parse_tokens_is_starter'('['). '$parse_tokens_is_starter'('{'). '$parse_tokens_is_starter'(number(_)). '$parse_tokens_is_starter'(atom(_)). '$parse_tokens_is_starter'(var(_,_)). '$parse_tokens_is_starter'(string(_)). '$parse_tokens_is_terminator'(')'). '$parse_tokens_is_terminator'(']'). '$parse_tokens_is_terminator'('}'). '$parse_tokens_is_terminator'('.'). '$parse_tokens_is_post_in_op'(',') :- !. '$parse_tokens_is_post_in_op'('|') :- !. '$parse_tokens_is_post_in_op'(atom(Op)) :- current_op(_, Type, Op), '$parse_tokens_post_in_type'(Type), !. '$parse_tokens_post_in_type'(xfx). '$parse_tokens_post_in_type'(xfy). '$parse_tokens_post_in_type'(yfx). '$parse_tokens_post_in_type'(xf). '$parse_tokens_post_in_type'(yf). '$parse_tokens_expect'(Token) --> '$parse_tokens_skip_spaces', [Token], !. '$parse_tokens_expect'(Token) --> '$parse_tokens_error'([Token,expected]). '$parse_tokens_skip_spaces' --> [' '], !, '$parse_tokens_skip_spaces'. '$parse_tokens_skip_spaces' --> []. '$parse_tokens_peep_next'(Next, S, S) :- S = [Next|_]. '$parse_tokens_error'(Message, S0, _S) :- clause('$tokens'(Tokens), _), raise_exception(syntax_error(Message, at(Tokens))), fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term input/output (write) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public write/2. :- public writeq/2. :- public write_canonical/2. :- public write_term/3. write(S_or_a, Term) :- write_term(S_or_a, Term, [numbervars(true)]). writeq(S_or_a, Term) :- write_term(S_or_a, Term, [quoted(true),numbervars(true)]). write_canonical(S_or_a, Term) :- write_term(S_or_a, Term, [quoted(true),ignore_ops(true)]). write_term(S_or_a, Term, Options) :- '$write_term'(S_or_a, Term, Options), fail. write_term(_, _, _). '$write_term'(S_or_a, Term, Options) :- '$write_term0'(Term, 1200, punct, _, Options, S_or_a), !. '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- var(Term), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$fast_write'(S_or_a, Term). '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- java(Term), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$fast_write'(S_or_a, Term). '$write_term0'(Term, _Prec, Type0, alpha, Style, S_or_a) :- Term = '$VAR'(VN), integer(VN), VN >= 0, '$builtin_member'(numbervars(true), Style), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$write_VAR'(VN, S_or_a). '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- number(Term), Term < 0, !, '$write_space_if_needed'(Type0, symbol, S_or_a), '$fast_write'(S_or_a, Term). '$write_term0'(Term, _Prec, Type0, alpha, _, S_or_a) :- number(Term), !, '$write_space_if_needed'(Type0, alpha, S_or_a), '$fast_write'(S_or_a, Term). %'$write_term0'(Term, Prec, Type0, punct, _, S_or_a) :- % atom(Term), % current_op(PrecOp, OpType, Term), % (OpType = fx ; OpType = fy), % PrecOp =< Prec, % !, % '$write_space_if_needed'(Type0, punct, S_or_a), % put_char(S_or_a, '('), % '$write_atom'(Term, punct, _, _, S_or_a), % put_char(S_or_a, ')'). '$write_term0'(Term, _Prec, Type0, Type, Style, S_or_a) :- atom(Term), !, '$write_atom'(Term, Type0, Type, Style, S_or_a). '$write_term0'(Term, Prec, Type0, Type, Style, S_or_a) :- \+ '$builtin_member'(ignore_ops(true), Style), '$write_is_operator'(Term, Op, Args, OpType), !, '$write_term_op'(Op, OpType, Args, Prec, Type0, Type, Style, S_or_a). '$write_term0'(Term, _Prec, Type0, punct, Style, S_or_a) :- Term = [_|_], \+ '$builtin_member'(ignore_ops(true), Style), !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, '['), '$write_term_list_args'(Term, punct, _, Style, S_or_a), put_char(S_or_a, ']'). '$write_term0'(Term, _Prec, Type0, _Type, Style, S_or_a) :- Term = {Term1}, \+ '$builtin_member'(ignore_ops(true), Style), !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, '{'), '$write_term0'(Term1, 1200, punct, _, Style, S_or_a), put_char(S_or_a, '}'). '$write_term0'(Term, _Prec, Type0, punct, Style, S_or_a) :- Term =.. [F|Args], '$write_atom'(F, Type0, _, Style, S_or_a), put_char(S_or_a, '('), '$write_term_args'(Args, punct, _, Style, S_or_a), put_char(S_or_a, ')'). '$write_space_if_needed'(punct, _, _ ) :- !. '$write_space_if_needed'(X, X, S_or_a) :- !, put_char(S_or_a, ' '). '$write_space_if_needed'(other, alpha, S_or_a) :- !, put_char(S_or_a, ' '). '$write_space_if_needed'(_, _, _ ). '$write_VAR'(VN, S_or_a) :- VN < 26, !, Letter is VN mod 26 + "A", put_code(S_or_a, Letter). '$write_VAR'(VN, S_or_a) :- Letter is VN mod 26 + "A", put_code(S_or_a, Letter), Rest is VN//26, '$fast_write'(S_or_a, Rest). '$write_atom'(Atom, Type0, Type, Style, S_or_a) :- '$builtin_member'(quoted(true), Style), !, '$atom_type'(Atom, Type), '$write_space_if_needed'(Type0, Type, S_or_a), '$fast_writeq'(S_or_a, Atom). '$write_atom'(Atom, Type0, Type, _, S_or_a) :- '$atom_type'(Atom, Type), '$write_space_if_needed'(Type0, Type, S_or_a), '$fast_write'(S_or_a, Atom). '$atom_type'(X, alpha ) :- '$atom_type0'(X, 0), !. '$atom_type'(X, symbol) :- '$atom_type0'(X, 1), !. '$atom_type'(X, punct ) :- '$atom_type0'(X, 2), !. '$atom_type'(X, other ) :- '$atom_type0'(X, 3), !. '$write_is_operator'(Term, Op, Args, OpType) :- functor(Term, Op, Arity), '$write_op_type'(Arity, OpType), current_op(_, OpType, Op), Term =.. [_|Args], !. '$write_op_type'(1, fx). '$write_op_type'(1, fy). '$write_op_type'(1, xf). '$write_op_type'(1, yf). '$write_op_type'(2, xfx). '$write_op_type'(2, xfy). '$write_op_type'(2, yfx). '$write_term_op'(Op, OpType, Args, Prec, Type0, punct, Style, S_or_a) :- current_op(PrecOp, OpType, Op), PrecOp > Prec, !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, '('), '$write_term_op1'(Op, OpType, Args, PrecOp, punct, _, Style, S_or_a), put_char(S_or_a, ')'). '$write_term_op'(Op, OpType, Args, _Prec, Type0, Type, Style, S_or_a) :- current_op(PrecOp, OpType, Op), '$write_term_op1'(Op, OpType, Args, PrecOp, Type0, Type, Style, S_or_a). '$write_term_op1'(Op, fx, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, '$write_atom'(Op, Type0, Type1, Style, S_or_a), Prec1 is PrecOp - 1, '$write_term0'(A1, Prec1, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, fy, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, '$write_atom'(Op, Type0, Type1, Style, S_or_a), Prec1 is PrecOp, '$write_term0'(A1, Prec1, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, xf, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp - 1, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_atom'(Op, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, yf, [A1], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_atom'(Op, Type1, Type, Style, S_or_a). '$write_term_op1'(Op, xfx, [A1,A2], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp - 1, Prec2 is PrecOp - 1, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_term_infix_op'(Op, Type1, Type2, Style, S_or_a), '$write_term0'(A2, Prec2, Type2, Type, Style, S_or_a). '$write_term_op1'(Op, xfy, [A1,A2], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp - 1, Prec2 is PrecOp, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_term_infix_op'(Op, Type1, Type2, Style, S_or_a), '$write_term0'(A2, Prec2, Type2, Type, Style, S_or_a). '$write_term_op1'(Op, yfx, [A1,A2], PrecOp, Type0, Type, Style, S_or_a) :- !, Prec1 is PrecOp, Prec2 is PrecOp - 1, '$write_term0'(A1, Prec1, Type0, Type1, Style, S_or_a), '$write_term_infix_op'(Op, Type1, Type2, Style, S_or_a), '$write_term0'(A2, Prec2, Type2, Type, Style, S_or_a). '$write_term_infix_op'(',', Type0, punct, _, S_or_a) :- !, '$write_space_if_needed'(Type0, punct, S_or_a), put_char(S_or_a, ','). '$write_term_infix_op'(Op, Type0, Type, Style, S_or_a) :- '$write_atom'(Op, Type0, Type, Style, S_or_a). '$write_term_list_args'([A|As], Type0, Type, Style, S_or_a) :- nonvar(As), As = [_|_], !, '$write_term0'(A, 999, Type0, Type1, Style, S_or_a), '$write_space_if_needed'(Type1, punct, S_or_a), put_char(S_or_a, ','), '$write_term_list_args'(As, punct, Type, Style, S_or_a). '$write_term_list_args'([A|As], Type0, Type, Style, S_or_a) :- nonvar(As), As = [], !, '$write_term0'(A, 999, Type0, Type, Style, S_or_a). '$write_term_list_args'([A|As], Type0, Type, Style, S_or_a) :- '$write_term0'(A, 999, Type0, Type1, Style, S_or_a), '$write_space_if_needed'(Type1, punct, S_or_a), put_char(S_or_a, '|'), '$write_term0'(As, 999, punct, Type, Style, S_or_a). '$write_term_args'([], Type, Type, _, _) :- !. '$write_term_args'([A], Type0, Type, Style, S_or_a) :- !, '$write_term0'(A, 999, Type0, Type, Style, S_or_a). '$write_term_args'([A|As], Type0, Type, Style, S_or_a) :- !, '$write_term0'(A, 999, Type0, Type1, Style, S_or_a), '$write_space_if_needed'(Type1, punct, S_or_a), put_char(S_or_a, ','), '$write_term_args'(As, punct, Type, Style, S_or_a). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Term input/output (others) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public op/3. :- public current_op/3. :- dynamic '$current_operator'/3. op(Priority, Op_specifier, Operator) :- integer(Priority), 0 =)). '$current_operator'( 1200, fx, (:-)). '$current_operator'( 1200, fx, (?-)). '$current_operator'( 1150, fx, (package)). '$current_operator'( 1150, fx, (import)). '$current_operator'( 1150, fx, (public)). '$current_operator'( 1150, fx, (dynamic)). '$current_operator'( 1150, fx, (meta_predicate)). '$current_operator'( 1150, fx, (mode)). '$current_operator'( 1150, fx, (multifile)). '$current_operator'( 1150, fx, (block)). '$current_operator'( 1100, xfy, (;)). '$current_operator'( 1050, xfy, (->)). '$current_operator'( 1000, xfy, (',')). '$current_operator'( 900, fy, (\+)). '$current_operator'( 700, xfx, (=)). '$current_operator'( 700, xfx, (\=)). '$current_operator'( 700, xfx, (==)). '$current_operator'( 700, xfx, (\==)). '$current_operator'( 700, xfx, (@<)). '$current_operator'( 700, xfx, (@>)). '$current_operator'( 700, xfx, (@=<)). '$current_operator'( 700, xfx, (@>=)). '$current_operator'( 700, xfx, (=..)). '$current_operator'( 700, xfx, (is)). '$current_operator'( 700, xfx, (=:=)). '$current_operator'( 700, xfx, (=\=)). '$current_operator'( 700, xfx, (<)). '$current_operator'( 700, xfx, (>)). '$current_operator'( 700, xfx, (=<)). '$current_operator'( 700, xfx, (>=)). '$current_operator'( 550, xfy, (:)). '$current_operator'( 500, yfx, (+)). '$current_operator'( 500, yfx, (-)). '$current_operator'( 500, yfx, (#)). '$current_operator'( 500, yfx, (/\)). '$current_operator'( 500, yfx, (\/)). '$current_operator'( 500, fx, (+)). '$current_operator'( 400, yfx, (*)). '$current_operator'( 400, yfx, (/)). '$current_operator'( 400, yfx, (//)). '$current_operator'( 400, yfx, (mod)). '$current_operator'( 400, yfx, (rem)). '$current_operator'( 400, yfx, (<<)). '$current_operator'( 400, yfx, (>>)). '$current_operator'( 300, xfx, (~)). '$current_operator'( 200, xfx, (**)). '$current_operator'( 200, xfy, (^)). '$current_operator'( 200, fy, (\)). '$current_operator'( 200, fy, (-)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Logic and control %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public (\+)/1. :- public once/1. :- public repeat/0. \+(G) :- call(G), !, fail. \+(_). repeat. repeat :- repeat. once(G) :- call(G), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Atomic term processing %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %:- public atom_length/2. written in Java %:- public atom_concat/3. written in Java :- public sub_atom/5. %:- public atom_chars/2, atom_codes/2. written in Java %:- public char_code/2. written in Java %:- public number_chars/2, number_codes/2. written in Java :- public name/2. %:- public regex_compile/2. written in Java %:- public regex_match/3. written in Java :- public regex_matches/3. :- public regex_matches/2. sub_atom(Atom, Before, Length, After, Sub_atom) :- atom_concat(AtomL, X, Atom), atom_length(AtomL, Before), atom_concat(Sub_atom, AtomR, X), atom_length(Sub_atom, Length), atom_length(AtomR, After). name(Constant, Chars) :- nonvar(Constant), ( number(Constant) -> number_codes(Constant, Chars) ; atomic(Constant) -> atom_codes(Constant, Chars) ; illarg(type(atomic), name(Constant,Chars), 1) ). name(Constant, Chars) :- var(Constant), ( number_codes(Constant0, Chars) -> Constant = Constant0 ; atom_codes(Constant0, Chars) -> Constant = Constant0 ; illarg(type(list(char)), name(Constant,Chars), 2) ). regex_matches(_, [], _) :- !, fail. regex_matches(Pattern, List, Result) :- List = [_ | _], !, regex_list(Pattern, List, Result). regex_matches(Pattern, String, Result) :- atom(String), regex_compile(Pattern, Matcher), regex_match(Matcher, String, Result). regex_matches(Pattern, String) :- once(regex_matches(Pattern, String, _)). regex_list(Pattern, [H | _ ], Result) :- regex_matches(Pattern, H, Result). regex_list(Pattern, [_ | Ls], Result) :- regex_list(Pattern, Ls, Result). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Implementation defined hooks %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public set_prolog_flag/2. :- public current_prolog_flag/2. set_prolog_flag(Flag, Value) :- var(Flag), !, illarg(var, set_prolog_flag(Flag,Value), 1). set_prolog_flag(Flag, Value) :- var(Value), !, illarg(var, set_prolog_flag(Flag,Value), 2). set_prolog_flag(Flag, Value) :- atom(Flag), !, '$set_prolog_flag0'(Flag, Value). set_prolog_flag(Flag, Value) :- illarg(type(atom), set_prolog_flag(Flag,Value), 1). '$set_prolog_flag0'(Flag, Value) :- '$prolog_impl_flag'(Flag, Mode, changeable(YN)), !, '$set_prolog_flag0'(YN, Flag, Value, Mode). '$set_prolog_flag0'(Flag, Value) :- illarg(domain(atom,prolog_flag), set_prolog_flag(Flag,Value), 1). '$set_prolog_flag0'(no, Flag, Value, _) :- !, illarg(permission(modify,flag,Flag,_), set_prolog_flag(Flag,Value), _). '$set_prolog_flag0'(_, Flag, Value, Mode) :- '$builtin_member'(Value, Mode), !, '$set_prolog_impl_flag'(Flag, Value). '$set_prolog_flag0'(_, Flag, Value, _) :- illarg(domain(atom,flag_value), set_prolog_flag(Flag,Value), 2). current_prolog_flag(Flag, Term) :- var(Flag), !, '$prolog_impl_flag'(Flag, _, _), '$get_prolog_impl_flag'(Flag, Term). current_prolog_flag(Flag, Term) :- atom(Flag), !, ( '$prolog_impl_flag'(Flag, _, _) -> '$get_prolog_impl_flag'(Flag, Term) ; illarg(domain(atom,prolog_flag), current_prolog_flag(Flag,Term), 1) ). current_prolog_flag(Flag, Term) :- illarg(type(atom), current_prolog_flag(Flag,Term), 1). '$prolog_impl_flag'(debug, [on,off], changeable(yes)). '$prolog_impl_flag'(max_arity, _, changeable(no)). :- public halt/0. :- public abort/0. halt :- halt(0). abort :- raise_exception('Execution aborted'). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % DCG %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public 'C'/3, expand_term/2. 'C'([X|S], X, S). expand_term(Dcg, Cl) :- var(Dcg), !, Dcg = Cl. expand_term(Dcg, Cl) :- '$dcg_expansion'(Dcg, Cl0), !, Cl0 = Cl. expand_term(Dcg, Dcg). '$dcg_expansion'(Dcg, Cl) :- var(Dcg), !, Dcg = Cl. '$dcg_expansion'((Head --> B), (H1 :- G1, G2)) :- nonvar(Head), Head = (H, List), List = [_|_], !, '$dcg_translation_atom'(H, H1, S0, S1), '$dcg_translation'(B, G1, S0, S), '$dcg_translation'(List, G2, S1, S). '$dcg_expansion'((H --> B), (H1 :- B1)) :- '$dcg_translation_atom'(H, H1, S0, S), '$dcg_translation'(B, B1, S0, S). '$dcg_translation_atom'(X, phrase(X,S0,S), S0, S) :- var(X), !. '$dcg_translation_atom'(M:X, M:X1, S0, S) :- !, '$dcg_translation_atom'(X, X1, S0, S). '$dcg_translation_atom'(X, X1, S0, S) :- X =.. [F|As], '$builtin_append'(As, [S0,S], As1), X1 =.. [F|As1]. '$dcg_translation'(X, Y, S0, S) :- '$dcg_trans'(X, Y0, T, S0, S), '$dcg_trans0'(Y0, Y, T, S0, S). '$dcg_trans0'(Y, Y, T, S0, T) :- T \== S0, !. '$dcg_trans0'(Y0, Y, T, _, S) :- '$dcg_concat'(Y0, S=T, Y). '$dcg_concat'(X, Y, Z) :- X == true, !, Z = Y. '$dcg_concat'(X, Y, Z) :- Y == true, !, Z = X. '$dcg_concat'(X, Y, (X,Y)). '$dcg_trans'(X, X1, S, S0, S) :- var(X), !, '$dcg_translation_atom'(X, X1, S0, S). '$dcg_trans'(M:X, M:Y, T, S0, S) :- !, '$dcg_trans'(X, Y, T, S0, S). '$dcg_trans'([], true, S0, S0, _) :- !. '$dcg_trans'([X|Y], Z, T, S0, S) :- !, '$dcg_trans'(Y, Y1, T, S1, S), '$dcg_concat'('C'(S0,X,S1), Y1, Z). '$dcg_trans'(\+X, (X1 -> fail; S=S0), S, S0, S) :- !, '$dcg_trans'(X, X1, S1, S0, S1). '$dcg_trans'((X,Y), Z, T, S0, S) :- !, '$dcg_trans'(X, X1, S1, S0, S1), '$dcg_trans'(Y, Y1, T, S1, S), '$dcg_concat'(X1, Y1, Z). '$dcg_trans'((X->Y), (X1->Y1), T, S0, S) :- !, '$dcg_trans'(X, X1, S1, S0, S1), '$dcg_trans'(Y, Y1, T, S1, S). '$dcg_trans'((X;Y), (X1;Y1), S, S0, S) :- !, '$dcg_translation'(X, X1, S0, S), '$dcg_translation'(Y, Y1, S0, S). '$dcg_trans'(!, !, S0, S0, _) :- !. '$dcg_trans'({G}, call(G), S0, S0, _) :- var(G), !. '$dcg_trans'({G}, G, S0, S0, _) :- !. '$dcg_trans'(X, X1, S, S0, S) :- '$dcg_translation_atom'(X, X1, S0, S). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Hash creation and control %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public new_hash/1. :- public hash_map/2. :- public hash_exists/1. new_hash(Hash) :- new_hash(Hash, []). hash_map(H_or_a, List) :- hash_keys(H_or_a, Ks0), sort(Ks0, Ks), hash_map(Ks, List, H_or_a). hash_map([], [], _) :- !. hash_map([K|Ks], [(K,V)|Ls], H_or_a) :- hash_get(H_or_a, K, V), hash_map(Ks, Ls, H_or_a). hash_exists(Alias) :- atom(Alias), '$get_hash_manager'(HM), hash_contains_key(HM, Alias). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Prolog interpreter %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- op(1170, xfx, (:-)). :- op(1170, xfx, (-->)). :- op(1170, fx, (:-)). :- op(1170, fx, (?-)). :- op(1150, fx, (package)). :- op(1150, fx, (import)). :- op(1150, fx, (public)). :- op(1150, fx, (dynamic)). :- op(1150, fx, (meta_predicate)). :- op(1150, fx, (mode)). :- op(1150, fx, (multifile)). :- op(1150, fx, (block)). :- public consult_stream/1. :- dynamic '$consulted_file'/1. :- dynamic '$consulted_import'/2. :- dynamic '$consulted_package'/1. :- dynamic '$consulted_predicate'/3. %%% Read Program consult_stream(File, In) :- '$consult_init'(File), repeat, read(In, Cl), '$consult_clause'(Cl), Cl == end_of_file, !. '$consult_init'(File) :- retractall('$consulted_file'(_)), retractall('$consulted_package'(_)), retractall('$consulted_import'(File, _)), retract('$consulted_predicate'(P,PI,File)), abolish(P:PI), fail. '$consult_init'(File) :- assertz('$consulted_file'(File)), assertz('$consulted_package'(user)). '$consult_clause'(end_of_file ) :- !. '$consult_clause'((:- module(P,_)) ) :- !, '$assert_consulted_package'(P). '$consult_clause'((:- package P) ) :- !, '$assert_consulted_package'(P). '$consult_clause'((:- import P) ) :- !, '$assert_consulted_import'(P). '$consult_clause'((:- dynamic _) ) :- !. '$consult_clause'((:- public _) ) :- !. '$consult_clause'((:- meta_predicate _)) :- !. '$consult_clause'((:- mode _) ) :- !. '$consult_clause'((:- multifile _) ) :- !. '$consult_clause'((:- block _) ) :- !. '$consult_clause'((:- G) ) :- !, clause('$consulted_package'(P), _), once(P:G). '$consult_clause'(Clause0) :- '$consult_preprocess'(Clause0, Clause), '$consult_cls'(Clause). '$assert_consulted_package'(P) :- clause('$consulted_package'(P), _), !. '$assert_consulted_package'(P) :- retractall('$consulted_package'(_)), assertz('$consulted_package'(P)). '$assert_consulted_import'(P) :- clause('$consulted_file'(File), _), assertz('$consulted_import'(File, P)). '$consult_preprocess'(Clause0, Clause) :- expand_term(Clause0, Clause). '$consult_cls'((H :- G)) :- !, '$assert_consulted_clause'((H :- G)). '$consult_cls'(H) :- '$assert_consulted_clause'((H :- true)). '$assert_consulted_clause'(Clause) :- Clause = (H :- _), functor(H, F, A), clause('$consulted_file'(File), _), clause('$consulted_package'(P), _), assertz(P:Clause), assertz('$consulted_predicate'(P,F/A,File)), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Misc %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- public reverse/2. :- public length/2. :- public numbervars/3. :- public statistics/2. reverse(Xs, Zs) :- reverse(Xs, [], Zs). reverse([], Zs, Zs). reverse([X|Xs], Tmp, Zs) :- reverse(Xs, [X|Tmp], Zs). length(L, N) :- var(N), !, '$length'(L, 0, N). length(L, N) :- '$length0'(L, 0, N). '$length'([], I, I). '$length'([_|L], I0, I) :- I1 is I0+1, '$length'(L, I1, I). '$length0'([], I, I) :- !. '$length0'([_|L], I0, I) :- I0 < I, I1 is I0+1, '$length0'(L, I1, I). numbervars(X, VI, VN) :- integer(VI), VI >= 0, !, '$numbervars'(X, VI, VN). '$numbervars'(X, VI, VN) :- var(X), !, X = '$VAR'(VI), % This structure is checked in write VN is VI + 1. '$numbervars'(X, VI, VI) :- atomic(X), !. '$numbervars'(X, VI, VI) :- java(X), !. '$numbervars'(X, VI, VN) :- functor(X, _, N), '$numbervars_str'(1, N, X, VI, VN). '$numbervars_str'(I, I, X, VI, VN) :- !, arg(I, X, A), '$numbervars'(A, VI, VN). '$numbervars_str'(I, N, X, VI, VN) :- arg(I, X, A), '$numbervars'(A, VI, VN1), I1 is I + 1, '$numbervars_str'(I1, N, X, VN1, VN). statistics(Key, Value) :- nonvar(Key), '$statistics_mode'(Key), !, '$statistics'(Key, Value). statistics(Key, Value) :- findall(M, '$statistics_mode'(M), Domain), illarg(domain(atom,Domain), statistics(Key,Value), 1). '$statistics_mode'(runtime). '$statistics_mode'(trail). '$statistics_mode'(choice). illarg(Msg, Goal, ArgNo) :- var(Msg), !, illarg(var, Goal, ArgNo). illarg(var, Goal, ArgNo) :- raise_exception(instantiation_error(Goal, ArgNo)). illarg(type(Type), Goal, ArgNo) :- arg(ArgNo, Goal, Arg), ( nonvar(Arg) -> Error = type_error(Goal,ArgNo,Type,Arg) ; Error = instantiation_error(Goal,ArgNo) ), raise_exception(Error). illarg(domain(Type,ExpDomain), Goal, ArgNo) :- arg(ArgNo, Goal, Arg), ( '$match_type'(Type, Arg) -> Error = domain_error(Goal,ArgNo,ExpDomain,Arg) ; nonvar(Arg) -> Error = type_error(Goal,ArgNo,Type,Arg) ; Error = instantiation_error(Goal,ArgNo) ), raise_exception(Error). illarg(existence(ObjType,Culprit,Message), Goal, ArgNo) :- raise_exception(existence_error(Goal,ArgNo,ObjType,Culprit,Message)). illarg(permission(Operation, ObjType, Culprit, Message), Goal, _) :- raise_exception(permission_error(Goal,Operation,ObjType,Culprit,Message)). illarg(representation(Flag), Goal, ArgNo) :- raise_exception(representation_error(Goal,ArgNo,Flag)). illarg(evaluation(Type), Goal, ArgNo) :- raise_exception(evaluation_error(Goal,ArgNo,Type)). illarg(syntax(Type,Culprit,Message), Goal, ArgNo) :- raise_exception(syntax_error(Goal,ArgNo,Type,Culprit,Message)). illarg(system(Message), _, _) :- raise_exception(system_error(Message)). illarg(internal(Message), _, _) :- raise_exception(internal_error(Message)). illarg(java(Exception), Goal, ArgNo) :- raise_exception(java_error(Goal,ArgNo,Exception)). illarg(Msg, _, _) :- raise_exception(Msg). '$match_type'(term, _). '$match_type'(variable, X) :- var(X). '$match_type'(atom, X) :- atom(X). '$match_type'(atomic, X) :- atomic(X). '$match_type'(byte, X) :- integer(X), 0 =< X, X =< 255. '$match_type'(in_byte, X) :- integer(X), -1 =< X, X =< 255. '$match_type'(character, X) :- atom(X), atom_length(X, 1). '$match_type'(in_character, X) :- (X == 'end_of_file' ; '$match_type'(character,X)). '$match_type'(number, X) :- number(X). '$match_type'(integer, X) :- integer(X). '$match_type'(float, X) :- float(X). '$match_type'(callable, X) :- callable(X). '$match_type'(compound, X) :- compound(X). '$match_type'(list, X) :- nonvar(X), (X = [] ; X = [_|_]). '$match_type'(java, X) :- java(X). '$match_type'(stream, X) :- (java(X, 'java.io.PushbackReader') ; java(X, 'java.io.PrintWriter')). '$match_type'(stream_or_alias, X) :- (atom(X) ; '$match_type'(stream, X)). '$match_type'(hash, X) :- java(X, 'com.googlecode.prolog_cafe.lang.HashtableOfTerm'). '$match_type'(hash_or_alias,X) :- (atom(X) ; '$match_type'(hash, X)). '$match_type'(predicate_indicator, X) :- nonvar(X), X = P:F/A, atom(P), atom(F), integer(A). %'$match_type'(evaluable, X). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Utilities %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% '$builtin_append'([], Zs, Zs). '$builtin_append'([X|Xs], Ys, [X|Zs]) :- '$builtin_append'(Xs, Ys, Zs). '$builtin_member'(X, [X|_]). '$builtin_member'(X, [_|L]) :- '$builtin_member'(X, L). '$member_in_reverse'(X, [_|L]) :- '$member_in_reverse'(X, L). '$member_in_reverse'(X, [X|_]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % END - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -