174 lines
4 KiB
Scheme
174 lines
4 KiB
Scheme
;;
|
|
;; util-set-list.scm
|
|
;;
|
|
;; Set implementation using lists
|
|
;;
|
|
;; ISC License
|
|
;;
|
|
;; Copyright 2023 Brmlab, z.s.
|
|
;; Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
;;
|
|
;; Permission to use, copy, modify, and/or distribute this software
|
|
;; for any purpose with or without fee is hereby granted, provided
|
|
;; that the above copyright notice and this permission notice appear
|
|
;; in all copies.
|
|
;;
|
|
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
;;
|
|
|
|
(declare (unit util-set-list))
|
|
|
|
(module
|
|
util-set-list
|
|
(
|
|
TAG-LSET
|
|
|
|
make-lset
|
|
lset-add
|
|
lset-remove
|
|
|
|
lset-member?
|
|
|
|
list->lset
|
|
lset->list
|
|
|
|
lset-merge
|
|
lset-intersect
|
|
lset-subtract
|
|
)
|
|
|
|
(import scheme
|
|
(chicken string)
|
|
(chicken random))
|
|
|
|
;; Tag used for identifying list sets from this module
|
|
(define TAG-LSET
|
|
(string-intersperse
|
|
(cons "LSET-"
|
|
(map (lambda (n)
|
|
(substring
|
|
(number->string
|
|
(+ 256 (char->integer n))
|
|
16)
|
|
1))
|
|
(string->list
|
|
(random-bytes
|
|
(make-string 8)))))
|
|
""))
|
|
|
|
;; Creates new list set using given equality procedure
|
|
(define (make-lset equality?)
|
|
(list TAG-LSET
|
|
(list equality?)))
|
|
|
|
;; Convenience accessors
|
|
(define lset-meta cadr)
|
|
(define lset-equality? caadr)
|
|
(define lset-list cddr)
|
|
|
|
;; Returns true if given element is in the list
|
|
(define (lset-member? ls el)
|
|
(let ((equality? (lset-equality? ls)))
|
|
(let loop ((els (lset-list ls)))
|
|
(if (null? els)
|
|
#f
|
|
(if (equality? (car els) el)
|
|
#t
|
|
(loop (cdr els)))))))
|
|
|
|
;; Adds given element(s) to the list set
|
|
(define (lset-add ls . els)
|
|
(let loop ((els els)
|
|
(ls ls))
|
|
(if (null? els)
|
|
ls
|
|
(let ((el (car els)))
|
|
(loop (cdr els)
|
|
(if (lset-member? ls el)
|
|
ls
|
|
(cons TAG-LSET
|
|
(cons (lset-meta ls)
|
|
(cons el
|
|
(lset-list ls))))))))))
|
|
|
|
;; Remove given element from the set
|
|
(define (lset-remove ls el)
|
|
(let ((equality? (lset-equality? ls)))
|
|
(let loop ((els (lset-list ls))
|
|
(res '()))
|
|
(if (null? els)
|
|
(cons TAG-LSET
|
|
(cons (lset-meta ls)
|
|
res))
|
|
(loop (cdr els)
|
|
(if (equality? (car els) el)
|
|
res
|
|
(cons (car els) res)))))))
|
|
|
|
;; Converts given list to a set with unique members
|
|
(define (list->lset lst equality?)
|
|
(let loop ((lst lst)
|
|
(ls (make-lset equality?)))
|
|
(if (null? lst)
|
|
ls
|
|
(loop (cdr lst)
|
|
(lset-add ls (car lst))))))
|
|
|
|
;; Converts the list set to plain list (effectively returning the
|
|
;; internal list)
|
|
(define lset->list lset-list)
|
|
|
|
;; Merges two (compatible) list sets
|
|
(define (lset-merge ls1 ls2)
|
|
(let loop ((lst (lset-list ls2))
|
|
(ls ls1))
|
|
(if (null? lst)
|
|
ls
|
|
(loop (cdr lst)
|
|
(lset-add ls (car lst))))))
|
|
|
|
;; Returns list set intersection (set of elements in both sets)
|
|
(define (lset-intersect ls1 ls2)
|
|
(let loop ((lst (lset-list ls2))
|
|
(ls (make-lset (lset-equality? ls1))))
|
|
(if (null? lst)
|
|
ls
|
|
(let ((el (car lst)))
|
|
(loop (cdr lst)
|
|
(if (lset-member? ls1 el)
|
|
(lset-add ls el)
|
|
ls))))))
|
|
|
|
;; Returns the set ls1 without elements in ls2
|
|
(define (lset-subtract ls1 ls2)
|
|
(let loop ((lst (lset-list ls2))
|
|
(ls ls1))
|
|
(if (null? lst)
|
|
ls
|
|
(loop (cdr lst)
|
|
(lset-remove ls (car lst))))))
|
|
|
|
)
|
|
|
|
(import util-set-list)
|
|
|
|
(print TAG-LSET)
|
|
(print (make-lset string=?))
|
|
(define ls (make-lset string=?))
|
|
(print ls)
|
|
(define ls1 (lset-add ls "a"))
|
|
(print ls1)
|
|
(define ls2 (lset-add ls1 "a"))
|
|
(print ls2)
|
|
(define ls3 (lset-add ls2 "b"))
|
|
(print ls3)
|
|
(define ls4 (lset-remove ls3 "a"))
|
|
(print ls4)
|
|
(print (list->lset '("asdf" "qwer" "asdf" "xcvv" "asdf" "qwer" "lkjh") string=?))
|