;;; PLT Scheme Simulation Collection
;;; resource.ss
;;; Copyright (c) 2004 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.
;;;
;;; -------------------------------------------------------------------
;;;
;;; This module implements resources.
;;;
;;; Version  Date      Description
;;; 0.1.0    10/16/04  Initial implementation of resources.  (Doug
;;;                    Williams)
;;; 0.1.1    06/06/05  Renamed resource slots to simplify references
;;;                    for data collection.  (Doug Williams)

(define-struct allocation
               (process
                units))

;;; Resource structure
;;; Index  Field                  Description
;;;   0    units                  Total # of units
;;;   1    units-available        # of units not allocated
;;;   2    units-allocated        # of units allocated to processes
;;;   3    satisfied              Set of processes satisfied
;;;   4    queue                  Set of processes waiting
(define-values (struct:resource
                resource-constructor
                resource?
                resource-field-ref
                set-resource-field!)
  (make-struct-type 'resource #f 5 0))

;;; Resource structure, units field
(define resource-units
  (make-struct-field-accessor resource-field-ref 0 'units))

;;; Resource structure, units-available field
(define resource-units-available
  (make-struct-field-accessor resource-field-ref 1 'units-available))

(define set-resource-units-available!
  (make-struct-field-mutator set-resource-field! 1 'units-available))

;;; Resource structure, units-allocated field
(define resource-units-allocated
  (make-struct-field-accessor resource-field-ref 2 'units-allocated))

(define set-resource-units-allocated!
  (make-struct-field-mutator set-resource-field! 2 'units-allocated))

;;; Resource structure, satisfied field
(define resource-satisfied
  (make-struct-field-accessor resource-field-ref 3 'satisfied))

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

;;; Resource structure, queue field
(define resource-queue
  (make-struct-field-accessor resource-field-ref 4 'queue))

(define set-resource-queue!
  (make-struct-field-mutator set-resource-field! 4 'queue))

;;; make-resource: -> resource
;;; Create and return a resource with the specified number of units,
;;; or 1, if not specified.
(define make-resource
  (case-lambda
    ((units)
     (resource-constructor
      units                           ; units
      units                           ; units-available
      0                               ; units-allocated
      (make-set)                    ; satisfied
      (make-set)))                  ; queue
    (()
     (make-resource 1))))

;;; resource-process-allocation:
;;;   resource x process -> (allocation or #f)
;;; Returns the resource allocation for a process or #f if none.
(define (resource-process-allocation resource process)
  (let/ec exit
    (set-for-each (resource-satisfied resource)
      (lambda (allocation)
        (if (eq? (allocation-process allocation) process)
            (exit allocation))))
    #f))

;;; resource-allocate: resource x integer x process -> void
;;; Allocate the specified number of units of the resource to the
;;; process.  If there is an existing allocation, the units are added
;;; to it; otherwise, a new allocation is created.
(define (resource-allocate resource units process)
  (let ((process-allocation (resource-process-allocation resource process)))
    (if process-allocation
        (set-allocation-units!
         process-allocation 
         (+ (allocation-units process-allocation) units))
        (set-insert-last!
         (resource-satisfied resource)
         (make-allocation process units)))
    (set-resource-units-available!
     resource
     (- (resource-units-available resource) units))
    (set-resource-units-allocated!
     resource
     (+ (resource-units-allocated resource) units))))

;;; resource-deallocate: respurce x integer x process -> void
;;; Deallocate the specified number of units of the resource from the
;;; process.  If there is an existing allocation and not all of the
;;; units are deallocated, the units are subtracted from it; otherwise
;;; the allocation is removed.
(define (resource-deallocate resource units process)
  (let ((process-allocation (resource-process-allocation resource process)))
    (if (< units (allocation-units process-allocation))
        (set-allocation-units!
         process-allocation
         (- (allocation-units process-allocation) units))
        (set-remove! (resource-satisfied resource)
                     process-allocation))
    (set-resource-units-available!
     resource
     (+ (resource-units-available resource) units))
    (set-resource-units-allocated!
     resource
     (- (resource-units-allocated resource) units))))

;;; resource-request: resource x integer -> void
;;; resource-request: resource -> void
;;; Request, by a process, for the specified number of units of a
;;; resource.  If the request cannot be satisfied, the process is
;;; places on a waiting queue.
(define resource-request
  (case-lambda
    ((resource units)
     (let ((process (current-simulation-process)))
       ;; The request must be for a process
       (if (not process)
           (error 'resource-request
                  "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (if (and process-allocation
                  (> (+ (allocation-units process-allocation) units)
                     (resource-units resource)))
             (error 'resource-request
                    "units requested for process exceeds units available")))
       ;; Process the request
       (let/cc continuation
         (if (> units (resource-units-available resource))
             ;; If insufficient units to satisfy the request,
             ;; then queue the request
             (let ((new-allocation (make-allocation process units))
                   (event (process-event process)))
               ;; Update process event
               (set-event-function! event continuation)
               (set-event-arguments! event '())
               ;; Add to allocations-waiting
               (set-insert-last!
                (resource-queue resource) new-allocation)
               ((current-simulation-loop-next)))
             ;; Otherwise, satisfy the request
             (resource-allocate resource units process)))))
    ((resource)
     (resource-request resource 1))))

;;; resource-relinquish: resource x integer -> void
;;; Release the specified number of units of the resource.  If the
;;; number of units is not specified, then all of the units held by
;;; the process are released.
(define resource-relinquish
  (case-lambda
    ((resource units)
     (let ((process (current-simulation-process)))
       (if (not process)
           (error 'resource-relinquish
                  "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (if (not process-allocation)
             (error 'resource-relinquish
                    "attempt to release units when none are allocated"))
         (if (> units (allocation-units process-allocation))
             (error 'resource-relinquish
                    "attempt to relase more units than allocated"))
         ;; Deallocate the resource units
         (resource-deallocate resource units process)
         ;; Check for waiting allocations that might now be satisfied
         (let/ec exit
           (set-for-each-cell (resource-queue resource)
             (lambda (cell)
               (if (= (resource-units-available resource) 0)
                   (exit))
               (let ((allocation (set-cell-item cell)))
                 (if (<= (allocation-units allocation)
                         (resource-units-available resource))
                     (let ((process (allocation-process allocation)))
                       ;; Remove the allocation from the waiting list
                       (set-remove-cell!
                        (resource-queue resource)
                        cell)
                       ;; Allocate the resource units
                       (resource-allocate
                        resource (allocation-units allocation) process)
                       ;; Schedule the process for execution now
                       (schedule-event (process-event process) 'now))))))))
       (void)))
    ((resource)
     (let ((process (current-simulation-process)))
       (if (not process)
           (error 'resource-request
                  "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (if (not process-allocation)
             (error 'resource-request
                    "attempt to release units when none are allocated"))
         (resource-relinquish resource (allocation-units process-allocation)))))))

;;; Shortcuts to set variables
(define (resource-queue-variable-n resource)
  (set-variable-n (resource-queue resource)))

(define (resource-satisfied-variable-n resource)
  (set-variable-n (resource-satisfied resource)))

;;; resource-print: resource -> void
;(define (resource-print resource)
;  (printf "Resource units total/available/allocated = ~a/~a/~a~n"
;          (resource-units resource)
;          (resource-units-available resource)
;          (resource-units-allocated resource))
;  (printf "Wait queue:~n")
;  (set-print (resource-allocations-waiting resource)))

(define-syntax with-resource
  (syntax-rules ()
    ((with-resource (resource units)
       body ...)
     (begin
       (resource-request resource units)
       body ...
       (resource-relinquish resource units)))
    ((with-resource (resource)
       body ...)
     (with-resource (resource 1)
       body ...))))