M Makefile.am => Makefile.am +3 -1
@@ 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 \
A guix/sets.scm => guix/sets.scm +116 -0
@@ 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
A tests/sets.scm => tests/sets.scm +52 -0
@@ 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))