97 lines
2.6 KiB
Scheme
97 lines
2.6 KiB
Scheme
;;; -*-Scheme-*-
|
|
|
|
(require 'cscheme)
|
|
|
|
(define (displayLine . someArgs)
|
|
(for-each
|
|
(lambda (aTerm) (display aTerm) (display " "))
|
|
someArgs)
|
|
(newline))
|
|
|
|
(define (Monitor)
|
|
|
|
(define stopAtMonitorLevel #f)
|
|
(define clock 0)
|
|
(define stopTime 0)
|
|
(define processIndicators '())
|
|
|
|
(define (setInitialProcessState! aContinuation)
|
|
(set! processIndicators
|
|
(cons (list 0 aContinuation) processIndicators))
|
|
(stopAtMonitorLevel #f))
|
|
|
|
(define (startSimulation! aDuration)
|
|
(set! stopTime aDuration)
|
|
(if (not (null? processIndicators))
|
|
(let ((firstIndicatorOnList (car processIndicators)))
|
|
(set! processIndicators
|
|
(remove firstIndicatorOnList processIndicators))
|
|
(resumeSimulation! firstIndicatorOnList))
|
|
(displayLine "*** no active process recorded!")))
|
|
|
|
(define (resumeSimulation! aProcessState)
|
|
(set! processIndicators
|
|
(cons aProcessState processIndicators))
|
|
(let ((nextProcessState aProcessState))
|
|
(for-each (lambda (aStatePair)
|
|
(if (< (car aStatePair) (car nextProcessState))
|
|
(set! nextProcessState aStatePair)))
|
|
processIndicators)
|
|
(let ((time (car nextProcessState))
|
|
(continuation (cadr nextProcessState)))
|
|
(set! processIndicators
|
|
(remove nextProcessState processIndicators))
|
|
(if (<= time stopTime)
|
|
(begin (set! clock time)
|
|
(continuation #f))
|
|
(begin (displayLine "*** simulation stops at:" clock)
|
|
(stopAtMonitorLevel #f))))))
|
|
|
|
(define (dispatch aMessage . someArguments)
|
|
(cond ((eq? aMessage 'initialize)
|
|
(setInitialProcessState! (car someArguments)))
|
|
((eq? aMessage 'startSimulation)
|
|
(startSimulation! (car someArguments)))
|
|
((eq? aMessage 'proceed)
|
|
(resumeSimulation! (car someArguments)))
|
|
((eq? aMessage 'time)
|
|
clock)
|
|
((eq? aMessage 'processIndicators)
|
|
processIndicators)
|
|
(else
|
|
"Sorry, I don't know how to do this!")))
|
|
|
|
(call-with-current-continuation
|
|
(lambda (anArg)
|
|
(set! stopAtMonitorLevel anArg)))
|
|
dispatch)
|
|
|
|
|
|
|
|
|
|
(define (Tourist aName aMonitor)
|
|
(call-with-current-continuation
|
|
(lambda (anArg)
|
|
(aMonitor 'initialize anArg)))
|
|
(displayLine aName "starts at" (aMonitor 'time))
|
|
(while #t
|
|
(displayLine aName "walks on at" (aMonitor 'time))
|
|
(call-with-current-continuation
|
|
(lambda (anArg)
|
|
(aMonitor 'proceed
|
|
(list (+ (aMonitor 'time) 1) anArg))))
|
|
(displayLine aName "arrives at new attraction at" (aMonitor 'time))
|
|
(call-with-current-continuation
|
|
(lambda (anArg)
|
|
(aMonitor 'proceed
|
|
(list (+ (aMonitor 'time) 2)
|
|
anArg))))))
|
|
|
|
|
|
(define Gallery (Monitor))
|
|
|
|
(Tourist 'Jane Gallery)
|
|
(Tourist 'Bruce Gallery)
|
|
|
|
(Gallery 'startSimulation 5)
|