guix-gnunet/guix/sets.scm

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