/**
* 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 {
exec_build, equal_term, list_objects, objects_list,
Compound, exec_unify, is_structure, variable_serno,
is_integer, is_float, union_undo, is_special, is_number,
make_error, set, make_check, check_nonvar, copy_term,
is_variable, is_atom, deref, union_find, union_add,
Item, stack_peek, stack_pop, stack_push
} from "../nova/core.mjs";
/*********************************************************************/
/* @</2, @=</2, @>/2, @>=/2 and compare/3 */
/*********************************************************************/
/**
* 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.4.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.4.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;
}
/**
* compare(C, X, Y): [TC2 8.4.2]
* The predicate succeeds when C unifies with the result of comparing
* X to Y. The result is one of the following atoms <, = or >.
*/
function test_compare(args) {
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 exec_unify(args[0], beta);
}
/**
* Determine the syntactic relationship between two Prolog terms.
* Can handle cyclic terms and deep recursion.
* Has left to right anomaly.
*
* @param first The first Prolog term.
* @param second The second Prolog term.
* @return number <0 for less, =0 for equal and >0 for greater
*/
function compare_term(first, second) {
let stack = null;
let log = null;
try {
for (; ;) {
first = deref(first);
second = deref(second);
if (!is_structure(first)) {
if (!Object.is(first, second))
break;
} else if (!is_structure(second)) {
break;
} else if (first.args.length !== second.args.length) {
break;
} else {
first = union_find(first);
second = union_find(second);
if (first !== second) {
if (first.functor !== second.functor)
break;
log = union_add(log, first, second);
if (0 !== first.args.length - 1) {
let item = new Item(first, second, 0);
stack = stack_push(stack, item);
}
first = first.args[0];
second = second.args[0];
continue;
}
}
let item = stack_peek(stack);
if (item === null) {
return 0;
} else {
item.idx++;
first = item.first.args[item.idx];
second = item.second.args[item.idx];
if (item.idx === item.first.args.length - 1)
stack_pop(stack);
}
}
return compare_truncated(first, second);
} finally {
union_undo(log);
}
}
/**
* Determine the syntactic relationship between truncated Prolog terms.
* Prolog compounds are truncated to their arity and functor.
*
* @param first The first Prolog term.
* @param second The second Prolog term.
* @return <0 for less, =0 for equal and >0 for greater
*/
function compare_truncated(first, second) {
let i = compare_type(first);
let k = i - compare_type(second);
if (k !== 0)
return k;
switch (i) {
case 0:
return variable_serno(first) -
variable_serno(second);
case 2:
return compare_atomic(first, second);
case 3:
return compare_atomic(first, second);
case 9:
return compare_atomic(first, second);
case 10:
k = first.args.length - second.args.length;
if (k !== 0)
return k;
return compare_atomic(first.functor, second.functor);
default:
return 0;
}
}
/**
* 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_structure(first)) {
return 10;
} else if (is_atom(first)) {
return 9;
} else if (is_number(first)) {
if (is_integer(first)) {
return 3;
} else if (is_special(first)) {
if (first === -Infinity) {
return 1;
} else if (first === Infinity) {
return 4;
} else if (Number.isNaN(first)) {
return 5;
}
} else if (is_float(first)) {
return 2;
}
} else if (first === false) {
return 7;
} else if (first === true) {
return 8;
} else if (first === null) {
return 6;
}
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;
}
/******************************************************************/
/* sort/2 and keysort/2 */
/******************************************************************/
/**
* sort(L, R): [TC2 8.4.3]
* The predicate succeeds in R with the sorted list L.
*/
function test_sort(args) {
let alpha = exec_build(args[0]);
let res = list_objects(alpha);
res.sort(compare_term);
let count = objects_dedup(res);
return exec_unify(args[1], objects_list(res, 0, count));
}
function objects_dedup(res) {
let j = 0;
let i = 0;
while (i < res.length) {
let alpha = res[i++];
while (i < res.length && equal_term(alpha, res[i]))
i++;
res[j++] = alpha;
}
return j;
}
/**
* keysort(L, R): [TC2 8.4.4]
* The predicate succeeds in R with the key sorted list L.
*/
function test_keysort(args) {
let alpha = exec_build(args[0]);
let res = list_objects(alpha);
objects_pairs(res);
res.sort((first, second) => compare_term(get_key(first), get_key(second)));
return exec_unify(args[1], objects_list(res, 0, res.length));
}
function objects_pairs(res) {
for (let i = 0; i < res.length; i++) {
let alpha = res[i];
if (is_structure(alpha) &&
"-" === alpha.functor &&
alpha.args.length === 2) {
/* */
} else {
check_nonvar(alpha);
alpha = copy_term(alpha);
throw make_error(new Compound("type_error",
["pair", alpha]));
}
}
}
function get_key(peek) {
return peek.args[0];
}
/*********************************************************************/
/* Iso Lib Init */
/*********************************************************************/
export function main() {
// term specials, syntactic comparison
set("@<", 2, make_check(test_less));
set("@>=", 2, make_check(test_greaterequal));
set("@>", 2, make_check(test_greater));
set("@=<", 2, make_check(test_lessequal));
set("compare", 3, make_check(test_compare));
// list specials, miscellaneous sorting
set("sort", 2, make_check(test_sort));
set("keysort", 2, make_check(test_keysort));
}