examples/harbor-model.rkt
#lang racket
;;; Harbor Model

(require (planet williams/simulation/simulation-with-graphics))

;;; Data Collection Variables

;;; cycle-time : (or/c variable? false/c) = #f
(define cycle-time #f)

;;; Model Definition

;;; random-sources : (vectorof random-source?)
(define random-sources (make-random-source-vector 2))

;;; the-dock : (or/c set? false/c)
;;; the-queue : (or/c set? false/c)
(define the-dock #f)
(define the-queue #f)

;;; (scheduler) -> void?
(define (scheduler)
  (let loop ()
    (make-object ship%)
    (wait (random-exponential (vector-ref random-sources 0) (/ 4.0 3.0)))
    (loop)))

(define-process-class ship%
  (field (unloading-time (random-flat (vector-ref random-sources 1) 1.0 2.5)))
  (let ((arrival-time (current-simulation-time)))
    (when (not (harbor-master this 'arriving))
      (queue-insert! the-queue this)
      (suspend-process))
    (work unloading-time)
    (queue-remove! the-dock this)
    (set-variable-value!
     cycle-time (- (current-simulation-time) arrival-time))
    (harbor-master this 'leaving)))

(define ship-unloading-time
  (class-field-accessor ship% unloading-time))

(define set-ship-unloading-time!
  (class-field-mutator ship% unloading-time))

(define (harbor-master ship action)
  (case action
    ((arriving)
     (if (< (queue-n the-dock) 2)
         ;; Dock is not full
         (begin
           (if (queue-empty? the-dock)
               (set-ship-unloading-time!
                ship (/ (ship-unloading-time ship) 2.0))
               (let ((other-ship (queue-first the-dock)))
                 (send other-ship interrupt)
                 (send other-ship set-time (* (send other-ship get-time) 2.0))
                 (send other-ship resume)))
           (queue-insert! the-dock ship)
           #t)
         ;; Dock is full
        #f))
    ((leaving)
     (if (queue-empty? the-queue)
         (when (not (queue-empty? the-dock))
           (let ((other-ship (queue-first the-dock)))
             (send other-ship interrupt)
             (send other-ship set-time (/ (send other-ship get-time) 2.0))
             (send other-ship resume)
             #t))
         (let ((next-ship (queue-remove-first! the-queue)))
           (queue-insert! the-dock next-ship)
           (send next-ship resume)
           #t)))
    (else
     (error 'harbor-master "illegal action value ~a" action))))

(define (stop-sim)
  (printf "Harbor Model - report after ~a simulated days - ~a ships processed~n"
          (current-simulation-time) (variable-n cycle-time))
  (printf "Minimum unload time was ~a~n"
          (variable-minimum cycle-time))
  (printf "Maximum unload time was ~a~n"
          (variable-maximum cycle-time))
  (printf "Average queue of ships waiting to be unloaded was ~a~n"
          (variable-mean (queue-variable-n the-queue)))
  (printf "Maximum queue was ~a~n"
          (variable-maximum (queue-variable-n the-queue)))
  (write-special (history-plot (variable-history (queue-variable-n the-queue))
                               "History of Waiting Queue"))
  (newline)
  (stop-simulation))

(define (run-simulation)
  (with-new-simulation-environment
   (set! cycle-time (make-variable))
   (tally (variable-statistics cycle-time))
   (set! the-dock (make-queue))
   (set! the-queue (make-queue))
   (accumulate (variable-history (queue-variable-n the-queue)))
   (schedule #:now (scheduler))
   (schedule #:at 80.0 (stop-sim))
   (start-simulation)))

(run-simulation)