;;;
;;; Copyright (c) 2006 OOHASHI Daichi, All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this
;;;    software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(define-module util.set
  (use gauche.collection)
  (export <set> <set-meta> set-type
	  set->list list->set
	  make-set set set-copy
	  set? set-contains? subset?
	  set-add! set-adjoin! set-delete! set-clear!
	  set-add-all! set-add-from! set-delete-all! set-delete-from!
	  set-union! set-difference! set-intersection!
	  set-xor! set-symmetric-difference!
	  set-add set-adjoin set-delete set-clear
	  set-add-all set-add-from set-delete-all set-delete-from
	  set-union set-difference set-intersection
	  set-xor set-symmetric-difference
	  set-union-map set-union-map!
	  ))

(select-module util.set)


;;; class definition
(define-class <set-meta> (<class>) ())

(define-class <set> (<collection>)
  ((contents
    :init-keyword :contents))
  :metaclass <set-meta>)

(define (set-type se)
  (hash-table-type (ref se 'contents)))

#|
;;; SRFI-69 like interface
(autoload srfi-13 string-hash)

(define (set-equivalence-function se)
  (case (set-type se)
    ((eq?) eq?)
    ((eqv?) eqv?)
    ((equal?) equal?)
    ((string=?) string=?)))

(define (set-hash-function se)
  (case (set-type se)
    ((eq?) eq-hash)
    ((eqv?) eqv-hash)
    ((equal?) hash)
    ((string=?) string-hash)))
|#

(define-method object-hash ((se <set>))
  (hash (set->list se)))

(define-method write-object ((obj <set>) port)
  (format port "#<set ~A(~A)>" (set-type obj) (size-of obj)))


;;; collection framework
(define-method size-of ((se <set>))
  (hash-table-num-entries (ref se 'contents)))

(define-method coerce-to ((list-class <list-meta>) (se <set>))
  (set->list se))

(define-method call-with-iterator ((se <set>) proc . args)
  (call-with-iterator (set->list se) proc))

(define-method call-with-builder ((set-class <set-meta>) proc . args)
  (let1 res (make-set (get-keyword :type args 'eqv?))
    (proc (cut set-add! res <>)
	  (cut values res))))


;;; type conversion
(define (set->list se)
  (hash-table-keys (ref se 'contents)))

(define (list->set type xs)
  (let1 res (set type)
    (set-add-from! res xs)
    res))


;;; instance creation
(define (make-set . opt)
  (make <set>
    :contents (make-hash-table (get-optional opt 'eqv?))))

(define (set type . vals)
  (let1 res (make-set type)
    (set-add-from! res vals)
    res))


;;; predicate
(define (set? obj)
  (is-a? obj <set>))

(define (set-contains? se value)
  (hash-table-exists? (ref se 'contents) value))


;;; comparison
(define (subset? se . sets)
  (define (subset2? s1 s2)
    (and (<= (size-of s1) (size-of s2))
	 (every (cut set-contains? s2 <>) s1)))
  (every (cut subset2? se <>) sets))

(define-method object-equal? ((s1 <set>) (s2 <set>))
  (and (eq? (set-type s1) (set-type s2))
       (= (size-of s1) (size-of s2))
       (subset? s1 s2)
       (subset? s2 s1)))


;;; duplicator
(define (set-copy se)
  (make <set>
    :contents (hash-table-copy (ref se 'contents))))


;;; internal utility
(define (hash-table-copy ht)
  (let1 res (make-hash-table (hash-table-type ht))
    (hash-table-for-each ht (cut hash-table-put! res <> <>))
    res))

(define-method every (pred? (coll <collection>) . colls)
  (call/cc (lambda (return)
	     (apply for-each
		    (lambda elem
		      (unless (apply pred? elem)
			(return #f)))
		    coll colls)
	     #t)))

(define (from-destructive proc! se . rest)
  (apply proc! (set-copy se) rest))

(define (check-args args)
  (and-let* ((obj (find (complement set?) args)))
    (errorf "set required, but got ~A" obj)))


;;; mutator (destructive)
(define (set-add! se value)
  (hash-table-put! (ref se 'contents) value #t)
  se)

(define (set-adjoin! se . vals)
  (set-add-all! se vals))

(define (set-delete! se value)
  (hash-table-delete! (ref se 'contents) value)
  se)

(define (set-clear! se)
  (set-delete-all! se se))

(define (set-add-all! se coll)
  (for-each (cut set-add! se <>) coll)
  se)

(define set-add-from! set-add-all!)

(define (set-delete-all! se coll)
  (for-each (cut set-delete! se <>) coll)
  se)

(define set-delete-from! set-delete-all!)

(define (set-union! se . sets)
  (check-args sets)
  (for-each (cut set-add-from! se <>) sets)
  se)

(define (set-difference! se . sets)
  (define (set-diff2! s1 s2)
    (if (< (size-of s1) (size-of s2))
	(for-each (lambda (val)
		    (when (set-contains? s2 val)
		      (set-delete! s1 val)))
		  s1)
	(for-each (lambda (val)
		    (when (set-contains? s1 val)
		      (set-delete! s1 val)))
		  s2)))
  (check-args sets)
  (for-each (cut set-diff2! se <>) sets)
  se)

(define (set-intersection! se . sets)
  (define (set-intersection2! s1 s2)
    (for-each (lambda (val)
		(unless (set-contains? s2 val)
		  (set-delete! s1 val)))
	      s1))
  (check-args sets)
  (for-each (cut set-intersection2! se <>) sets)
  se)

(define (set-xor! se . sets)
  (define (set-xor2! s1 s2)
    (let1 i (set-intersection s1 s2)
      (set-difference! (set-union! s1 s2) i)))
  (check-args sets)
  (for-each (cut set-xor2! se <>) sets)
  se)

(define set-symmetric-difference! set-xor!)


;;; mutator (non destructive)
(define (set-add se value)
  (from-destructive set-add! se value))

(define (set-adjoin se . vals)
  (set-add-all se vals))

(define (set-delete se value)
  (from-destructive set-delete! se value))

(define (set-clear se)
  (make-set (set-type se)))

(define (set-add-all se coll)
  (from-destructive set-add-from! se coll))

(define set-add-from set-add-all)

(define (set-delete-all se coll)
  (from-destructive set-delete-from! se coll))

(define set-delete-from set-delete-all)

(define (set-union . sets)
  (if (null? sets)
      (make-set)
      (apply from-destructive set-union! sets)))

(define (set-difference se . sets)
  (apply from-destructive set-difference! se sets))

(define (set-intersection se . sets)
  (apply from-destructive set-intersection! se sets))

(define (set-xor . sets)
  (apply from-destructive set-xor! sets))

(define set-symmetric-difference set-xor)


;;; utility funcitons
(define (set-union-map proc se . sets)
  (apply set-union (apply map proc se sets)))

(define (set-union-map! proc se . sets)
  (apply set-union! (apply map proc se sets)))

(provide "util/set")