#lang scheme
;;; Harbor Model

(require (planet "simulation-with-graphics.ss"
                 ("williams" "simulation.plt")))
(require (planet "random-distributions.ss"
                 ("williams" "science.plt")))

;;; Data collection variables
(define cycle-time #f)

;;; Model definition
(define random-sources (make-random-source-vector 2))

(define dock #f)
(define queue #f)

(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))
      (set-insert! queue this)
      (suspend-process))
    (work unloading-time)
    (set-remove! 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 (< (set-n dock) 2)
         ;; Dock is not full
         (begin
           (if (set-empty? dock)
               (set-ship-unloading-time!
                ship (/ (ship-unloading-time ship) 2.0))
               (let ((other-ship (set-first dock)))
                 (send other-ship interrupt)
                 (send other-ship set-time (* (send other-ship get-time) 2.0))
                 (send other-ship resume)))
           (set-insert! dock ship)
           #t)
         ;; Dock is full
        #f))
    ((leaving)
     (if (set-empty? queue)
         (when (not (set-empty? dock))
           (let ((other-ship (set-first 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 (set-remove-first! queue)))
           (set-insert! 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 (set-variable-n queue)))
  (printf "Maximum queue was ~a~n"
          (variable-maximum (set-variable-n queue)))
  (write-special (history-plot (variable-history (set-variable-n 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! dock (make-set))
   (set! queue (make-set))
   (accumulate (variable-history (set-variable-n queue)))
   (schedule now (scheduler))
   (schedule (at 80.0) (stop-sim))
   (start-simulation)))

(run-simulation)