Uniq list in Guile

[Dmitry Bogatov]

Hello!

Recently I faced neseserity to uniq list in Guile. Surprised, that I
did not found ready solution, I decided to prepare it.

By analogy with sorting functions in `sort.c` I prepared
`uniq.c`(attached, but unfinished patch, lacking proper documentation).
But after I became curious, how slower would be Scheme version with
(set-cdr!). To my test (random list of small integers) it is about twice
as slow.

Is Guile Mainline interested in these routines, and if yes, does in your
opinion doubling execution speed worth resorting to C hacking?

From 0e5331e20446ba3318fd6ab0aabbcc40a4b4a5ab Mon Sep 17 00:00:00 2001
From: Dmitry Bogatov <address@hidden>
Date: Tue, 22 Oct 2013 15:56:43 +0400
Subject: [PATCH] Uniq Scheme lists in C

Signed-off-by: Dmitry Bogatov <address@hidden>
---
 doc/ref/api-utility.texi | 29 ++++++++++++++-
 libguile/Makefile.am     |  4 +++
 libguile/init.c          |  2 ++
 libguile/uniq.c          | 93 ++++++++++++++++++++++++++++++++++++++++++++++++
 libguile/uniq.h          | 39 ++++++++++++++++++++
 5 files changed, 166 insertions(+), 1 deletion(-)
 create mode 100644 libguile/uniq.c
 create mode 100644 libguile/uniq.h

diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi
index 76c50b2..22ffb27 100644
--- a/doc/ref/api-utility.texi
+++ b/doc/ref/api-utility.texi
@@ -18,6 +18,7 @@ applications, they are collected in a @dfn{utility} chapter.
 * Object Properties::           A modern interface to object properties.
 * Sorting::                     Sort utility procedures.
 * Copying::                     Copying deep structures.
+* Uniqueing::                   Uniqueing lists.
 * General Conversion::          Converting objects to strings.
 * Hooks::                       User-customizable event lists.
 @end menu
@@ -256,7 +257,7 @@ to @var{value}.
 @end deffn
 
 
address@hidden Sorting
address@hidden Sorting, Copying, Object Properties, Utility Functions
 @subsection Sorting
 
 @c FIXME::martin: Review me!
@@ -372,6 +373,32 @@ the range of the vector which gets sorted.  The return 
value
 is not specified.
 @end deffn
 
address@hidden Uniqueing
+
address@hidden uniqueing
address@hidden uniqueing lists
+
+Another common operation is getting unique elements of
+sequence. Following procedures perform action, analogous to
address@hidden(1) program --- delete adjanced equal elements. If you need
+remove all duplicates, @var{sort} or @var{sort!} it before. Since this
+operation change length of sequence, vectors are not supported.
+
address@hidden snarfed from uniq.c:40
address@hidden {Scheme Procedure} uniq! items eq
+Uniquify the list @var{items}, by deleting equal adjanced
+elements. @var{eq} is used for comparing the sequence
+elements.  The sorting is destructive, that means that
+the input sequence is modified to produce the sorted result.
+
address@hidden deffn
+
address@hidden snarfed from uniq.c:72
address@hidden {Scheme Procedure} uniq items eq
+Uniquify the list @var{items}, by deleting equal adjanced
+elements.  @var{eq} is used for comparing the sequence
+elements.
address@hidden deffn
 
 @node Copying
 @subsection Copying Deep Structures
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ce437e4..2928843 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -221,6 +221,7 @@ address@hidden@_la_SOURCES =                                
\
        version.c                               \
        vm.c                                    \
        vports.c                                \
+       uniq.c                                  \
        weak-set.c                              \
        weak-table.c                            \
        weak-vector.c
@@ -319,6 +320,7 @@ DOT_X_FILES =                                       \
        vectors.x                               \
        version.x                               \
        vports.x                                \
+       uniq.x                                  \
        weak-set.x                              \
        weak-table.x                            \
        weak-vector.x
@@ -422,6 +424,7 @@ DOT_DOC_FILES =                             \
        vectors.doc                             \
        version.doc                             \
        vports.doc                              \
+       uniq.doc                                \
        weak-set.doc                            \
        weak-table.doc                          \
        weak-vector.doc
@@ -642,6 +645,7 @@ modinclude_HEADERS =                                \
        vm-expand.h                             \
        vm.h                                    \
        vports.h                                \
+       uniq.h                                  \
        weak-set.h                              \
        weak-table.h                            \
        weak-vector.h
