hackerbase/src/util-set-list.scm

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

  lset-empty?

  lset-member?

  lset-count
  
  lset-add
  lset-remove

  list->lset
  lset->list

  lset-merge
  lset-intersect
  lset-subtract

  lset=?

  lset-tests!
  )

 (import scheme
	 (chicken base)
	 testing
	 util-tag)

 ;; Tag used for identifying list sets from this module
 (define TAG-LSET (make-tag LSET))

 ;; Creates new list set using given equality procedure
 (define (make-lset . equality?)
   (let ((equality? (if (null? equality?)
			equal?
			(car equality?))))
     (list TAG-LSET
	   (list equality?))))

 ;; Returns true if given value is lset
 (define (lset? v)
   (and (pair? v)
	(eq? (car v) TAG-LSET)))

 ;; Convenience accessors
 (define lset-meta cadr)
 (define lset-equality? caadr)
 (define lset-list cddr)

 ;; Returns true if the list set is empty
 (define (lset-empty? ls)
   (null? (lset-list ls)))

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

 ;; Returns the number of elements in the list set
 (define (lset-count ls)
   (length (lset-list ls)))

 ;; 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 ((equality? (if (null? equality?)
			equal?
			(car 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))))))

 ;; Returns true if two sets are equal
 (define (lset=? s1 s2)
   (and (lset-empty? (lset-subtract s1 s2))
	(lset-empty? (lset-subtract s2 s1))))

 ;; Module self-tests
 (define (lset-tests!)
   (run-tests
    lset
    (test-true make-lset/lset-empty?
	       (lset-empty? (make-lset)))
    (test-false lset-member?
		(lset-member? (make-lset) 1))
    (test-false lset-member?
		(lset-member? (make-lset string=?) "test"))
    (test-true lset-add
	       (lset-member?
		(lset-add (make-lset) 1)
		1))
    (test-false lset-add
		(lset-member?
		 (lset-add (make-lset string=?) "test")
		 "not"))
    (test-equal? lset-count
		 (lset-count (make-lset))
		 0)
    (test-equal? lset-count
		 (lset-count (lset-add (make-lset) 1))
		 1)
    (test-equal? lset-count
		 (lset-count (lset-add (make-lset) 1 2 3 1 2))
		 3)
    (test-false lset-remove
		(lset-member?
		 (lset-remove (lset-add (make-lset) 1 2 3) 2)
		 2))
    (test-equal? list->lset
		 (lset-count
		  (list->lset '(1 2 3 1 2)))
		 3)
    (test-equal? lset->list
		 (length
		  (lset->list
		   (list->lset '(1 2 3 1 2))))
		 3)
    (test-equal? lset-merge
		 (lset-count
		  (lset-merge
		   (list->lset '(1 2 3 1 2))
		   (list->lset '(2 3 4 2 3))))
		 4)
    (test-equal? lset-intersect
		 (lset-count
		  (lset-intersect
		   (list->lset '(1 2 3 1 2))
		   (list->lset '(2 3 4 2 3))))
		 2)
    (test-equal? lset-subtract
		 (lset-count
		  (lset-subtract
		   (list->lset '(1 2 3 1 2))
		   (list->lset '(2 3 4 2 3))))
		 1)
    (test-equal? lset->list/ci
		 (lset-count
		  (list->lset '("Asdf" "asdf" "aSdf") string-ci=?))
		 1)
    ))

 )