diff options
author | Rob Browning <rlb@defaultvalue.org> | 2024-07-18 03:23:27 -0500 |
---|---|---|
committer | Rob Browning <rlb@defaultvalue.org> | 2024-07-30 19:28:37 -0500 |
commit | a94b4406b76082d2a98842a404b7a068729dcf58 (patch) | |
tree | 9d3fbef864ae6546c2b112402aef3de107fcd36f | |
parent | 51e15d448f705a7aa0aa2f26744f9b2b793535d2 (diff) | |
download | guile-a94b4406b76082d2a98842a404b7a068729dcf58.tar.gz |
srfi-1 delete-duplicates!: move from C to Scheme
* libguile/srfi-1.c (scm_srfi1_delete-duplicates_x): delete.
* libguile/srfi-1.h (scm_srfi1_delete-duplicates_x): delete.
* module/srfi/srfi-1.scm: add delete-duplicates!.
-rw-r--r-- | libguile/srfi-1.c | 83 | ||||
-rw-r--r-- | libguile/srfi-1.h | 1 | ||||
-rw-r--r-- | module/srfi/srfi-1.scm | 39 |
3 files changed, 39 insertions, 84 deletions
diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 56e12296b..ba48e3425 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -189,89 +189,6 @@ SCM_DEFINE (scm_srfi1_delete_duplicates, "delete-duplicates", 1, 1, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_delete_duplicates_x, "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} may be modified to construct the returned list.\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_x -{ - scm_t_trampoline_2 equal_p; - SCM ret, endret, item, l; - - /* ret is the return list, constructed from the pairs in lst. endret is - the last pair of ret, initially the first pair. lst is advanced as - elements are considered. */ - - /* skip to end if an empty list (or something invalid) */ - ret = lst; - if (scm_is_pair (lst)) - { - if (SCM_UNBNDP (pred)) - equal_p = equal_trampoline; - else - { - SCM_VALIDATE_PROC (SCM_ARG2, pred); - equal_p = scm_call_2; - } - - endret = ret; - - /* loop over lst elements starting from second */ - for (;;) - { - lst = SCM_CDR (lst); - if (! scm_is_pair (lst)) - break; - item = SCM_CAR (lst); - - /* is item equal to any element from ret to endret (inclusive)? */ - l = ret; - for (;;) - { - if (scm_is_true (equal_p (pred, SCM_CAR (l), item))) - break; /* equal, forget this element */ - - if (scm_is_eq (l, endret)) - { - /* not equal to any, so append this pair */ - scm_set_cdr_x (endret, lst); - endret = lst; - break; - } - l = SCM_CDR (l); - } - } - - /* terminate, in case last element was deleted */ - scm_set_cdr_x (endret, SCM_EOL); - } - - /* demand that lst was a proper list */ - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, SCM_ARG1, FUNC_NAME, "list"); - - return ret; -} -#undef FUNC_NAME - void scm_register_srfi_1 (void) diff --git a/libguile/srfi-1.h b/libguile/srfi-1.h index 1e906424d..bd230d10f 100644 --- a/libguile/srfi-1.h +++ b/libguile/srfi-1.h @@ -25,7 +25,6 @@ #include "libguile/scm.h" SCM_INTERNAL SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); -SCM_INTERNAL SCM scm_srfi1_delete_duplicates_x (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 793185e1d..146912e29 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -1147,6 +1147,13 @@ be deleted with @code{(delete 5 lst <)}. tail with @var{lst}." (remove (lambda (elem) (pred x elem)) lst)) +(define (member-before x lst stop =) + (cond + ((null? lst) #f) + ((eq? lst stop) #f) + ((= (car lst) x) #t) + (else (member-before x (cdr lst) stop =)))) + (define* (delete! x lst #:optional (pred equal?)) "Return a list containing the elements of @var{lst} but with those equal to @var{x} deleted. The returned elements will be in the @@ -1163,6 +1170,38 @@ 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{=}, or @code{equal?} if not given. +Calls @code{(= 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." + (if (null? lst) + lst + (let lp ((tail lst)) + (let ((next (cdr tail))) + (if (null? next) + lst + (if (member-before (car next) lst next =) + (begin + (set-cdr! tail (cdr next)) + (lp tail)) + (lp next))))))) + ;;; Association lists (define alist-cons acons) |