Heimseite
Seitenübersicht
An/abmeldung
Anschlagbrett
Herunterladen(c) 2005-2024 XLOG Technologies AG
/**
* Modern Albufeira Prolog Interpreter
*
* Warranty & Liability
* To the extent permitted by applicable law and unless explicitly
* otherwise agreed upon, XLOG Technologies AG makes no warranties
* regarding the provided information. XLOG Technologies AG assumes
* no liability that any problems might be solved with the information
* provided by XLOG Technologies AG.
*
* Rights & License
* All industrial property rights regarding the information - copyright
* and patent rights in particular - are the sole property of XLOG
* Technologies AG. If the company was not the originator of some
* excerpts, XLOG Technologies AG has at least obtained the right to
* reproduce, change and translate the information.
*
* Reproduction is restricted to the whole unaltered document. Reproduction
* of the information is only allowed for non-commercial uses. Selling,
* giving away or letting of the execution of the library is prohibited.
* The library can be distributed as part of your applications and libraries
* for execution provided this comment remains unchanged.
*
* Restrictions
* Only to be distributed with programs that add significant and primary
* functionality to the library. Not to be distributed with additional
* software intended to replace any components of the library.
*
* Trademarks
* Jekejeke is a registered trademark of XLOG Technologies AG.
*/
import {
add, is_variable, Compound, is_compound
} from "./store.mjs";
import {
call, cont, deref, is_atom,
is_integer, make_error, unify,
is_float, trail, unbind, Choice, more, exec_eval,
exec_unify, exec_build, VAR_MASK_STATE
} from "./machine.mjs";
import {
check_integer, is_bigint, norm_bigint, widen_bigint,
norm_smallint, norm_float, narrow_float, make_special,
check_atom, make_arithmetic, make_check,
char_count, check_nil, MAX_ARITY
} from "./special.mjs";
import {
last_code
} from "./runtime.mjs";
/*********************************************************************/
/* Evaluable Predicates */
/*********************************************************************/
function test_eval(args) {
let res = exec_eval(args[0]);
return exec_unify(args[1], res);
}
/*********************************************************************/
/* (-)/2, (+)/3, (-)/3, (*)/3, (/)/3, (//)/3 and (rem)/3. */
/*********************************************************************/
/**
* -(A, B): [ISO 9.1.7]
* The predicate succeeds in B with the negation of A.
*/
function arit_neg(args) {
let alpha = exec_eval(args[0]);
return -alpha;
}
/**
* +(A, B, C): [ISO 9.1.7]
* The predicate succeeds in C with the sum of A and B.
*/
function arit_add(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
if (is_integer(alpha) && is_integer(beta)) {
if (!is_bigint(alpha) && !is_bigint(beta)) {
return norm_smallint(alpha + beta);
} else {
return norm_bigint(widen_bigint(alpha) + widen_bigint(beta));
}
} else {
return norm_float(narrow_float(alpha) + narrow_float(beta));
}
}
/**
* -(A, B, C):
* The predicate succeeds in C with A subtracted by B.
*/
function arit_sub(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
if (is_integer(alpha) && is_integer(beta)) {
if (!is_bigint(alpha) && !is_bigint(beta)) {
return norm_smallint(alpha - beta);
} else {
return norm_bigint(widen_bigint(alpha) - widen_bigint(beta));
}
} else {
return norm_float(narrow_float(alpha) - narrow_float(beta));
}
}
/**
* *(A, B, C): [ISO 9.1.7]
* The predicate succeeds in C with the product of A and B.
*/
function arit_mul(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
if (is_integer(alpha) && is_integer(beta)) {
if (!is_bigint(alpha) && !is_bigint(beta)) {
return norm_smallint(alpha * beta);
} else {
return norm_bigint(widen_bigint(alpha) * widen_bigint(beta));
}
} else {
return norm_float(narrow_float(alpha) * narrow_float(beta));
}
}
/**
* /(A, B, C): [ISO 9.1.7]
* The predicate succeeds in C with A float divided by B.
*/
function arit_quot(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
beta = narrow_float(beta);
if (beta === 0)
throw make_error(new Compound("evaluation_error",["zero_divisor"]));
return norm_float(narrow_float(alpha) / beta);
}
/**
* //(A, B, C): [ISO 9.1.7]
* The predicate succeeds in C with A truncate divided by B.
*/
function arit_intquot(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (beta === 0)
throw make_error(new Compound("evaluation_error",["zero_divisor"]));
if (!is_bigint(alpha) && !is_bigint(beta)) {
return Math.trunc(alpha / beta);
} else {
return norm_bigint(widen_bigint(alpha) / widen_bigint(beta));
}
}
/**
* rem(A, B, C): [ISO 9.1.7]
* The predicate succeeds in C with A remainder B.
*/
function arit_rem(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (beta === 0)
throw make_error(new Compound("evaluation_error",["zero_divisor"]));
if (!is_bigint(alpha) && !is_bigint(beta)) {
return alpha % beta;
} else {
return norm_bigint(widen_bigint(alpha) % widen_bigint(beta));
}
}
/*********************************************************************/
/* float/1, (^)/3, div/3 and mod/3. */
/*********************************************************************/
/**
* float(A, B): [ISO 9.17]
* The predicate succeeds in B with the approximated A.
*/
function arit_float(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
return norm_float(narrow_float(alpha));
} else {
return alpha;
}
}
/**
* ^(A, B, C): [TC2 9.3.10]
* The predicate succeeds in C with A int power by B.
*/
function arit_intpow(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
if (is_integer(alpha) && is_integer(beta)) {
if (beta < 0)
throw make_error(new Compound("domain_error",
["not_less_than_zero", beta]));
if (!is_bigint(alpha) && !is_bigint(beta)) {
if ((32 - Math.clz32(Math.abs(alpha))) * beta < 53) {
return norm_smallint(Math.pow(alpha, beta));
} else {
return norm_bigint(widen_bigint(alpha) ** widen_bigint(beta));
}
} else {
return norm_bigint(widen_bigint(alpha) ** widen_bigint(beta));
}
} else {
return norm_float(Math.pow(narrow_float(alpha), narrow_float(beta)));
}
}
/**
* div(A, B, C): [TC2 9.1.3]
* The predicate succeeds in C with A floor divided by B.
*/
function arit_div(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (beta === 0)
throw make_error(new Compound("evaluation_error", ["zero_divisor"]));
if (!is_bigint(alpha) && !is_bigint(beta)) {
return Math.floor(alpha / beta);
} else {
return norm_bigint(bigint_div(
widen_bigint(alpha), widen_bigint(beta)));
}
}
function bigint_div(alpha, beta) {
let temp = alpha / beta;
if ((alpha < 0) !== (beta < 0)) {
let res = alpha % beta;
if (res !== 0)
temp--;
}
return temp;
}
/**
* mod(A, B, C): [ISO 9.1.7]
* The predicate succeeds in C with A modulus B.
*/
function arit_mod(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (beta === 0)
throw make_error(new Compound("evaluation_error",["zero_divisor"]));
if (!is_bigint(alpha) && !is_bigint(beta)) {
return number_mod(alpha, beta);
} else {
return norm_bigint(number_mod(
widen_bigint(alpha), widen_bigint(beta)));
}
}
function number_mod(alpha, beta) {
let res = alpha % beta;
if ((alpha < 0) !== (beta < 0)) {
if (res !== 0)
res += beta;
}
return res;
}
/*********************************************************************/
/* abs/2, sign/2, min/3 and max/3 */
/*********************************************************************/
/**
* abs(A, B): [ISO 9.1.7]
* The predicate succeeds in B with the absolute value of A.
*/
function arit_abs(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
if (alpha < 0) {
return -alpha;
} else {
return alpha;
}
} else {
return norm_float(Math.abs(narrow_float(alpha)));
}
}
/**
* sign(A, B): [ISO 9.1.4]
* The predicate succeeds in B with the sign of A.
*/
function arit_sign(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
if (alpha < 0) {
return -1;
} else if (alpha > 0) {
return 1;
} else {
return 0;
}
} else {
return norm_float(Math.sign(narrow_float(alpha)));
}
}
/**
* min(A, B, C): [TC2 9.3.9]
* The predicate succeeds in C with the minimum of A and B.
*/
function arit_min(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
if (is_integer(alpha) && is_integer(beta)) {
if (alpha < beta) {
return alpha;
} else {
return beta;
}
} else {
return norm_float(Math.min(
narrow_float(alpha), narrow_float(beta)));
}
}
/**
* max(A, B, C): [TC2 9.3.8]
* The predicate succeeds in C with the maximum of A and B.
*/
function arit_max(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
if (is_integer(alpha) && is_integer(beta)) {
if (alpha > beta) {
return alpha;
} else {
return beta;
}
} else {
return norm_float(Math.max(
narrow_float(alpha), narrow_float(beta)));
}
}
/*********************************************************************/
/* truncate/2, floor/2, ceiling/2 and round/2 */
/*********************************************************************/
/**
* truncate(A, B): [ISO 9.1.7]
* The predicate succeeds in B with the truncate of A.
*/
function arit_truncate(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
return alpha;
} else {
return norm_smallint(Math.trunc(narrow_float(alpha)));
}
}
/**
* floor(A, B): [ISO 9.1.7]
* The predicate succeeds in B with the floor of A.
*/
function arit_floor(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
return alpha;
} else {
return norm_smallint(Math.floor(narrow_float(alpha)));
}
}
/**
* ceiling(A, B): [ISO 9.1.7]
* The predicate succeeds in B with the ceiling of A.
*/
function arit_ceiling(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
return alpha;
} else {
return norm_smallint(Math.ceil(narrow_float(alpha)));
}
}
/**
* round(A, B): [ISO 9.1.7]
* The predicate succeeds in B with the rounding of A.
*/
function arit_round(args) {
let alpha = exec_eval(args[0]);
if (is_integer(alpha)) {
return alpha;
} else {
return norm_smallint(Math.round(narrow_float(alpha)));
}
}
/*********************************************************************/
/* =:=/2, =\=/2, </2, >=/2, >/2 and =</2 */
/*********************************************************************/
/**
* X =:= Y: [ISO 8.7.1]
* The predicate succeeds when X number equals Y, otherwise fails.
*/
function test_numberequal(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return number_equal(alpha, beta);
}
/**
* X =\= Y: [ISO 8.7.1]
* The predicate succeeds when X does not number equal Y, otherwise fails.
*/
function test_numbernotequal(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return !number_equal(alpha, beta);
}
/**
* Determine whether two Prolog numbers are equal.
*
* @param alpha The first Prolog number.
* @param beta The second Prolog number.
* @return boolean True if the two Prolog numbers are equal.
*/
function number_equal(alpha, beta) {
if (is_integer(alpha) && is_integer(beta)) {
return alpha === beta;
} else {
return narrow_float(alpha) === narrow_float(beta);
}
}
/**
* X < Y: [ISO 8.7.1]
* The predicate succeeds when X is number less than Y, otherwise fails.
*/
function test_numberless(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return number_less(alpha, beta);
}
/**
* X >= Y: [ISO 8.7.1]
* The predicate succeeds when X is number greater or equal to Y, otherwise fails.
*/
function test_numbergreaterequal(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return !number_less(alpha, beta);
}
/**
* X > Y: [ISO 8.7.1]
* The predicate succeeds when X is number greater than Y, otherwise fails.
*/
function test_numbergreater(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return number_less(beta, alpha);
}
/**
* X =< Y: [ISO 8.7.1]
* The predicate succeeds when X is number less or equal to Y, otherwise fails.
*/
function test_numberlessequal(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return !number_less(beta, alpha);
}
/**
* Determine whether a Prolog numbers is less than a Prolog number.
*
* @param alpha The first Prolog number.
* @param beta The second Prolog number.
* @return boolean True if the two Prolog numbers are equal.
*/
function number_less(alpha, beta) {
if (is_integer(alpha) && is_integer(beta)) {
return alpha < beta;
} else {
return narrow_float(alpha) < narrow_float(beta);
}
}
/*********************************************************************/
/* sin/3, cos/2, tan/2, asin/2, acos/2, atan/2 and pi/1. */
/*********************************************************************/
/**
* sin(A, B): [ISO 9.3.2]
* The predicate succeeds in B with the sine of A.
*/
function arit_sin(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.sin(narrow_float(alpha)));
}
/**
* cos(A, B): [ISO 9.3.3]
* The predicate succeeds in B with the cosine of A.
*/
function arit_cos(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.cos(narrow_float(alpha)));
}
/**
* tan(A, B): [TC2 9.3.14]
* The predicate succeeds in B with the tangent of A.
*/
function arit_tan(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.tan(narrow_float(alpha)));
}
/**
* asin(A, B): [TC2 9.3.11]
* The predicate succeeds in B with the arcus sine of A.
*/
function arit_asin(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.asin(narrow_float(alpha)));
}
/**
* acos(A, B): [TC2 9.3.12]
* The predicate succeeds in B with the arcus cosine of A.
*/
function arit_acos(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.acos(narrow_float(alpha)));
}
/**
* atan(A, B): [ISO 9.3.4]
* The predicate succeeds in B with the arcus tangent of A.
*/
function arit_atan(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.atan(narrow_float(alpha)));
}
/**
* pi(A): [TC2 9.3.15]
* The predicate succeeds in A with π.
*/
function arit_pi(args) {
return Math.PI;
}
/*********************************************************************/
/* (**)/3, exp/2, log/2, sqrt/2 and e/1 */
/*********************************************************************/
/**
* **(A, B, C): [ISO 9.3.1]
* The predicate succeeds in C with A float power by B.
*/
function arit_pow(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
return norm_float(Math.pow(narrow_float(alpha), narrow_float(beta)));
}
/**
* exp(A, B): [ISO 9.3.5]
* The predicate succeeds in B with e power by A.
*/
function arit_exp(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.exp(narrow_float(alpha)));
}
/**
* log(A, B): [ISO 9.3.6]
* The predicate succeeds in B with the natural logarithm of A.
*/
function arit_log(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.log(narrow_float(alpha)));
}
/**
* sqrt(A, B): [ISO 9.3.7]
* The predicate succeeds in B with the square root of A.
*/
function arit_sqrt(args) {
let alpha = exec_eval(args[0]);
return norm_float(Math.sqrt(narrow_float(alpha)));
}
/**
* e(A): [N208 9.7.2]
* The predicate succeeds in A with the Euler number.
*/
function arit_e(args) {
return Math.E;
}
/**
* epsilon(A): [N208 9.7.3]
* The predicate succeeds in A with the machine epsilon.
*/
function arit_epsilon(args) {
return Number.EPSILON;
}
/**
* atan2(A, B, C): [TC2 9.3.13]
* The predicate succeeds in C with the arc tangent of A and B.
*/
function arit_atan2(args) {
let alpha = exec_eval(args[0]);
let beta = exec_eval(args[1]);
alpha = narrow_float(alpha);
beta = narrow_float(beta);
if (alpha === 0 && beta === 0) {
throw make_error(new Compound("evaluation_error", ["undefined"]));
} else {
return norm_float(Math.atan2(alpha, beta));
}
}
/*********************************************************************/
/* (\)/2, (/\)/3, (\/)/3, (xor)/3, (>>)/3 and (<</3) */
/*********************************************************************/
/**
* \(A, B): [ISO 9.4.5]
* The predicate succeeds in B with the bitwise not of A.
*/
function arit_not(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
return ~alpha;
}
/**
* /\(A, B, C): [ISO 9.4.3]
* The predicate succeeds in C with the bitwise and of A and B.
*/
function arit_and(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (!is_bigint(alpha) && !is_bigint(beta)) {
return alpha & beta;
} else {
return norm_bigint(widen_bigint(alpha) & widen_bigint(beta));
}
}
/**
* \/(A, B, C): [ISO 9.4.4]
* The predicate succeeds in C with the bitwise or of A and B.
*/
function arit_or(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (!is_bigint(alpha) && !is_bigint(beta)) {
return norm_smallint(alpha | beta);
} else {
return norm_bigint(widen_bigint(alpha) | widen_bigint(beta));
}
}
/**
* xor(A, B, C): [TC2 9.4.6]
* The predicate succeeds in C with the bitwise xor of A and B.
*/
function arit_xor(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (!is_bigint(alpha) && !is_bigint(beta)) {
return norm_smallint(alpha ^ beta);
} else {
return norm_bigint(widen_bigint(alpha) ^ widen_bigint(beta));
}
}
/**
* >>(A, B, C): [ISO 9.4.1]
* The predicate succeeds in C with A shift right by B.
*/
function arit_shiftright(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (!is_bigint(alpha) && !is_bigint(beta)) {
if (0 <= beta && beta < 32) {
return alpha >> beta;
} else if (0 > beta && beta < Math.clz32(Math.abs(alpha)) - 1) {
return norm_smallint(alpha << -beta);
} else {
return norm_bigint(widen_bigint(alpha) >> widen_bigint(beta));
}
} else {
return norm_bigint(widen_bigint(alpha) >> widen_bigint(beta));
}
}
/**
* <<(A, B, C): [ISO 9.4.2]
* The predicate succeeds in C with A shift left by B.
*/
function arit_shiftleft(args) {
let alpha = exec_eval(args[0]);
check_integer(alpha);
let beta = exec_eval(args[1]);
check_integer(beta);
if (!is_bigint(alpha) && !is_bigint(beta)) {
if (0 < beta && beta < Math.clz32(Math.abs(alpha)) - 1) {
return norm_smallint(alpha << beta);
} else if (0 >= beta && -beta < 32) {
return alpha >> -beta;
} else {
return norm_bigint(widen_bigint(alpha) << widen_bigint(beta));
}
} else {
return norm_bigint(widen_bigint(alpha) << widen_bigint(beta));
}
}
/*********************************************************************/
/* ==/2, \==/2, @<, @=<, @>, @>= and compare/3 */
/*********************************************************************/
/**
* S == T: [ISO 8.4.1]
* The built-in succeeds when S and T are syntactically equivalent
* Prolog terms, otherwise the built-in fails.
*/
function test_equal(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return equal_term(alpha, beta);
}
/**
* S \== T: [ISO 8.4.1]
* The built-in succeeds when S and T are not syntactically equivalent
* Prolog terms, otherwise the built-in fails.
*/
function test_notequal(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return !equal_term(alpha, beta);
}
/**
* Determine whether two Prolog terms are syntactically equivalent.
* Tail recursive solution.
*
* @param first The first Prolog term.
* @param second The second Prolog term.
* @return boolean True if they are syntactically equivalent, otherwise false.
*/
export function equal_term(first, second) {
for (; ;) {
first = deref(first);
second = deref(second);
if (!is_compound(first))
return (first === second);
if (!is_compound(second))
return false;
if (first.args.length !== second.args.length)
return false;
if (first.functor !== second.functor)
return false;
first = first.args;
second = second.args;
let i = 0;
for (; i < first.length - 1; i++) {
if (!equal_term(first[i], second[i]))
return false;
}
first = first[i];
second = second[i];
}
}
/**
* X @< Y: [ISO 8.4.1]
* The predicate succeeds when X is syntactically less than Y, otherwise fails.
*/
function test_less(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return compare_term(alpha, beta) < 0;
}
/**
* X @>= Y: [ISO 8.4.1]
* The predicate succeeds when X is syntactically greater or equal to Y, otherwise fails.
*/
function test_greaterequal(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return compare_term(alpha, beta) >= 0;
}
/**
* X @> Y: [ISO 8.7.1]
* The predicate succeeds when X is syntactically greater than Y, otherwise fails.
*/
function test_greater(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return compare_term(alpha, beta) > 0;
}
/**
* X @=< Y: [ISO 8.7.1]
* The predicate succeeds when X is syntactically less or equal to Y, otherwise fails.
*/
function test_lessequal(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return compare_term(alpha, beta) <= 0;
}
function test_compare(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
let gamma = exec_build(args[2]);
beta = compare_term(beta, gamma);
if (beta < 0) {
beta = "<";
} else if (beta === 0) {
beta = "=";
} else {
beta = ">";
}
return unify(alpha, beta);
}
/**
* Determine the syntactic relationship between two Prolog terms.
*
* @param first The first Prolog term.
* @param second The second Prolog term.
* @return number <0 for less, =0 for equal and >0 for greater
*/
export function compare_term(first, second) {
for (; ;) {
first = deref(first);
second = deref(second);
let i = compare_type(first);
let k = i - compare_type(second);
if (k !== 0)
return k;
switch (i) {
case 0:
return (first.flags & ~VAR_MASK_STATE) -
(second.flags & ~VAR_MASK_STATE);
case 1:
return compare_atomic(first, second);
case 2:
return compare_atomic(first, second);
case 3:
return compare_atomic(order_value(first), order_value(second));
case 4:
return compare_atomic(first, second);
case 5:
k = first.args.length - second.args.length;
if (k !== 0)
return k;
k = compare_atomic(first.functor, second.functor);
if (k !== 0)
return k;
first = first.args;
second = second.args;
let i = 0;
for (; i < first.length - 1; i++) {
k = compare_term(first[i], second[i]);
if (k !== 0) return k;
}
first = first[i];
second = second[i];
break;
default:
throw make_error(new Compound(
"system_error", ["unknown_type"]));
}
}
}
/**
* Determine the compare type of a Prolog term.
*
* @param first The Prolog term.
* @return number The compare type.
*/
function compare_type(first) {
if (is_variable(first)) {
return 0;
} else if (is_compound(first)) {
return 5;
} else if (is_atom(first)) {
return 4;
} else if (is_integer(first)) {
return 2;
} else if (is_float(first)) {
return 1;
} else {
return 3;
}
}
/**
* Determine the order value of a Prolog reference.
*
* @param first The Prolog reference.
* @return number The order value.
*/
function order_value(first) {
if (first === false) {
return 0;
} else if (first === true) {
return 1;
} else if (first === null) {
return -1;
} else {
throw make_error(new Compound("resource_error", ["not_supported"]));
}
}
/**
* Determine the syntactic relationship between two Prolog atomics.
*
* @param first The first Prolog atomic.
* @param second The second Prolog atomic.
* @return number -1 for less, 0 for equal and 1 for greater
*/
function compare_atomic(first,second) {
if (first < second)
return -1;
if (first === second)
return 0;
return 1;
}
/*********************************************************************/
/* atom_codes/2 and char_code/2 */
/*********************************************************************/
/**
* atom_codes(A, L): [ISO 8.16.5]
* If A is a variable, the built-in succeeds in A with the atom
* for the Prolog list L. Otherwise the built-in succeeds in L
* with the Prolog list from the atom A.
*/
function test_atom_codes(args) {
let text = deref(exec_build(args[0]));
if (is_variable(text)) {
let res = deref(exec_build(args[1]));
res = atom_codes_pack(res);
return unify(text, res);
} else {
check_atom(text);
text = atom_codes_unpack(text);
return exec_unify(args[1], text);
}
}
function atom_codes_pack(peek) {
let temp = peek;
let i = 0;
while (is_compound(temp) && temp.functor === "."
&& temp.args.length === 2 && i < MAX_ARITY) {
let ch = deref(temp.args[0]);
check_integer(ch);
if (ch < 0 || ch > 0x10FFFF)
throw make_error(new Compound("domain_error", ["code_point", ch]));
i++;
temp = deref(temp.args[1]);
}
check_nil(temp);
let res = new Array(i);
temp = peek;
i = 0;
while (is_compound(temp) && temp.functor === "." && temp.args.length === 2) {
let ch = deref(temp.args[0]);
res[i++] = ch;
temp = deref(temp.args[1]);
}
return String.fromCodePoint(...res);
}
function atom_codes_unpack(text) {
let back = null;
let res;
let i = 0;
while (i < text.length) {
let ch = text.codePointAt(i);
let peek = new Compound(".", [ch, undefined]);
if (back !== null) {
back.args[1] = peek;
} else {
res = peek;
}
back = peek;
i += char_count(ch);
}
if (back !== null) {
back.args[1] = "[]";
} else {
res = "[]";
}
return res;
}
/**
* char_code(C, N): [ISO 8.16.6]
* If C is a variable, the built-in succeeds in C with the
* character for the code N. Otherwise the built-in succeeds
* in N with the code from character C.
*/
function test_char_code(args) {
let text = deref(exec_build(args[0]));
if (is_variable(text)) {
let ch = deref(exec_build(args[1]));
check_integer(ch);
if (ch < 0 || ch > 0x10FFFF)
throw make_error(new Compound("domain_error", ["code_point", ch]));
ch = String.fromCodePoint(ch);
return unify(text, ch);
} else {
check_atom(text);
let ch;
if (text.length === 0 ||
text.length !== char_count(ch = text.codePointAt(0)))
throw make_error(new Compound("type_error", ["character", text]));
return exec_unify(args[1], ch);
}
}
/*********************************************************************/
/* atom_length/2 */
/*********************************************************************/
/**
* atom_length(X, Y): [ISO 8.16.1]
* The predicate succeeds in Y with the length of the atom X.
*/
function test_atom_length(args) {
let text = deref(exec_build(args[0]));
check_atom(text);
let res = atom_count(text, 0, text.length);
return exec_unify(args[1], norm_smallint(res));
}
function atom_count(text, from, to) {
let res = 0;
while (from < to) {
let ch = text.codePointAt(from);
from += char_count(ch);
res ++;
}
return res;
}
/*********************************************************************/
/* atom_split/3 and atom_arg/3 */
/*********************************************************************/
/**
* atom_split(A, D, L):
* The built-in succeeds when L is the split of the atom A by the delimiter D.
*/
function test_atom_split(args) {
let text = deref(exec_build(args[0]));
let dele = deref(exec_build(args[1]));
check_atom(dele);
if (is_variable(text)) {
let res = deref(exec_build(args[2]));
let val = atom_split_pack(dele, res);
return unify(text, val);
} else {
check_atom(text);
text = atom_split_unpack(text, dele);
return exec_unify(args[2], text);
}
}
function atom_split_pack(dele, res) {
let peek = res;
let i = 0;
while (is_compound(peek) && peek.functor === "."
&& peek.args.length === 2 && i < MAX_ARITY) {
i++;
peek = deref(peek.args[1]);
}
check_nil(peek);
let elems = new Array(i);
peek = res;
i = 0;
while (is_compound(peek) && peek.functor === "." && peek.args.length === 2) {
let val = deref(peek.args[0]);
check_atom(val);
elems[i++] = val;
peek = deref(peek.args[1]);
}
return elems.join(dele);
}
function atom_split_unpack(text, dele) {
let res = "[]";
let pos = text.length;
let found = (pos >= dele.length ? text.lastIndexOf(dele, pos-dele.length) : -1);
while (found !== -1) {
let val = text.substring(found+dele.length, pos);
res = new Compound(".", [val, res]);
pos = found;
found = (pos >= dele.length ? text.lastIndexOf(dele, pos-dele.length) : -1);
}
let val = text.substring(0, pos);
res = new Compound(".", [val, res]);
return res;
}
/**
* atom_arg(K, X, Y):
* The predicate succeeds in Y with the zero-based K-th code point of X.
*/
function test_atom_arg(args) {
let alpha = deref(exec_build(args[0]));
check_integer(alpha);
let text = deref(exec_build(args[1]));
check_atom(text);
alpha = atom_offset(text, 0, alpha);
if (alpha < 0 || alpha >= text.length)
return false;
return exec_unify(args[2], text.codePointAt(alpha));
}
function atom_offset(text,pos,alpha) {
if (alpha < 0)
return -1;
while (alpha > 0 && pos < text.length) {
let ch = text.codePointAt(pos);
pos += char_count(ch);
alpha--;
}
if (alpha > 0)
return -1;
return pos;
}
/*********************************************************************/
/* atom_concat/3 */
/*********************************************************************/
/**
* atom_concat(X, Y, Z): [ISO 8.16.2]
* The built-in succeeds when Z is the concatenation of X and Y.
*/
function special_atom_concat(args) {
let first = deref(args[0]);
let second = deref(args[1]);
let third = deref(args[2]);
if (is_variable(second)) {
if (is_variable(first)) {
check_atom(third);
return solve2_concat(args, null, 0, null);
} else {
check_atom(first);
check_atom(third);
if (!third.startsWith(first))
return false;
if (!unify(second, third.substring(first.length)))
return false;
}
} else if (is_variable(first)) {
check_atom(second);
check_atom(third);
if (!third.endsWith(second))
return false;
if (!unify(first, third.substring(0,third.length-second.length)))
return false;
} else {
check_atom(first);
check_atom(second);
if (!unify(third, first + second))
return false;
}
cont(call.args[1]);
return true;
}
function solve_concat(rope, at, choice) {
let goal = deref(call.args[0]);
return solve2_concat(goal.args, rope, at, choice);
}
function solve2_concat(args, rope, at, choice) {
let text = deref(args[2]);
let mark = trail;
while (at <= text.length) {
if (unify(args[0], text.substring(0, at)) &&
unify(args[1], text.substring(at))) {
at = atom_succ(text,at);
if (at <= text.length) {
if (choice === null) {
choice = new Choice(solve_concat, null, at, mark);
} else {
choice.at = at;
}
more(choice);
}
cont(call.args[1]);
return true;
}
unbind(mark);
at = atom_succ(text,at);
}
return false;
}
function atom_succ(text, at) {
if (at < text.length) {
let ch = text.codePointAt(at);
return at + char_count(ch);
} else {
return at + 1;
}
}
/*********************************************************************/
/* sys_atom_match/3 and sys_atom_part/4 */
/*********************************************************************/
/**
* sys_atom_match(X, Y, Z):
* The built-in succeeds if X has substring Y at Z.
*/
function special_sys_atom_match(args) {
let text = deref(args[0]);
check_atom(text);
let part = deref(args[1]);
check_atom(part);
let alpha = deref(args[2]);
if (is_variable(alpha)) {
return solve2_match(args, 0, 0, null);
} else {
check_integer(alpha);
alpha = atom_offset(text, 0, alpha);
if (alpha < 0)
return false;
if (!text.startsWith(part, alpha))
return false;
}
cont(call.args[1]);
return true;
}
function solve_match(rope, at, choice) {
let goal = deref(call.args[0]);
return solve2_match(goal.args, rope, at, choice);
}
function solve2_match(args, res, at, choice) {
let text = deref(args[0]);
let part = deref(args[1]);
let mark = trail;
while (at + part.length <= text.length) {
let pos = text.indexOf(part, at);
if (pos < 0)
return false;
res += atom_count(text, at, pos);
at = pos;
if (unify(args[2], norm_smallint(res))) {
at = atom_succ(text, at);
res++;
if (at + part.length <= text.length) {
if (choice === null) {
choice = new Choice(solve_match, res, at, mark);
} else {
choice.data = res;
choice.at = at;
}
more(choice);
}
cont(call.args[1]);
return true;
}
unbind(mark);
at = atom_succ(text,at);
res++;
}
return false;
}
/**
* sys_atom_part(X, Y, Z, T):
* The built-in succeeds in T with the substring at
* offset Y and with length Z from X.
*/
function special_sys_atom_part(args) {
let text = deref(args[0]);
check_atom(text);
let alpha = deref(args[1]);
if (is_variable(alpha)) {
let beta = deref(args[2]);
check_integer(beta);
beta = atom_offset(text, 0, beta);
if (beta < 0)
return false;
return solve2_part(args, [0,0], beta, null);
} else {
check_integer(alpha);
let beta = deref(args[2]);
check_integer(beta);
alpha = atom_offset(text, 0, alpha);
if (alpha < 0)
return false;
beta = atom_offset(text, alpha, beta);
if (beta < 0)
return false;
if (!unify(args[3], text.substring(alpha, beta)))
return false;
}
cont(call.args[1]);
return true;
}
function solve_part(rope, at, choice) {
let goal = deref(call.args[0]);
return solve2_part(goal.args, rope, at, choice);
}
function solve2_part(args, pair, to, choice) {
let text = deref(args[0]);
let mark = trail;
while (to <= text.length) {
if (unify(args[1], norm_smallint(pair[1])) &&
unify(args[3], text.substring(pair[0], to))) {
pair[0] = atom_succ(text, pair[0]);
pair[1]++;
to = atom_succ(text, to);
if (to <= text.length) {
if (choice === null) {
choice = new Choice(solve_part, pair, to, mark);
} else {
choice.at = to;
}
more(choice);
}
cont(call.args[1]);
return true;
}
unbind(mark);
pair[0] = atom_succ(text, pair[0]);
pair[1]++;
to = atom_succ(text, to);
}
return false;
}
/*********************************************************************/
/* sys_last_atom_match/3 and sys_last_atom_part/4 */
/*********************************************************************/
/**
* sys_last_atom_match(X, Y, Z):
* The built-in succeeds if X has substring Y at Z.
*/
function special_sys_last_atom_match(args) {
let text = deref(args[0]);
check_atom(text);
let part = deref(args[1]);
check_atom(part);
let alpha = deref(args[2]);
if (is_variable(alpha)) {
let at = text.length - part.length;
let res = atom_count(text, 0, at);
return solve2_last_match(args, res, at, null);
} else {
check_integer(alpha);
alpha = atom_offset(text, 0, alpha);
if (alpha < 0)
return false;
if (!text.startsWith(part, alpha))
return false;
}
cont(call.args[1]);
return true;
}
function solve_last_match(rope, at, choice) {
let goal = deref(call.args[0]);
return solve2_last_match(goal.args, rope, at, choice);
}
function solve2_last_match(args, res, at, choice) {
let text = deref(args[0]);
let part = deref(args[1]);
let mark = trail;
while (at >= 0) {
let pos = text.lastIndexOf(part, at);
if (pos < 0)
return false;
res -= atom_count(text, pos, at);
at = pos;
if (unify(args[2], norm_smallint(res))) {
at = atom_pred(text, at);
res--;
if (at >= 0) {
if (choice === null) {
choice = new Choice(solve_last_match, res, at, mark);
} else {
choice.data = res;
choice.at = at;
}
more(choice);
}
cont(call.args[1]);
return true;
}
unbind(mark);
at = atom_pred(text, at);
res--;
}
return false;
}
function atom_pred(text, at) {
if (0 < at) {
let ch = last_code(text, at);
return at - char_count(ch);
} else {
return at - 1;
}
}
/**
* sys_last_atom_part(X, Y, Z, T):
* The built-in succeeds in T with the substring at
* offset Y and with length Z from X.
*/
function special_sys_last_atom_part(args) {
let text = deref(args[0]);
check_atom(text);
let alpha = deref(args[1]);
if (is_variable(alpha)) {
let beta = deref(args[2]);
check_integer(beta);
beta = last_atom_offset(text, text.length, beta);
if (beta < 0)
return false;
let res = atom_count(text, 0, beta);
return solve2_last_part(args, [beta,res], text.length, null);
} else {
check_integer(alpha);
let beta = deref(args[2]);
check_integer(beta);
alpha = atom_offset(text, 0, alpha);
if (alpha < 0)
return false;
beta = atom_offset(text, alpha, beta);
if (beta < 0)
return false;
if (!unify(args[3], text.substring(alpha, beta)))
return false;
}
cont(call.args[1]);
return true;
}
function last_atom_offset(text,pos,alpha) {
if (alpha < 0)
return -1;
while (alpha > 0 && 0 < pos) {
let ch = last_code(text, pos);
pos -= char_count(ch);
alpha--;
}
if (alpha > 0)
return -1;
return pos;
}
function solve_last_part(rope, at, choice) {
let goal = deref(call.args[0]);
return solve2_last_part(goal.args, rope, at, choice);
}
function solve2_last_part(args, pair, to, choice) {
let text = deref(args[0]);
let mark = trail;
while (pair[0] >= 0) {
if (unify(args[1], norm_smallint(pair[1])) &&
unify(args[3], text.substring(pair[0], to))) {
pair[0] = atom_pred(text, pair[0]);
pair[1]--;
to = atom_pred(text, to);
if (pair[0] >= 0) {
if (choice === null) {
choice = new Choice(solve_last_part, pair, to, mark);
} else {
choice.at = to;
}
more(choice);
}
cont(call.args[1]);
return true;
}
unbind(mark);
pair[0] = atom_pred(text, pair[0]);
pair[1]--;
to = atom_pred(text, to);
}
return false;
}
/*********************************************************************/
/* Eval Init */
/*********************************************************************/
// number specials, basic predicates
add("$EVAL", 2, make_check(test_eval));
// number specials, basic operations
add("-", 2, make_arithmetic(arit_neg));
add("+", 3, make_arithmetic(arit_add));
add("-", 3, make_arithmetic(arit_sub));
add("*", 3, make_arithmetic(arit_mul));
add("/", 3, make_arithmetic(arit_quot));
add("//", 3, make_arithmetic(arit_intquot));
add("rem", 3, make_arithmetic(arit_rem));
// number specials, more operations
add("float", 2, make_arithmetic(arit_float));
add("^", 3, make_arithmetic(arit_intpow));
add("div", 3, make_arithmetic(arit_div));
add("mod", 3, make_arithmetic(arit_mod));
// number specials, magnitude operations
add("abs", 2, make_arithmetic(arit_abs));
add("sign", 2, make_arithmetic(arit_sign));
add("min", 3, make_arithmetic(arit_min));
add("max", 3, make_arithmetic(arit_max));
// number specials, rounding operations
add("truncate", 2, make_arithmetic(arit_truncate));
add("floor", 2, make_arithmetic(arit_floor));
add("ceiling", 2, make_arithmetic(arit_ceiling));
add("round", 2, make_arithmetic(arit_round));
// number specials, magnitude predicates
add("=:=", 2, make_check(test_numberequal));
add("=\\=", 2, make_check(test_numbernotequal));
add("<", 2, make_check(test_numberless));
add(">=", 2, make_check(test_numbergreaterequal));
add(">", 2, make_check(test_numbergreater));
add("=<", 2, make_check(test_numberlessequal));
// number specials, trigonometric operations
add("sin", 2, make_arithmetic(arit_sin));
add("cos", 2, make_arithmetic(arit_cos));
add("tan", 2, make_arithmetic(arit_tan));
add("asin", 2, make_arithmetic(arit_asin));
add("acos", 2, make_arithmetic(arit_acos));
add("atan", 2, make_arithmetic(arit_atan));
add("pi", 1, make_arithmetic(arit_pi));
// number specials, exponential operations
add("**", 3, make_arithmetic(arit_pow));
add("exp", 2, make_arithmetic(arit_exp));
add("log", 2, make_arithmetic(arit_log));
add("sqrt", 2, make_arithmetic(arit_sqrt));
add("e", 1, make_arithmetic(arit_e));
add("epsilon", 1, make_arithmetic(arit_epsilon));
add("atan2", 3, make_arithmetic(arit_atan2));
// number specials, bitwise operations
add("\\", 2, make_arithmetic(arit_not));
add("/\\", 3, make_arithmetic(arit_and));
add("\\/", 3, make_arithmetic(arit_or));
add("xor", 3, make_arithmetic(arit_xor));
add(">>", 3, make_arithmetic(arit_shiftright));
add("<<", 3, make_arithmetic(arit_shiftleft));
// term specials, syntactic comparison
add("==", 2, make_check(test_equal));
add("\\==", 2, make_check(test_notequal));
add("@<", 2, make_check(test_less));
add("@>=", 2, make_check(test_greaterequal));
add("@>", 2, make_check(test_greater));
add("@=<", 2, make_check(test_lessequal));
add("compare", 3, make_check(test_compare));
// atom specials, standard
add("atom_codes", 2, make_check(test_atom_codes));
add("char_code", 2, make_check(test_char_code));
add("atom_length", 2, make_check(test_atom_length));
add("atom_split", 3, make_check(test_atom_split));
add("atom_arg", 3, make_check(test_atom_arg));
// atom specials, non-standard
add("atom_concat", 3, make_special(special_atom_concat));
add("sys_atom_part", 4, make_special(special_sys_atom_part));
add("sys_atom_match", 3, make_special(special_sys_atom_match));
add("sys_last_atom_part", 4, make_special(special_sys_last_atom_part));
add("sys_last_atom_match", 3, make_special(special_sys_last_atom_match));