summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRob Browning <rlb@defaultvalue.org>2024-07-20 10:07:59 -0500
committerRob Browning <rlb@defaultvalue.org>2024-07-30 19:28:37 -0500
commit51b7021de184d4a2b737edbef2bd9a8dd7966874 (patch)
treeda92a75448e71072b25cf070370c1ba4b1587085
parenta94b4406b76082d2a98842a404b7a068729dcf58 (diff)
downloadguile-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.c138
-rw-r--r--libguile/srfi-1.h2
-rw-r--r--module/srfi/srfi-1.scm46
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.