01/03: Add (guix sets).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit d326767e6417cbaad2856e6641e98dd80311b8c3
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 11 23:43:30 2015 +0100

    Add (guix sets).
    
    * guix/sets.scm, tests/sets.scm: New files.sets
    * Makefile.am (MODULES, SCM_TESTS): Add them.
---
 Makefile.am    |    4 +-
 guix/sets.scm  |  116 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/sets.scm |   52 +++++++++++++++++++++++++
 3 files changed, 171 insertions(+), 1 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 5ee7434..c482848 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,5 +1,5 @@
 # GNU Guix --- Functional package management for GNU
-# Copyright © 2012, 2013, 2014 Ludovic Courtès <address@hidden>
+# Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 # Copyright © 2013 Andreas Enge <address@hidden>
 #
 # This file is part of GNU Guix.
@@ -34,6 +34,7 @@ MODULES =                                     \
   guix/pk-crypto.scm                           \
   guix/pki.scm                                 \
   guix/utils.scm                               \
+  guix/sets.scm                                        \
   guix/download.scm                            \
   guix/git-download.scm                                \
   guix/monads.scm                              \
@@ -153,6 +154,7 @@ SCM_TESTS =                                 \
   tests/hash.scm                               \
   tests/pk-crypto.scm                          \
   tests/pki.scm                                        \
+  tests/sets.scm                               \
   tests/substitute-binary.scm                  \
   tests/builders.scm                           \
   tests/derivations.scm                                \
diff --git a/guix/sets.scm b/guix/sets.scm
new file mode 100644
index 0000000..017b79c
--- /dev/null
+++ b/guix/sets.scm
@@ -0,0 +1,116 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix sets)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 match)
+  #:export (set
+            setq
+            set?
+            set-insert
+            set-union
+            set-contains?
+            set->list
+            list->set
+            list->setq))
+
+;;; Commentary:
+;;;
+;;; A simple (simplistic?) implementation of unordered persistent sets based
+;;; on vhashes that seems to be good enough so far.
+;;;
+;;; Another option would be to use "bounded balance trees" (Adams 1992) as
+;;; implemented by Ian Price in 'pfds', which has faster union etc. but needs
+;;; an order on the objects of the set.
+;;;
+;;; Code:
+
+(define-record-type <set>
+  (%make-set vhash insert ref)
+  set?
+  (vhash  set-vhash)
+  (insert set-insert-proc)
+  (ref    set-ref))
+
+(define %insert
+  (cut vhash-cons <> #t <>))
+(define %insertq
+  (cut vhash-consq <> #t <>))
+
+(define (set . args)
+  "Return a set containing the ARGS, compared as per 'equal?'."
+  (list->set args))
+
+(define (setq . args)
+  "Return a set containing the ARGS, compared as per 'eq?'."
+  (list->setq args))
+
+(define (list->set lst)
+  "Return a set with the elements taken from LST.  Elements of the set will be
+compared with 'equal?'."
+  (%make-set (fold %insert vlist-null lst)
+             %insert
+             vhash-assoc))
+
+(define (list->setq lst)
+  "Return a set with the elements taken from LST.  Elements of the set will be
+compared with 'eq?'."
+  (%make-set (fold %insertq vlist-null lst)
+             %insertq
+             vhash-assq))
+
+(define-inlinable (set-contains? set value)
+  "Return #t if VALUE is a member of SET."
+  (->bool ((set-ref set) value (set-vhash set))))
+
+(define (set-insert value set)
+  "Insert VALUE into SET."
+  (if (set-contains? set value)
+      set
+      (let ((vhash ((set-insert-proc set) value (set-vhash set))))
+        (%make-set vhash (set-insert-proc set) (set-ref set)))))
+
+(define-inlinable (set-size set)
+  "Return the number of elements in SET."
+  (vlist-length (set-vhash set)))
+
+(define (set-union set1 set2)
+  "Return the union of SET1 and SET2.  Warning: this is linear in the number
+of elements of the smallest."
+  (unless (eq? (set-insert-proc set1) (set-insert-proc set2))
+    (error "set-union: incompatible sets"))
+
+  (let* ((small (if (> (set-size set1) (set-size set2))
+                    set2 set1))
+         (large (if (eq? small set1) set2 set1)))
+    (vlist-fold (match-lambda*
+                 (((item . _) result)
+                  (set-insert item result)))
+                large
+                (set-vhash small))))
+
+(define (set->list set)
+  "Return the list of elements of SET."
+  (map (match-lambda
+        ((key . _) key))
+       (vlist->list (set-vhash set))))
+
+;;; sets.scm ends here
diff --git a/tests/sets.scm b/tests/sets.scm
new file mode 100644
index 0000000..0a89591
--- /dev/null
+++ b/tests/sets.scm
@@ -0,0 +1,52 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <address@hidden>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-sets)
+  #:use-module (guix sets)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-64))
+
+
+(test-begin "sets")
+
+(test-assert "set-contains?"
+  (let* ((lst (iota 123))
+         (set (list->set lst)))
+    (and (every (cut set-contains? set <>)
+                lst)
+         (not (set-contains? set -1)))))
+
+(test-assert "set->list"
+  (let* ((lst (iota 123))
+         (set (list->set lst)))
+    (lset= = lst (set->list set))))
+
+(test-assert "set-union"
+  (let* ((a  (list 'a))
+         (b  (list 'b))
+         (s1 (setq a))
+         (s2 (setq b))
+         (s3 (set-union s1 s2)))
+    (and (set-contains? s3 a)
+         (set-contains? s3 b))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))