ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

Add (guix sets).

Browse source 
* guix/sets.scm, tests/sets.scm: New files.sets
* Makefile.am (MODULES, SCM_TESTS): Add them.
This commit is contained in:
Ludovic Courtès 2015-01-11 23:43:30 +01:00
parent 0009ed71ad
commit d326767e64
3 changed files with 171 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
Makefile.am
View file

@ -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 \

116
guix/sets.scm Normal file
View file

@ -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

52
tests/sets.scm Normal file
View file

@ -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))