diff options
| -rw-r--r-- | Makefile.am | 4 | ||||
| -rw-r--r-- | guix/sets.scm | 116 | ||||
| -rw-r--r-- | tests/sets.scm | 52 |
3 files changed, 171 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index 5ee743470b..c482848fdf 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 <ludo@gnu.org> +# Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013 Andreas Enge <andreas@enge.fr> # # 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 0000000000..017b79ca31 --- /dev/null +++ b/guix/sets.scm @@ -0,0 +1,116 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 0000000000..0a89591765 --- /dev/null +++ b/tests/sets.scm @@ -0,0 +1,52 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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)) |