#lang scheme/base
;;; PLT Scheme Simulation Collection
;;; resource.ss
;;; Copyright (c) 2004-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.
;;;
;;; -------------------------------------------------------------------
;;;
;;; 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)
;;; 1.0.0    02/22/06  Added reneging and priority.  (Doug Williams)
;;; 1.0.1    03/24/06  Changed with to when in request macro.  (Doug
;;;                    Williams)
;;; 3.0.0    06/24/08  Updated for V4.0.  (Doug Williams)
;;; 3.0.1    11/27/08  Converted to a module.  (Doug Williams)

(require "simulation-environment.ss"
         "simulation-control.ss"
         "event.ss"
         "process.ss"
         "set.ss")

(provide (all-defined-out))

(define-struct allocation
               (process
                units)
  #:mutable)

;;; 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)
        (when (eq? (allocation-process allocation) process)
          (exit allocation))))
    #f))

;;; resource-process-queue:
;;;   resource x process -> (allocation or #f)
;;; Returns the resource waiting for a process or #f if none.
(define (resource-process-queue resource process)
  (let/ec exit
    (set-for-each (resource-queue resource)
      (lambda (allocation)
        (when (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 priority reneg)
     (let ((process (current-simulation-process)))
       ;; The request must be for a process
       (when (not process)
         (error 'resource-request
                "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (when (and process-allocation
                    (> (+ (allocation-units process-allocation) units)
                       (resource-units resource)))
           (error 'resource-request
                  "units requested for process exceeds units available")))
       ;; Process the request
       (if (> units (resource-units-available resource))
           ;; If insufficient units to satisfy the request,
           ;; then queue the request
           (begin
             (let/cc continuation
               (let ((new-allocation (make-allocation process units))
                     (event (process-event process)))
                 ;; Update process event
                 (set-event-function! event continuation)
                 (set-event-arguments! event '())
                 (when reneg
                   (schedule-event event reneg))
                 ;; Add to allocations-waiting
                 (if (= priority -inf.0)
                     (set-insert-last!
                      (resource-queue resource) new-allocation)
                     (set-insert-priority!
                      (resource-queue resource) new-allocation priority))
                 ((current-simulation-loop-next))))
             ;; Did we reneg or was the allocation fullfilled?
             (let ((process-queue (resource-process-queue resource process)))
               (if process-queue
                   ;; This is a reneg
                   (begin
                     (set-remove! (resource-queue resource) process-queue)
                     #f)
                   ;; Otherwise, the allocation has been fullfillef
                   ;; The (potential) reneg has been removed (in
                   ;; resource-relinquish).
                   #t)))
           ;; Otherwise, satisfy the request
           (begin
             (resource-allocate resource units process)
             #t))))
    ((resource units priority)
     (resource-request resource units priority #f))
    ((resource units)
     (resource-request resource units -inf.0 #f))
    ((resource)
     (resource-request resource 1 -inf.0 #f))))

;;; 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)))
       (when (not process)
         (error 'resource-relinquish
                "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (when (not process-allocation)
           (error 'resource-relinquish
                  "attempt to release units when none are allocated"))
         (when (> 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
         (when (not (set-empty? (resource-queue resource)))
           (let ((highest (set-cell-priority
                           (set-first-cell
                            (resource-queue resource)))))
             (let/ec exit
               (set-for-each-cell (resource-queue resource)
                                  (lambda (cell)
                                    (when (or (= (resource-units-available resource) 0)
                                              (and (set-cell-priority cell)
                                                   (< (set-cell-priority cell) highest)))
                                      (exit))
                                    (let ((allocation (set-cell-item cell)))
                                      (when (<= (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)
                                          ;; Remove the reneg event, if any
                                          (event-list-remove! (process-event process))
                                          ;; Schedule the process for execution now
                                          (schedule-event (process-event process) '#:now))))))))))
       (void)))
    ((resource)
     (let ((process (current-simulation-process)))
       (when (not process)
         (error 'resource-request
                "no current process"))
       (let ((process-allocation (resource-process-allocation resource process)))
         (when (not process-allocation)
           (error 'resource-request
                  "attempt to release units when none are allocated"))
         (resource-relinquish resource (allocation-units process-allocation)))))))

;;; Macro: request
(define-syntax request
  (syntax-rules (now at in when)
    ;; #:units units
    ((request "process keywords" resource u priority reneg (#:units units))
     (request "process keywords" resource units priority reneg ()))
    ((request "process keywords" resource u priority reneg (#:units units . rest))
     (request "process keywords" resource units priority reneg (rest)))
    ;; #:priority priority
    ((request "process keywords" resource units p reneg (#:priority priority))
     (request "process keywords" resource units priority reneg ()))
    ((request "process keywords" resource units p reneg (#:priority priority . rest))
     (request "process keywords" resource units priority reneg (rest)))
    ;; #:leave now
    ((request "process keywords" resource units priority reneg (#:leave now))
     (request "process keywords" resource units priority #:now ()))
    ((request "process keywords" resource units priority reneg (#:leave now . rest))
     (request "process keywords" resource units priority #:now (rest)))
    ;; #:leave (at time)
    ((request "process keywords" resource units priority reneg (#:leave (at time)))
     (request "process keywords" resource units priority time ()))
    ((request "process keywords" resource units priority reneg (#:leave (at time) . rest))
     (request "process keywords" resource units priority time (rest)))
    ;; #:leave (in delay)
    ((request "process keywords" resource units priority reneg (#:leave (in delay)))
     (request "process keywords" resource units priority (+ (current-simulation-time)  delay) ()))
    ((request "process keywords" resource units priority reneg (#:leave (in delay) . rest))
     (request "process keywords" resource units priority (+ (current-simulation-time) delay) (rest)))
    ;; #:leave (when event)
    ((request "process keywords" resource units priority reneg (#:leave (when event)))
     (request "process keywords" resource units priority event ()))
    ((request "process keywords" resource units priority reneg (#:leave (when event) . rest))
     (request "process keywords" resource units priority event (rest)))
    ;; #:leave time
    ((request "process keywords" resource units priority reneg (#:leave time))
     (request "process keywords" resource units priority time ()))
    ((request "process keywords" resource units priority reneg (#:leave time . rest))
     (request "process keywords" resource units priority time (rest)))
    ;; no keywords left
    ((request "process keywords" resource units priority reneg ())
     (resource-request resource units priority reneg))
    ;; keyword error
    ((request "process keywords" . rest)
     (syntax-error rest))
    ((request resource)
     (request "process keywords" resource 1 -inf.0 #f ()))
    ((request resource . rest)
     (request "process keywords" resource 1 -inf.0 #f rest))
    ))

;;; Macro: relinquish
(define-syntax relinquish
  (syntax-rules ()
    ((relinquish resource (#:units units))
     (resource-relinquish resource units))
    ((relinquish resource)
     (resource-relinquish resource))))

;;; Macro: with-resource
(define-syntax with-resource
  (syntax-rules ()
    ((with-resource (resource . rest)
       body ...)
     (begin
       (request resource . rest)
       body ...
       (relinquish resource)))))

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