diff --git a/libguile/init.c b/libguile/init.c
index 6787483..51698c4 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -111,6 +111,7 @@
 #include "libguile/smob.h"
 #include "libguile/socket.h"
 #include "libguile/sort.h"
+#include "libguile/uniq.h"
 #include "libguile/srcprop.h"
 #include "libguile/stackchk.h"
 #include "libguile/stacks.h"
@@ -465,6 +466,7 @@ scm_i_init_guile (void *base)
   scm_init_socket ();
 #endif
   scm_init_sort ();
+  scm_init_uniq ();
   scm_init_srcprop ();     /* requires smob_prehistory */
   scm_init_stackchk ();
 
diff --git a/libguile/uniq.c b/libguile/uniq.c
new file mode 100644
index 0000000..4cc2b86
--- /dev/null
+++ b/libguile/uniq.c
@@ -0,0 +1,93 @@
+/* Copyright (C) 2013 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/eval.h"
+#include "libguile/arrays.h"
+#include "libguile/array-map.h"
+#include "libguile/feature.h"
+#include "libguile/vectors.h"
+#include "libguile/async.h"
+#include "libguile/dynwind.h"
+
+#include "libguile/uniq.h"
+
+
+SCM_DEFINE (scm_uniq_x, "uniq!", 2, 0, 0,
+            (SCM items, SCM eq),
+           "Uniquify the list @var{items}, by deleting equal adjanced\n"
+           "elements. @var{eq} is used for comparing the sequence\n"
+           "elements.  The sorting is destructive, that means that\n"
+           "the input sequence is modified to produce the sorted result.\n")
+#define FUNC_NAME s_scm_uniq_x
+{
+  int len;
+  SCM it = items;
+
+  if (SCM_NULL_OR_NIL_P (items))
+    return items;
+
+  SCM_VALIDATE_LIST_COPYLEN(1, items, len);
+
+  while (!SCM_NULL_OR_NIL_P(SCM_CDR(it)))
+    {
+      SCM cur =  SCM_CAR(it);
+      SCM next = SCM_CADR(it);
+      if (scm_is_true (scm_call_2 (eq, cur, next)))
+       {
+         SCM_SETCDR(it, SCM_CDDR(it));
+       }
+      else
+       {
+         it = SCM_CDR(it);
+       }
+    }
+  return items;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniq, "uniq", 2, 0, 0,
+            (SCM items, SCM eq),
+           "Uniquify the list @var{items}, by deleting equal adjanced\n"
+           "elements.  @var{eq} is used for comparing the sequence \n"
+           "elements.")
+#define FUNC_NAME s_scm_uniq
+{
+  if (SCM_NULL_OR_NIL_P (items))
+    return items;
+
+  return scm_uniq_x(scm_list_copy(items), eq);
+}
+#undef FUNC_NAME
+
+
+void
+scm_init_uniq (void)
+{
+#include "libguile/uniq.x"
+}
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/
diff --git a/libguile/uniq.h b/libguile/uniq.h
new file mode 100644
index 0000000..6926d01
--- /dev/null
+++ b/libguile/uniq.h
@@ -0,0 +1,39 @@
+/* classes: h_files */
+
+#ifndef SCM_UNIQ_H
+#define SCM_UNIQ_H
+
+/* Copyright (C) 2013 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+SCM_API SCM scm_uniq_x(SCM items, SCM eq);
+SCM_API SCM scm_uniq(SCM items, SCM eq);
+SCM_INTERNAL void scm_init_uniq(void);
+
+#endif  /* SCM_UNIQ_H */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/
-- 
Recipients list generated via git-blame. Tell me, if you object.

(define* (random-list #:key (length 1000) (limit 8))
    (let loop ((seed '()) (index 0))
        (if (= length index)
            seed
            (loop (cons (random limit) seed) (1+ index)))))

(define nl (random-list #:length 10000))
(define sl (random-list #:length 10000))

(define (scm-uniq! lst eq)
    (let loop ((it lst))
        (when (pair? (cdr it))
              (if (eq (car it) (cadr it))
                  (begin
                      (set-cdr! it (cddr it))
                      (loop it))
                  (loop (cdr it)))))
    lst)

--
Best regards, Dmitry Bogatov <address@hidden>,
Free Software supporter and netiquette guardian.
        git clone git://kaction.name/rc-files.git --depth 1
        GPG: 54B7F00D
Html mail and proprietary format attachments are forwarded to /dev/null.

pgpB0vZnnpe1J.pgp
Description: PGP signature