;;; PLT Scheme Simulation Collection
;;; set.ss
;;; Copyright (c) 2005-2008 M. Douglas Williams
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;;
;;; This library 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
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA.
;;;
;;; Version  Date      Description
;;; 3.0.0    06/24/08  Updated for V4.0.  (Doug Williams)

;;; Sets are implemented as a doubly-linked list of items with a
;;; header structure representing the entire set.
;;;
;;;       --------------
;;;       | variable-n |
;;;       +------------+
;;;    +--|-first-cell |
;;;    |  +------------+
;;;    |  |  last-cell-|------------------------------+
;;;    |  --------------                              |
;;;    |                                              v
;;;    |  ------------     ------------             ------------
;;;    +->|     next |---->|     next |---->   ---->|     next/|
;;;       +----------+     +----------+             +----------+
;;;       |/previous |<----| previous |<----...<----| previous |
;;;       +----------+     +----------+             +----------+
;;;       | priority |     | priority |             | priority |
;;;       ------------     ------------             ------------
;;;       |     item |     |     item |             |     item |
;;;       ------------     ------------             ------------

;;; Set-cell structure
(define-struct set-cell
               (next
                previous
                priority
                item)
  #:mutable)

;;; Set structure
(define-values (struct:set
                set-constructor
                set?
                set-field-ref
                set-set-field!)
  (make-struct-type 'set #f 4 0))

;;; Set structure, discrete-variable-n field
(define set-variable-n
  (make-struct-field-accessor set-field-ref 0 'variable-n))

(define set-set-variable-n!
  (make-struct-field-mutator set-set-field! 0 'variable-n))

;;; Set structure, n pseudo-field
(define (set-n set)
  (variable-value (set-field-ref set 0)))

(define (set-set-n! set n)
  (set-variable-value! (set-field-ref set 0) n))

;;; Set structure, first-cell field
(define set-first-cell
  (make-struct-field-accessor set-field-ref 1 'first-cell))

(define set-set-first-cell!
  (make-struct-field-mutator set-set-field! 1 'first-cell))

;;; Set structure, last-cell field
(define set-last-cell
  (make-struct-field-accessor set-field-ref 2 'last-cell))

(define set-set-last-cell!
  (make-struct-field-mutator set-set-field! 2 'last-cell))

;;; Set structure, type field
(define set-type
  (make-struct-field-accessor set-field-ref 3 'type))

(define set-set-type!
  (make-struct-field-mutator set-set-field! 3 'type))

;;; make-set: -> set
(define make-set
  (case-lambda
    ((type)
     (set-constructor (make-variable 0) '() '() type))
    (()
     (make-set '#:fifo))))

;;; set-empty?: any -> boolean
(define (set-empty? set)
  (= (set-n set) 0))

(define (set-first set)
  (when (set-empty? set)
    (error 'set-first
           "set is empty"))
  (set-cell-item (set-first-cell set)))

(define (set-last set)
  (when (set-empty? set)
    (error 'set-last
           "set is empty"))
  (set-cell-item (set-last-cell set)))

;;; set-for-each-cell: set x procedure -> void
(define (set-for-each-cell set proc)
  (let loop ((cell (set-first-cell set)))
    (if (not (null? cell))
        (let ((next (set-cell-next cell)))
          (proc cell)
          (loop next))
        (void))))

;;; set-for-each: set x procedure -> void
(define (set-for-each set proc)
  (let loop ((cell (set-first-cell set)))
    (if (not (null? cell))
        (let ((next (set-cell-next cell))
              (item (set-cell-item cell)))
          (proc item)
          (loop next))
        (void))))

;;; set-find-cell: set x item -> (set-cell or #f)
(define (set-find-cell set item)
  (let/ec exit
    (set-for-each-cell set
      (lambda (cell)
        (when (eq? (set-cell-item cell) item)
          (exit cell))))
    #f))

;;; set-insert-cell-first!: set x set-cell -> void
(define (set-insert-cell-first! set cell)
  ;; Increment n
  (set-set-n! set (+ (set-n set) 1))
  ;; Maintain forward chain
  (set-set-cell-next! cell (set-first-cell set))
  (set-set-first-cell! set cell)
  ;; Maintain reverse chain
  (set-set-cell-previous! cell '())
  (if (null? (set-cell-next cell))
      (set-set-last-cell! set cell)
      (set-set-cell-previous! (set-cell-next cell) cell)))

;;; set-insert-first!: set x any -> void
(define (set-insert-first! set item)
  (set-insert-cell-first! set (make-set-cell '() '() #f item)))

;;; set-insert-cell-last!: set x set-cell -> void
(define (set-insert-cell-last! set cell)
  ;; Increment n
  (set-set-n! set (+ (set-n set) 1))
  ;; Maintain reverse chain
  (set-set-cell-previous! cell (set-last-cell set))
  (set-set-last-cell! set cell)
  ;; Maintain forward chain
  (set-set-cell-next! cell '())
  (if (null? (set-cell-previous cell))
      (set-set-first-cell! set cell)
      (set-set-cell-next! (set-cell-previous cell) cell)))

;;; set-insert-last!: set x any -> void
(define (set-insert-last! set item)
  (set-insert-cell-last! set (make-set-cell '() '() #f item)))

;;; set-insert-cell-priority!
(define (set-insert-cell-priority! set cell)
  (set-set-n! set (+ (set-n set) 1))
  (let ((cells (set-first-cell set)))
    (let loop ()
      (when (and (not (null? cells))
                 (<= (set-cell-priority cell)
                     (set-cell-priority (car cells))))
        (set! cells (cdr cells))
        (loop)))
    (set-set-cell-next! cell (car cells))
    (set-set-cell-previous! cell (if cells
                                     (set-cell-previous (car cells))
                                     (set-last-cell set)))
    (when (null? (set-cell-next cell))
      (set-set-last-cell! set cell))
    (when (null? (set-cell-previous cell))
      (set-set-first-cell! set cell))))

;;; set-insert-priority!
(define (set-insert-priority! set item priority)
  (set-insert-cell-priority! set (make-set-cell '() '() priority item)))

;;; set-remove-cell!: set x set-cell -> void
(define (set-remove-cell! set cell)
  ;; Decrement n
  (set-set-n! set (- (set-n set) 1))
  ;; Maintain forward chain
  (if (null? (set-cell-previous cell))
      (set-set-first-cell! set (set-cell-next cell))
      (set-set-cell-next! (set-cell-previous cell)
                          (set-cell-next cell)))
  ;; Maintain reverse chain
  (if (null? (set-cell-next cell))
      (set-set-last-cell! set (set-cell-previous cell))
      (set-set-cell-previous! (set-cell-next cell)
                              (set-cell-previous cell)))
  ;; Clean up cell links
  (set-set-cell-next! cell '())
  (set-set-cell-previous! cell '()))

;;; set-remove-item!: set x item -> (set-cell or #f)
(define (set-remove-item! set item)
  (let ((cell (set-find-cell set item)))
    (set-remove-cell! set cell)
    cell))

;;; set-remove-first-cell!: set -> set-cell
;;; set-remove-first-cell!: set x procedure -> (set-cell or any)
(define set-remove-first-cell!
  (case-lambda
    ((set)
     (when (set-empty? set)
       (error 'set-remove-first-cell!
              "set is empty"))
     (let ((cell (set-first-cell set)))
       (set-remove-cell! set cell)
       cell))
    ((set error-thunk)
     (if (set-empty? set)
         ((error-thunk))
         (set-remove-first-cell! set)))))

;;; set-remove-first!: set -> any
;;; set-remove-first!: set x procedure -> any
(define set-remove-first!
  (case-lambda
    ((set)
     (when (set-empty? set)
       (error 'set-remove-first!
              "set is empty"))
     (set-cell-item (set-remove-first-cell! set)))
    ((set error-thunk)
     (if (set-empty? set)
         ((error-thunk))
         (set-remove-first! set)))))

;;; set-remove-last-cell!: set -> set-cell
;;; set-remove-last-cell!: set x procedure -> (set-cell or any)
(define set-remove-last-cell!
  (case-lambda
    ((set)
     (when (set-empty? set)
       (error 'set-remove-last-cell!
              "set is empty"))
     (let ((cell (set-last-cell set)))
       (set-remove-cell! set cell)
       cell))
    ((set error-thunk)
     (if (set-empty? set)
         ((error-thunk))
         (set-remove-last-cell! set)))))

;;; set-remove-last!: set -> any
;;; set-remove-last!: set x procedure -> any
(define set-remove-last!
  (case-lambda
    ((set)
     (when (set-empty? set)
       (error 'set-remove-last!
              "set is empty"))
     (set-cell-item (set-remove-last-cell! set)))
    ((set error-thunk)
     (if (set-empty? set)
         ((error-thunk))
         (set-remove-last! set)))))

;;; Generic routines

(define set-insert!
  (case-lambda
    ((set item priority)
     (case (set-type set)
       ((#:fifo)
        (set-insert-last! set item))
       ((#:lifo)
        (set-insert-first! set item))
       ((#:priority)
        (set-insert-priority! set item priority))
       (else
        (error 'set-insert! "unknown set type ~a" (set-type set)))))
    ((set item)
     (case (set-type set)
       ((#:fifo)
        (set-insert-last! set item))
       ((#:lifo)
        (set-insert-first! set item))
       ((#:priority)
        (set-insert-priority! set item 100))
       (else
        (error 'set-insert! "unknown set type ~a" (set-type set)))))))

(define set-remove!
  (case-lambda
    ((set item)
     (set-remove-item! set item))
    ((set)
     (set-remove-first! set))))