#lang racket/base
;;; Racket Simulation Collection
;;; queue.rkt
;;; Copyright (c) 2005-2011 M. Douglas Williams
;;;
;;; This file is part of the Racket Simulation Collection.
;;;
;;; The Racket Simulation Collection 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 3 of the License,
;;; or (at your option) any later version.
;;;
;;; The Racket Simulation Collection 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 the Racket Simulation Collection.  If not, see
;;; <http://www.gnu.org/licenses/>.
;;;
;;; -----------------------------------------------------------------------------
;;;
;;; Version  Date      Description
;;; 3.0.0    06/24/08  Updated for V4.0. (MDW)
;;; 3.0.1    11/27/08  Converted to a module. (MDW)
;;; 4.0.0    08/15/10  Converted to Racket. (MDW)

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

(require "environment.rkt")

;;; Queue-cell structure
(struct queue-cell (next
                    previous
                    priority
                    item)
  #:mutable)

;;; Queue structure
(struct queue (variable-n
               first-cell
               last-cell
               type)
  #:mutable)

;;; (make-queue (type '#:fifo)) -> queue?
;;;   type : (one-of/c '#:fifo '#:lifo '#:priority)
(define (make-queue (type '#:fifo))
  (queue (make-variable 0) '() '() type))

;;; (queue-n queue) -> exact-nonnegative-integer?
;;;   queue : queue?
(define (queue-n queue)
  (variable-value (queue-variable-n queue)))

;;; (set-queue-n! queue n) -> void?
;;;   queue : queue?
;;;   n : exact-nonnegative-integer?
(define (set-queue-n! queue n)
  (set-variable-value! (queue-variable-n queue) n))

;;; (queue-empty? queue) -? boolean?
;;;   queue : queue?
(define (queue-empty? queue)
  (= (queue-n queue) 0))

;;; (queue-first queue) -> any
;;;   queue : queue?
(define (queue-first queue)
  (when (queue-empty? queue)
    (error 'queue-first
           "queue is empty"))
  (queue-cell-item (queue-first-cell queue)))

;;; (queue-last queue) -> any
;;;   queue : queue?
(define (queue-last queue)
  (when (queue-empty? queue)
    (error 'queue-last
           "queue is empty"))
  (queue-cell-item (queue-last-cell queue)))

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

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

;;; (queue-find-cell queue item) -> queue-cell?
;;;   queue : queue?
;;;   item : any/c
(define (queue-find-cell queue item)
  (let/ec exit
    (queue-for-each-cell queue
      (lambda (cell)
        (when (eq? (queue-cell-item cell) item)
          (exit cell))))
    #f))

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

;;; (queue-insert-first! queue item) -> void?
;;;   queue : queue?
;;;   item : any/c
(define (queue-insert-first! queue item)
  (queue-insert-cell-first! queue (queue-cell '() '() #f item)))

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

;;; (queue-insert-last! queue item) -> void?
;;;   queue : queue?
;;;   item : any/c
(define (queue-insert-last! queue item)
  (queue-insert-cell-last! queue (queue-cell '() '() #f item)))

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

;;; (queue-insert-priority! queue item priority) -> void?
;;;   queue : queue?
;;;   item : any/c
;;;   priority : real?
(define (queue-insert-priority! queue item priority)
  (queue-insert-cell-priority! queue (queue-cell '() '() priority item)))

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

;;; (queue-remove-item! queue item)-> (or/c false/c any)
;;;   queue : queue?
;;;   item : any/c
(define (queue-remove-item! queue item)
  (let ((cell (queue-find-cell queue item)))
    (queue-remove-cell! queue cell)
    cell))

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

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

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

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

;;; Generic routines

;;; (queue-insert! queue item priority) -> void?
;;;   queue : queue?
;;;   item : any/c
;;;   priority : real? = 100
(define (queue-insert! queue item (priority 100))
  (case (queue-type queue)
    ((#:fifo)
     (queue-insert-last! queue item))
    ((#:lifo)
     (queue-insert-first! queue item))
    ((#:priority)
     (queue-insert-priority! queue item priority))
    (else
     (error 'queue-insert! "unknown queue type ~a" (queue-type queue)))))

;;; (queue-remove! queue item) -> (or/c false/c any)
;;;   queue : queue?
;;;   item : item?
;;; (queue-remove! queue item) -> (or/c false/c any)
;;;   queue : queue?
(define queue-remove!
  (case-lambda
    ((queue item)
     (queue-remove-item! queue item))
    ((queue)
     (queue-remove-first! queue))))

;;; Module Contracts

(provide (all-defined-out))