;;; PLT Scheme Simulation Collection
;;; event.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 file contains the implementations of events and event lists.
;;;
;;; Version  Date      Description
;;; 0.1.0    10/16/04  The initial implemention of events and event
;;;                    lists.  (Doug Williams)
;;; 1.0.0    02/17/06  Added support for linked events.  (Doug
;;;                    Williams)
;;; 2.0.0    06/05/08  Modified event list manipulation routines for
;;;                    V4.0.  (Doug Williams)
;;; 3.0.0    06/24/08  Updated for V4.0.  (Doug Williams)

;;; Event structure
;;; An event represents the future execution of a process or procedural
;;; object (primitive event).
;;; Field  Description
;;;   0    time               time the event is to occur
;;;   1    priority           priority of the event
;;;   2    process            process owning the event or #f
;;;   3    function           function implementing the event
;;;   4    arguments          arguments to the function
;;;   5    event-list         the event list containing this event
;;;                           or #f
;;;   6    linked-event-list  event list containing the events linked
;;;                           to this event or #f
(define-values (struct:event
                event-constructor
                event?
                event-field-ref
                set-event-field!)
  (make-struct-type 'event #f 7 0))

;;; Event structure, time field
(define event-time
  (make-struct-field-accessor event-field-ref 0 'time))
(define set-event-time!
  (make-struct-field-mutator set-event-field! 0 'time))

;;; Event structure, priority field
(define event-priority
  (make-struct-field-accessor event-field-ref 1 'priority))
(define set-event-priority!
  (make-struct-field-mutator set-event-field! 1 'priority))

;;; Event structure, process field
(define event-process
  (make-struct-field-accessor event-field-ref 2 'process))
(define set-event-process!
  (make-struct-field-mutator set-event-field! 2 'process))

;;; Event structure, function field
(define event-function
  (make-struct-field-accessor event-field-ref 3 'function))
(define set-event-function!
  (make-struct-field-mutator set-event-field! 3 'function))

;;; Event structure, arguments field
(define event-arguments
  (make-struct-field-accessor event-field-ref 4 'arguments))
(define set-event-arguments!
  (make-struct-field-mutator set-event-field! 4 'arguments))

;;; Event structure, event-list field
(define event-event-list
  (make-struct-field-accessor event-field-ref 5 'event-list))
(define set-event-event-list!
  (make-struct-field-mutator set-event-field! 5 'event-list))

;;; Event structure, linked-event-list field
(define event-linked-event-list
  (make-struct-field-accessor event-field-ref 6 'linked-event-list))
(define set-event-linked-event-list!
  (make-struct-field-mutator set-event-field! 6 'linked-event-list))

;;; make-event: real x (union process or #f) x procedure x list
;;;             -> event
(define (make-event time priority process function arguments)
  (event-constructor time priority process function arguments #f #f))

;;; Event-list structure
;;; An event list maintains a list of events.  Used to implement the
;;; now and future event lists.
(define-values (struct:event-list
                event-list-constructor
                event-list?
                event-list-field-ref
                set-event-list-field!)
  (make-struct-type 'event-list #f 1 0))

;;; Event List, events field
(define event-list-events
  (make-struct-field-accessor event-list-field-ref 0 'events))

(define set-event-list-events!
  (make-struct-field-mutator set-event-list-field! 0 'events))

;;; make-event-list: -> event-list
(define (make-event-list)
  (event-list-constructor '()))

;;; event-list-empty?: event-list -> boolean
(define (event-list-empty? event-list)
  (eq? (event-list-events event-list) '()))

;;; event-list-add!: event-list x event -> void
;;; Add an event to an event list.  Currently, events are ordered by
;;; time only.
;;; 06/05/2008 - MDW - Modified the routines to use mutable cons
;;; cells
(define (event-list-add! event-list event)
  (let ((events (event-list-events event-list))
        (previous #f))
    (let loop ()
      (when (and (not (null? events))
                 (or (> (event-time event)
                        (event-time (mcar events)))
                     (and (= (event-time event)
                             (event-time (mcar events)))
                          (<= (event-priority event)
                              (event-priority (mcar events))))))
        (set! previous events)
        (set! events (mcdr events))
        (loop)))
    (set-event-event-list! event event-list)
    (if previous
        (set-mcdr! previous (mcons event events))
        (set-event-list-events! event-list (mcons event events)))))

;;; event-list-remove!: event-list x event -> void
;;; 06/05/2008 - MDW - Modified the routines to use mutable cons
;;; cells
(define event-list-remove!
  (case-lambda
    ((event-list event)
     (let loop ((previous #f)
                (events (event-list-events event-list)))
       (when (not (null? events))
         (if (eq? event (mcar events))
             (begin
               (if previous
                   (set-mcdr! previous (mcdr events))
                   (set-event-list-events!
                    event-list (mcdr events)))
               (set-event-event-list! event #f))
             (loop events (mcdr events))))))
    ((event)
     (when (event-event-list event)
       (event-list-remove! (event-event-list event) event)))))

;;; event-list-pop!: event-list -> event
;;; Remove and return the next event to be executed from an event list.
;;; 06/05/2008 - MDW - Modified the routines to use mutable cons
;;; cells
(define (event-list-pop! event-list)
  (let* ((events (event-list-events event-list))
         (event (mcar events)))
    (set-event-list-events! event-list (mcdr events))
    (set-event-event-list! event #f)
    event))