/* Part of SWI-Prolog Author: Jan Wielemaker E-mail: J.Wielemaker@vu.nl WWW: http://www.swi-prolog.org Copyright (c) 1985-2020, University of Amsterdam VU University Amsterdam All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. */ #include "pl-incl.h" #include "pl-arith.h" #include "pl-dict.h" #include "pl-prims.h" #include "pl-gc.h" #include "pl-wam.h" #include "pl-fli.h" #undef LD #define LD LOCAL_LD static PRED_IMPL("is_list", 1, is_list, 0) { if ( lengthList(A1, FALSE) >= 0 ) succeed; fail; } /** $length(-List, +Len) is semidet. Implements `known-length' generation path of length/2. Fails if Len < 0. */ static PRED_IMPL("$length", 2, dlength, 0) { PRED_LD intptr_t len; if ( PL_get_intptr(A2, &len) ) { if ( len > 0 ) { Word p; term_t list = PL_new_term_ref(); if ( !hasGlobalSpace(len*3) ) { int rc; if ( (rc=ensureGlobalSpace(len*3, ALLOW_GC)) != TRUE ) return raiseStackOverflow(rc); } p = gTop; *valTermRef(list) = consPtr(p, TAG_COMPOUND|STG_GLOBAL); while(len-- > 0) { p[0] = FUNCTOR_dot2; setVar(p[1]); p[2] = consPtr(&p[3], TAG_COMPOUND|STG_GLOBAL); p += 3; } p[-1] = ATOM_nil; gTop = p; return PL_unify(A1, list); } else if ( len == 0 ) { return PL_unify_nil(A1); } else { return FALSE; } } else if ( PL_is_integer(A2) ) { number i; Word p = valTermRef(A2); deRef(p); get_integer(*p, &i); if ( ar_sign_i(&i) < 0 ) return FALSE; return outOfStack((Stack)&LD->stacks.global, STACK_OVERFLOW_RAISE); } return PL_error("length", 2, NULL, ERR_TYPE, ATOM_integer, A2); } static PRED_IMPL("$memberchk", 3, memberchk, 0) { GET_LD term_t ex = PL_new_term_ref(); term_t h = PL_new_term_ref(); term_t l = PL_copy_term_ref(A2); size_t done = 0; fid_t fid; if ( !(fid=PL_open_foreign_frame()) ) return FALSE; for(;;) { if ( ++done % 10000 == 0 ) { if ( PL_handle_signals() < 0 ) return FALSE; if ( done > usedStack(global)/(sizeof(word)*2) ) return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, A2); } if ( PL_is_variable(l) ) { PL_close_foreign_frame(fid); return PL_unify(A3, l); } if ( !PL_unify_list(l, h, l) ) { PL_close_foreign_frame(fid); PL_unify_nil_ex(l); return FALSE; } if ( PL_unify(A1, h) ) { if ( foreignWakeup(ex) ) { PL_close_foreign_frame(fid); return PL_unify_nil(A3); } else { if ( !isVar(*valTermRef(ex)) ) return PL_raise_exception(ex); PL_rewind_foreign_frame(fid); } } else { PL_rewind_foreign_frame(fid); } } } /******************************* * SORTING * *******************************/ /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Natural merge sort. Code contributed by Richard O'Keefe and integrated into SWI-Prolog by Jan Wielemaker. The nice point about this code is that it uses no extra space and is pretty stable in performance. Richards claim it that many qsort() implementations in libc are very slow. This isn't the case for glibc 2.2, where this performs about the same as the previous qsort() based implementation. However, it integrated keysort/2 in the set and here the difference is huge. Here is C code implementing a bottom-up natural merge sort on lists; it has remove_dups and compare_keys options. (Actually I wouldn't handle the compare_keys option quite like this.) The difference between this and sam-sort is the way runs are built: natural merge: add new node r after last node q of run if item(q) <= item(r) otherwise end this run. sam-sort: add new node r after last node q of run if item(q) <= item(r) otherwise add new new r before first node p of run if item(r) < item(p) otherwise end this run. The natural merge has the nice property that if the list is already sorted it takes O(N) time. In general if you have a list made of M already sorted pieces S1++S2++...++SM it will take no more than O(N.log M). Sam-sort (for "Smooth Applicative Merge sort") has the nice property that it likes the reverse order almost as much as forward order, so \ /\ and \/ patterns are sorted (nearly) as fast as / // and // patterns respectively. I've been using a variant of this code in a sorting utility since about 1988. It leaves the UNIX sort(1) program in the dust. As you may know, sort(1) breaks the input into blocks that fit in memory, sorts the blocks using qsort(), and writes the blocks out to disc, then merges the blocks. For files that fit into memory, the variant of this code runs about twice as fast as sort(1). Part of that is better I/O, but part is just plain not using qsort(). - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ typedef enum { SORT_ASC = 0, SORT_DESC = 1 } sort_order; /* Things in capital letters should be replaced for different applications */ /* ITEM The type of an individual item. COMPARE Compares two items given their addresses (allows ITEM to be large and avoids pass by copy). Return <0, =0, or >0. COMPARE_KEY Compares the keys of two items given the addresses of the entire items. FREE Frees a List_Record including its ITEM. */ typedef struct { Word term; Word key; } ITEM; /* TBD: handle CMP_ERROR */ #ifndef COMPARE_KEY #define COMPARE_KEY(x,y) compareStandard((x)->key, (y)->key, FALSE) #endif #ifndef FREE #define FREE(x) \ { x->next = NULL; \ x->item.term = NULL; \ x->item.key = NULL; \ } #endif typedef struct List_Record *list; struct List_Record { list next; ITEM item; }; #define NIL (list)0 #define compare(c, x, y) \ int c = COMPARE_KEY(&(x)->item, &(y)->item); \ if ( order == SORT_DESC ) c = -c static list nat_sort(list data, int remove_dups, sort_order order) { GET_LD list stack[64]; /* enough for biggest machine */ list *sp = stack; int runs = 0; /* total number of runs processed */ list p, q, r, s; struct List_Record header; int k; remove_dups = !remove_dups; /* 0 -> do, 1 -> don't */ while ((p = data) != NIL) { /* pick up a run from the front of data, setting */ /* p = (pointer to beginning of run), data = (rest of data) */ if ((q = p->next) != NIL) { compare(c, p, q); data = q->next; if (c > 0) { r = q, q = p, p = r; p->next = q; } else if (c == remove_dups) { /* c < 0 or = 0, so c = 1 impossible */ p->next = q->next; FREE(q); q = p; } for (r = data; r != NIL; ) { compare(c, q, r); if (c > 0) break; if (c == remove_dups) { s = r->next; FREE(r); r = s; } else { q->next = r, q = r, r = r->next; } } q->next = NIL; data = r; } else { data = NIL; } runs++; /* merge this run with 0 or more runs off the top of the stack */ for (k = runs; 1 &~ k; k >>= 1) { q = *--sp; r = &header; while (q && p) { /* q precedes p */ compare(c, q, p); if (c <= 0) { r->next = q, r = q, q = q->next; if (c == remove_dups) { s = p->next; FREE(p); p = s; } } else { r->next = p, r = p, p = p->next; } } r->next = q ? q : p; p = header.next; } /* push the merged run onto the stack */ *sp++ = p; } if (sp == stack) return NIL; /* merge all the runs on the stack */ p = *--sp; while (sp != stack) { q = *--sp; r = &header; while (q && p) { /* q precedes p */ compare(c, q, p); if (c <= 0) { r->next = q, r = q, q = q->next; if (c == remove_dups) { s = p->next; FREE(p); p = s; } } else { r->next = p, r = p, p = p->next; } } r->next = q ? q : p; p = header.next; } return p; } #define extract_key(p1, argc, argv, pair) LDFUNC(extract_key, p1, argc, argv, pair) static Word extract_key(DECL_LD Word p1, int argc, const word *argv, int pair) { if ( pair ) { if ( hasFunctor(*p1, FUNCTOR_minus2) ) { p1 = argTermP(*p1, 0); deRef(p1); } else { term_t err_t = pushWordAsTermRef(p1); PL_error("keysort", 2, NULL, ERR_TYPE, ATOM_pair, err_t); popTermRef(); return NULL; } } else { for(; --argc >= 0; argv++) { term_t err_t, ant; const char *expected = "compound"; atom_t existence = ATOM_argument; if ( isTerm(*p1) ) { if ( termIsDict(*p1) ) { Word vp; if ( (vp = dict_lookup_ptr(*p1, argv[0])) ) { p1 = vp; goto next; } existence = ATOM_key; goto err_exists; } else if ( isInteger(argv[0]) ) { int arity = arityTerm(*p1); int an = valInt(argv[0]); if ( an <= arity ) { p1 = argTermP(*p1, an-1); next: deRef(p1); continue; } err_exists: err_t = pushWordAsTermRef(p1); ant = PL_new_term_ref(); *valTermRef(ant) = argv[0]; PL_error(NULL, 0, NULL, ERR_EXISTENCE3, existence, ant, err_t); popTermRef(); return NULL; } else /* no dict, atom key */ { expected = "dict"; } } err_t = pushWordAsTermRef(p1); PL_type_error(expected, err_t); popTermRef(); return NULL; } } return p1; } /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Create a list on the global stack, just at the place the final result will be. Return: 0: error, 1: sort, 2: do not sort (len < 2) - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ typedef enum { SORT_ERR, SORT_SORT, SORT_NIL, SORT_NOSORT } list_sort; #define prolog_list_to_sort_list(t, remove_dups, argc, argv, pair, lp, end) LDFUNC(prolog_list_to_sort_list, t, remove_dups, argc, argv, pair, lp, end) static list_sort prolog_list_to_sort_list(DECL_LD term_t t, /* input list */ int remove_dups, /* allow to be cyclic */ int argc, const word *argv, int pair, /* find key */ list *lp, Word *end) /* result list */ { Word l, tail; list p; intptr_t len; int rc; l = valTermRef(t); len = skip_list(l, &tail); if ( !(isNil(*tail) || /* proper list */ (isList(*tail) && remove_dups)) ) /* sort/2 on cyclic list */ { if ( isVar(*tail) ) PL_error(NULL, 0, NULL, ERR_INSTANTIATION); else PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_list, t); return SORT_ERR; } if ( len == 0 ) return SORT_NIL; if ( len == 1 && !pair && argc == 0 && !isList(*tail) ) return SORT_NOSORT; if ( !hasGlobalSpace(len*3) ) { if ( (rc=ensureGlobalSpace(len*3, ALLOW_GC)) != TRUE ) { raiseStackOverflow(rc); return SORT_ERR; } l = valTermRef(t); /* may be shifted */ } p = (list)gTop; *lp = p; deRef(l); while(len-- > 0) { p->item.term = HeadList(l); deRef(p->item.term); p->item.key = extract_key(p->item.term, argc, argv, pair); if ( unlikely(!p->item.key) ) return SORT_ERR; l = TailList(l); deRef(l); if ( len > 0 ) { assert(isList(*l)); p->next = p+1; p++; } } p->next = NULL; *end = (Word)(p+1); return SORT_SORT; } static void put_sort_list(term_t l, list sl) { GET_LD *valTermRef(l) = consPtr(sl, TAG_COMPOUND|STG_GLOBAL); for(;;) { list n = sl->next; Word p = (Word)sl; n = sl->next; /* see also linkVal() */ p[1] = (needsRef(*sl->item.term) ? makeRefG(sl->item.term) : *sl->item.term); p[0] = FUNCTOR_dot2; if ( n ) { p[2] = consPtr(n, TAG_COMPOUND|STG_GLOBAL); sl = n; } else { p[2] = ATOM_nil; return; } } } #define pl_nat_sort(in, out, remove_dups, order, argc, argv, pair) LDFUNC(pl_nat_sort, in, out, remove_dups, order, argc, argv, pair) static int pl_nat_sort(DECL_LD term_t in, term_t out, int remove_dups, sort_order order, int argc, const word *argv, int pair) { list l = 0; Word top = NULL; if ( !ensureLocalSpace(sizeof(word)) ) return FALSE; switch( prolog_list_to_sort_list(in, remove_dups, argc, argv, pair, &l, &top) ) { case SORT_ERR: return FALSE; case SORT_NIL: return PL_unify_nil(out); case SORT_NOSORT: return PL_unify(in, out); case SORT_SORT: default: { term_t tmp = PL_new_term_ref(); l = nat_sort(l, remove_dups, order); put_sort_list(tmp, l); gTop = top; return PL_unify(out, tmp); } } } static PRED_IMPL("sort", 2, sort, PL_FA_ISO) { PRED_LD return pl_nat_sort(A1, A2, TRUE, SORT_ASC, 0, NULL, FALSE); } static PRED_IMPL("msort", 2, msort, 0) { PRED_LD return pl_nat_sort(A1, A2, FALSE, SORT_ASC, 0, NULL, FALSE); } static PRED_IMPL("keysort", 2, keysort, PL_FA_ISO) { PRED_LD return pl_nat_sort(A1, A2, FALSE, SORT_ASC, 0, NULL, TRUE); } /** sort(+Key, +Order, +Random, -Sorted) ECLiPSe compatible sort. */ #define FAST_ARGV 10 #define get_key_arg_ex(t, k, zero_ok) LDFUNC(get_key_arg_ex, t, k, zero_ok) static int get_key_arg_ex(DECL_LD term_t t, word *k, int zero_ok) { Word p = valTermRef(t); deRef(p); if ( isTaggedInt(*p) ) { intptr_t v = valInt(*p); if ( v > 0 ) { *k = *p; return TRUE; } if ( v == 0 ) { *k = *p; if ( zero_ok ) return TRUE; } } if ( isAtom(*p) ) { *k = *p; return TRUE; } if ( isInteger(*p) ) { number n; get_integer(*p, &n); if ( ar_sign_i(&n) <= 0 ) PL_error(NULL, 0, NULL, ERR_DOMAIN, ATOM_not_less_than_one, t); return FALSE; } return -1; } typedef struct order_def { atom_t name; sort_order order; int remove_dups; } order_def; static const order_def order_defs[] = { { ATOM_smaller, SORT_ASC, TRUE }, { ATOM_at_smaller, SORT_ASC, TRUE }, { ATOM_smaller_equal, SORT_ASC, FALSE }, { ATOM_at_smaller_eq, SORT_ASC, FALSE }, { ATOM_larger, SORT_DESC, TRUE }, { ATOM_at_larger, SORT_DESC, TRUE }, { ATOM_larger_equal, SORT_DESC, FALSE }, { ATOM_at_larger_eq, SORT_DESC, FALSE }, { 0 } }; static PRED_IMPL("sort", 4, sort, 0) { PRED_LD word tmp[FAST_ARGV]; word *argv = tmp; int argc; int rc; atom_t order_name; const order_def *od; if ( (rc=get_key_arg_ex(A1, argv, TRUE)) == FALSE ) return FALSE; if ( rc == TRUE ) /* Key is integer */ { if ( argv[0] == consInt(0) ) { argc = 0; argv = NULL; } else { argc = 1; } } else { size_t len; switch(PL_skip_list(A1, 0, &len)) { case PL_LIST: { term_t tail = PL_copy_term_ref(A1); term_t head = PL_new_term_ref(); if ( len > FAST_ARGV ) { if ( (argv = malloc(len*sizeof(intptr_t))) == NULL ) return PL_no_memory(); } for(argc=0; PL_get_list(tail, head, tail); argc++) { if ( get_key_arg_ex(head, &argv[argc], FALSE) != TRUE ) { rc = FALSE; goto out; } } assert(PL_get_nil(tail)); break; } default: return PL_type_error("sort_key", A1); } } if ( !(rc=PL_get_atom_ex(A2, &order_name)) ) goto out; for(od=order_defs; od->name; od++) { if ( od->name == order_name ) break; } if ( !od->name ) { rc = PL_domain_error("order", A2); goto out; } rc = pl_nat_sort(A3, A4, od->remove_dups, od->order, argc, argv, FALSE); out: if ( argv && argv != tmp ) free(argv); return rc; } /******************************* * PUBLISH PREDICATES * *******************************/ BeginPredDefs(list) PRED_DEF("is_list", 1, is_list, 0) PRED_DEF("$length", 2, dlength, 0) PRED_DEF("$memberchk", 3, memberchk, 0) PRED_DEF("sort", 2, sort, PL_FA_ISO) PRED_DEF("msort", 2, msort, 0) PRED_DEF("keysort", 2, keysort, PL_FA_ISO) PRED_DEF("sort", 4, sort, 0) EndPredDefs