Home Page
Site Map
Login/out
Message Board
Download(c) 2005-2025 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 {
check_integer, exec_build, VAR_MASK_STATE, is_integer,
is_variable, Compound, exec_unify, is_compound,
norm_smallint, make_error, norm_bigint, add,
bind, deref, is_atom, is_number, check_callable,
narrow_float, Variable, set_to_list, make_special,
VOID_ARGS, cont, get_cont, is_bigint, make_check
} from "../nova/core.mjs";
/*********************************************************************/
/* numbervars/3 */
/*********************************************************************/
/**
* numbervars(X, N, M):
* The predicate instantiates the un-instantiated variables of
* the term X with compounds of the form ‘$VAR’(<index>). The
* <index> starts with N. The predicate succeeds when M unifies
* with the next available <index>.
*/
function test_numbervars(args) {
let alpha = exec_build(args[0]);
let beta = deref(exec_build(args[1]));
check_integer(beta);
if (beta < 0)
throw make_error(new Compound("domain_error",
["not_less_than_zero", beta]));
beta = numbervars(alpha, beta);
return exec_unify(args[2], beta);
}
function numbervars(alpha, beta) {
function numbervars2(alpha2) {
for (; ;) {
alpha2 = deref(alpha2);
if (is_variable(alpha2)) {
bind(new Compound("$VAR", [beta]), alpha2);
beta = succ(beta);
break;
} else if (is_compound(alpha2)) {
alpha2 = alpha2.args;
let i = 0;
for (; i < alpha2.length - 1; i++)
numbervars2(alpha2[i]);
alpha2 = alpha2[i];
} else {
break;
}
}
}
numbervars2(alpha);
return beta;
}
function succ(beta) {
if (!is_bigint(beta)) {
return norm_smallint(beta + 1);
} else {
return norm_bigint(beta + 1n);
}
}
/*********************************************************************/
/* unify_with_occurs_check/2 */
/*********************************************************************/
/**
* unify_with_occurs_check(S, T): [ISO 8.2.2]
* The built-in succeeds when the Prolog terms S and T unify
* with occurs check, otherwise the built-in fails.
*/
function test_unify_checked(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return unify_checked(alpha, beta);
}
/**
* Determine whether two terms unify with occurs check.
* As a side effect the trail is extended, even if unification fails.
* Tail recursive solution.
*
* @param first The first term.
* @param second The second term.
* @return boolean True if the two terms unify, otherwise false.
*/
function unify_checked(first, second) {
for (; ;) {
first = deref(first);
second = deref(second);
if (is_variable(first)) {
if (is_variable(second) && first === second)
return true;
if (has_var(first, second))
return false;
bind(second, first);
return true;
}
if (is_variable(second)) {
if (has_var(second, first))
return false;
bind(first, second);
return true;
}
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 (!unify_checked(first[i], second[i]))
return false;
}
first = first[i];
second = second[i];
}
}
/**
* Check whether a variable occurs in a term.
* Tail recursive solution.
*
* @param term The variable.
* @param source The Prolog term.
* @return boolean True if term occurs in source, otherwise false.
*/
function has_var(term, source) {
function has_var2(source2) {
for (; ;) {
source2 = deref(source2);
if (is_variable(source2)) {
return (term === source2);
} else if (is_compound(source2)) {
source2 = source2.args;
let i = 0;
for (; i < source2.length - 1; i++)
if (has_var2(source2[i]))
return true;
source2 = source2[i];
} else {
return false;
}
}
}
return has_var2(source);
}
/*********************************************************************/
/* subsumes/2 */
/*********************************************************************/
/**
* subsumes(X, Y): [N208 8.2.4]
* The built-in succeeds if X subsumes Y.
*/
function test_subsumes(args) {
let alpha = exec_build(args[0]);
let beta = exec_build(args[1]);
return subsumes(alpha, beta);
}
/**
* Determine whether two terms single side unify.
* As a side effect the trail is extended, even if unification fails.
* Tail recursive solution.
*
* @param first The first term.
* @param second The second term.
* @return boolean True if the two terms single side unify, otherwise false.
*/
function subsumes(first, second) {
function subsumes2(first2, second2) {
for (; ;) {
first2 = deref(first2);
second2 = deref(second2);
if (is_variable(first2)) {
if (is_variable(second2) && first2 === second2)
return true;
if (has_var(first2, second))
return false;
bind(second2, first2);
return true;
}
if (is_variable(second2))
return false;
if (!is_compound(first2))
return (first2 === second2);
if (!is_compound(second2))
return false;
if (first2.args.length !== second2.args.length)
return false;
if (first2.functor !== second2.functor)
return false;
first2 = first2.args;
second2 = second2.args;
let i = 0;
for (; i < first2.length - 1; i++) {
if (!subsumes2(first2[i], second2[i]))
return false;
}
first2 = first2[i];
second2 = second2[i];
}
}
return subsumes2(first, second);
}
/******************************************************************/
/* term_hash/2 */
/******************************************************************/
/**
* term_hash(X, H):
* The predicate succeeds in H with the variant hash of the term X.
*/
function test_term_hash(args) {
let alpha = exec_build(args[0]);
let res = norm_smallint(term_hash(alpha));
return exec_unify(args[1], res);
}
function term_hash(alpha) {
let res = 0;
function term_hash2(alpha2) {
for (;;) {
alpha2 = deref(alpha2);
if (is_variable(alpha2)) {
res = (res * 31 + (alpha2.flags & ~VAR_MASK_STATE)) | 0;
return;
}
if (!is_compound(alpha2)) {
res = (res * 31 + hash_code(alpha2)) | 0;
return;
}
let args = alpha2.args;
res = (res * 31 + hash_code(alpha2.functor)) | 0;
let i = 0;
for (; i < args.length - 1; i++)
term_hash2(args[i]);
alpha2 = args[i];
}
}
term_hash2(alpha);
return res;
}
/**
* Compute the hash code of an atomic
*
* @param alpha The term.
* @return The hash code, a signed 32-bit integer
*/
function hash_code(alpha) {
if (is_atom(alpha)) {
let res = 0;
for (let i = 0; i < alpha.length; i++)
res = (res * 31 + alpha.charCodeAt(i)) | 0;
return res;
} else if (is_number(alpha)) {
if (is_integer(alpha)) {
if (!is_bigint(alpha)) {
return alpha;
} else {
let sign;
if (alpha < 0) {
sign = -1;
alpha = -alpha;
} else {
sign = 1;
}
alpha = alpha.toString(16);
let res = 0;
let i = alpha.length % 8;
if (i > 0)
res = parseInt(alpha.substring(0,i), 16) | 0;
for (; i < alpha.length; i+=8)
res = (res * 31 + parseInt(alpha.substring(i,i+8), 16)) | 0;
return res*sign;
}
} else {
let beta = new Float64Array(1);
beta[0] = narrow_float(alpha);
let gamma = new Int32Array(beta.buffer);
return gamma[0] ^ gamma[1];
}
} else {
if (alpha === true) {
return 1;
} else if (alpha === false) {
return 0;
} else if (alpha === null) {
return -1;
} else {
return -2;
}
}
}
/*********************************************************************/
/* term_singletons/2 and nonground/2 */
/*********************************************************************/
/**
* term_singletons(T, L):
* The built-in succeeds in L with the singleton variables of T.
*/
function test_term_singletons(args) {
let alpha = exec_build(args[0]);
alpha = term_singletons(alpha);
alpha = set_to_list(alpha);
return exec_unify(args[1], alpha);
}
/**
* Collect the singleton variables of a Prolog term.
*
* @param alpha The Prolog term.
* @return The set with the singleton variables.
*/
function term_singletons(alpha) {
let res = null;
let anon = null;
function term_singletons2(alpha2) {
for (; ;) {
alpha2 = deref(alpha2);
if (is_variable(alpha2)) {
if (res === null) {
res = new Set();
anon = new Set();
}
if (res.has(alpha2)) {
anon.delete(alpha2);
} else {
res.add(alpha2);
anon.add(alpha2);
}
break;
} else if (is_compound(alpha2)) {
alpha2 = alpha2.args;
let i = 0;
for (; i < alpha2.length - 1; i++)
term_singletons2(alpha2[i]);
alpha2 = alpha2[i];
} else {
break;
}
}
}
term_singletons2(alpha);
return anon;
}
/**
* nonground(T, V):
* The built-in succeeds if T is non-ground and V is the first variable.
*/
function test_nonground(args) {
let alpha = exec_build(args[0]);
alpha = first_variable(alpha);
if (alpha === undefined)
return false;
return exec_unify(args[1], alpha);
}
function first_variable(alpha) {
for (; ;) {
alpha = deref(alpha);
if (is_variable(alpha)) {
return alpha;
} else if (is_compound(alpha)) {
alpha = alpha.args;
let i = 0;
for (; i < alpha.length - 1; i++) {
let res = first_variable(alpha[i]);
if (res !== undefined)
return res;
}
alpha = alpha[i];
} else {
return undefined;
}
}
}
/*********************************************************************/
/* unnumbervars/4 */
/*********************************************************************/
/**
* unnumbervars(S, N, T):
* The predicate succeeds in T with a copy of S with compounds of
* the form ‘$VAR’(<index>) and <index> greater or equal N are
* replaced by fresh variables.
*/
function test_unnumbervars(args) {
let alpha = exec_build(args[0]);
let beta = deref(exec_build(args[1]));
check_integer(beta);
if (beta < 0)
throw make_error(new Compound("domain_error",
["not_less_than_zero", beta]));
alpha = unnumbervars(alpha, beta)
return exec_unify(args[2], alpha);
}
function unnumbervars(alpha, beta) {
let assoc = null;
function unnumbervars2(alpha2) {
let back = null;
for (; ;) {
alpha2 = deref(alpha2);
if (is_variable(alpha2)) {
break;
} else if (is_compound(alpha2)) {
if ("$VAR" === alpha2.functor &&
alpha2.args.length === 1) {
let beta2 = deref(alpha2.args[0]);
if (is_integer(beta2) && beta <= beta2) {
beta2 = beta2 - beta;
if (assoc === null)
assoc = new Array(0);
while (assoc.length <= beta2)
assoc.push(new Variable());
alpha2 = assoc[beta2];
break;
}
}
let t1 = alpha2.args;
let args = new Array(t1.length);
alpha2 = new Compound(alpha2.functor, args);
let i = 0;
for (; i < args.length - 1; i++)
args[i] = unnumbervars2(t1[i]);
args[i] = back;
back = alpha2;
alpha2 = t1[i];
} else {
break;
}
}
while (back !== null) {
let peek = back.args[back.args.length - 1];
back.args[back.args.length - 1] = alpha2;
alpha2 = back;
back = peek;
}
return alpha2;
}
return unnumbervars2(alpha);
}
/*********************************************************************/
/* call/2-4 */
/*********************************************************************/
/**
* call(F, A1, .., An): [Corr.2 8.15.4.4]
* The predicate succeeds in calling the goal which results from
* appending the arguments A1, .., An to the callable F.
*/
function special_call(args) {
let alpha = deref(args[0]);
check_callable(alpha);
let functor;
let oldargs;
if (is_compound(alpha)) {
functor = alpha.functor;
oldargs = alpha.args;
} else {
functor = alpha;
oldargs = VOID_ARGS;
}
let arity = oldargs.length + args.length - 1;
let goal;
if (arity === 0) {
goal = functor;
} else {
let newargs = new Array(arity);
for (let i = 0; i < oldargs.length; i++)
newargs[i] = deref(oldargs[i]);
for (let i = 0; i < args.length - 1; i++)
newargs[i + oldargs.length] = deref(args[i + 1]);
goal = new Compound(functor, newargs);
}
let res = get_cont().args[1];
res = new Compound(".", [goal, res]);
cont(res);
return true;
}
/*********************************************************************/
/* Fast Lib Init */
/*********************************************************************/
export function main() {
add("numbervars", 3, make_check(test_numbervars));
add("unify_with_occurs_check", 2, make_check(test_unify_checked));
add("subsumes", 2, make_check(test_subsumes));
add("term_hash", 2, make_check(test_term_hash));
add("term_singletons", 2, make_check(test_term_singletons));
add("nonground", 2, make_check(test_nonground));
add("unnumbervars", 3, make_check(test_unnumbervars));
add("call", 2, make_special(special_call));
add("call", 3, make_special(special_call));
add("call", 4, make_special(special_call));
add("call", 5, make_special(special_call));
add("call", 6, make_special(special_call));
add("call", 7, make_special(special_call));
add("call", 8, make_special(special_call));
}