diff options
author | Rob Browning <rlb@defaultvalue.org> | 2024-07-20 10:07:59 -0500 |
---|---|---|
committer | Rob Browning <rlb@defaultvalue.org> | 2024-07-30 19:28:37 -0500 |
commit | 51b7021de184d4a2b737edbef2bd9a8dd7966874 (patch) | |
tree | da92a75448e71072b25cf070370c1ba4b1587085 | |
parent | a94b4406b76082d2a98842a404b7a068729dcf58 (diff) | |
download | guile-51b7021de184d4a2b737edbef2bd9a8dd7966874.tar.gz |
srfi-1 delete-duplicates: move from C to Scheme
* libguile/srfi-1.c (scm_srfi1_delete-duplicates): delete.
* libguile/srfi-1.h (scm_srfi1_delete-duplicates): delete.
* module/srfi/srfi-1.scm: add delete-duplicates.
-rw-r--r-- | libguile/srfi-1.c | 138 | ||||
-rw-r--r-- | libguile/srfi-1.h | 2 | ||||
-rw-r--r-- | module/srfi/srfi-1.scm | 46 |
3 files changed, 46 insertions, 140 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index ba48e3425..c3d79e766 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -51,144 +51,6 @@ * optimize them, and have the VM execute them efficiently. */ - -static SCM -equal_trampoline (SCM proc, SCM arg1, SCM arg2) -{ - return scm_equal_p (arg1, arg2); -} - -/* list_copy_part() copies the first COUNT cells of LST, puts the result at - *dst, and returns the SCM_CDRLOC of the last cell in that new list. - - This function is designed to be careful about LST possibly having changed - in between the caller deciding what to copy, and the copy actually being - done here. The COUNT ensures we terminate if LST has become circular, - SCM_VALIDATE_CONS guards against a cdr in the list changed to some - non-pair object. */ - -#include <stdio.h> -static SCM * -list_copy_part (SCM lst, int count, SCM *dst) -#define FUNC_NAME "list_copy_part" -{ - SCM c; - for ( ; count > 0; count--) - { - SCM_VALIDATE_CONS (SCM_ARGn, lst); - c = scm_cons (SCM_CAR (lst), SCM_EOL); - *dst = c; - dst = SCM_CDRLOC (c); - lst = SCM_CDR (lst); - } - return dst; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0, - (SCM lst, SCM pred), - "Return a list containing the elements of @var{lst} but without\n" - "duplicates.\n" - "\n" - "When elements are equal, only the first in @var{lst} is\n" - "retained. Equal elements can be anywhere in @var{lst}, they\n" - "don't have to be adjacent. The returned list will have the\n" - "retained elements in the same order as they were in @var{lst}.\n" - "\n" - "Equality is determined by @var{pred}, or @code{equal?} if not\n" - "given. Calls @code{(pred x y)} are made with element @var{x}\n" - "being before @var{y} in @var{lst}. A call is made at most once\n" - "for each combination, but the sequence of the calls across the\n" - "elements is unspecified.\n" - "\n" - "@var{lst} is not modified, but the return might share a common\n" - "tail with @var{lst}.\n" - "\n" - "In the worst case, this is an @math{O(N^2)} algorithm because\n" - "it must check each element against all those preceding it. For\n" - "long lists it is more efficient to sort and then compare only\n" - "adjacent elements.") -#define FUNC_NAME s_scm_srfi1_delete_duplicates -{ - scm_t_trampoline_2 equal_p; - SCM ret, *p, keeplst, item, l; - int count, i; - - /* ret is the new list constructed. p is where to append, initially &ret - then SCM_CDRLOC of the last pair. lst is advanced as each element is - considered. - - Elements retained are not immediately appended to ret, instead keeplst - is the last pair in lst which is to be kept but is not yet copied. - Initially this is the first pair of lst, since the first element is - always retained. - - *p is kept set to keeplst, so ret (inclusive) to lst (exclusive) is all - the elements retained, making the equality search loop easy. - - If an item must be deleted, elements from keeplst (inclusive) to lst - (exclusive) must be copied and appended to ret. When there's no more - deletions, *p is left set to keeplst, so ret shares structure with the - original lst. (ret will be the entire original lst if there are no - deletions.) */ - - /* skip to end if an empty list (or something invalid) */ - ret = SCM_EOL; - - if (SCM_UNBNDP (pred)) - equal_p = equal_trampoline; - else - { - SCM_VALIDATE_PROC (SCM_ARG2, pred); - equal_p = scm_call_2; - } - - keeplst = lst; - count = 0; - p = &ret; - - for ( ; scm_is_pair (lst); lst = SCM_CDR (lst)) - { - item = SCM_CAR (lst); - - /* look for item in "ret" list */ - for (l = ret; scm_is_pair (l); l = SCM_CDR (l)) - { - if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) - { - /* "item" is a duplicate, so copy keeplst onto ret */ - duplicate: - p = list_copy_part (keeplst, count, p); - - keeplst = SCM_CDR (lst); /* elem after the one deleted */ - count = 0; - goto next_elem; - } - } - - /* look for item in "keeplst" list - be careful traversing, in case nasty code changed the cdrs */ - for (i = 0, l = keeplst; - i < count && scm_is_pair (l); - i++, l = SCM_CDR (l)) - if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) - goto duplicate; - - /* keep this element */ - count++; - - next_elem: - ; - } - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list"); - - /* share tail of keeplst items */ - *p = keeplst; - - return ret; -} -#undef FUNC_NAME - void scm_register_srfi_1 (void) diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index bd230d10f..eb027a0c2 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -24,8 +24,6 @@ #include "libguile/scm.h" -SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); - SCM_INTERNAL void scm_register_srfi_1 (void); SCM_INTERNAL void scm_init_srfi_1 (void); diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index 146912e29..2e083c8aa 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -1170,6 +1170,52 @@ be deleted with @code{(delete 5 lst <)}. @var{lst} may be modified to construct the returned list." (remove! (lambda (elem) (pred x elem)) lst)) +(define* (delete-duplicates lst #:optional (= equal?)) + "Return a list containing the elements of @var{lst} but without +duplicates. + +When elements are equal, only the first in @var{lst} is retained. Equal +elements can be anywhere in @var{lst}, they don't have to be adjacent. +The returned list will have the retained elements in the same order as +they were in @var{lst}. + +Equality is determined by @var{pred}, or @code{equal?} if not given. +Calls @code{(pred x y)} are made with element @var{x} being before +@var{y} in @var{lst}. A call is made at most once for each combination, +but the sequence of the calls across the elements is unspecified. + +@var{lst} is not modified, but the return might share a common tail with +@var{lst}. + +In the worst case, this is an @math{O(N^2)} algorithm because it must +check each element against all those preceding it. For long lists it is +more efficient to sort and then compare only adjacent elements." + ;; Same implementation as remove (see comments there), except that the + ;; predicate checks for duplicates in both last-seen and the pending + ;; result. + (if (null? lst) + lst + (let ((result (list #f))) + (let lp ((lst lst) + (last-kept lst) + (tail result)) + (if (null? lst) + (begin + (set-cdr! tail last-kept) + (cdr result)) + (let ((item (car lst))) + (if (or (member item (cdr result) (lambda (x y) (= y x))) + (member-before item last-kept lst =)) + (if (eq? last-kept lst) + (lp (cdr lst) (cdr lst) tail) + (call-with-values + (lambda () (list-prefix-and-tail last-kept lst)) + (lambda (prefix new-tail) + (set-cdr! tail prefix) + (lp (cdr lst) (cdr lst) new-tail)))) + ;; unique, keep + (lp (cdr lst) last-kept tail)))))))) + (define* (delete-duplicates! lst #:optional (= equal?)) "Return a list containing the elements of @var{lst} but without duplicates. |