home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / examples / scheme / co < prev    next >
Encoding:
Text File  |  1990-04-03  |  2.6 KB  |  97 lines
  1. ;;; -*-Scheme-*-
  2.  
  3. (require 'cscheme)
  4.  
  5. (define (displayLine . someArgs)
  6.   (for-each
  7.    (lambda (aTerm) (display aTerm) (display " "))
  8.    someArgs)
  9.   (newline))
  10.  
  11. (define (Monitor)
  12.  
  13.   (define stopAtMonitorLevel #f)
  14.   (define clock 0)
  15.   (define stopTime 0)
  16.   (define processIndicators '())
  17.  
  18.   (define (setInitialProcessState! aContinuation)
  19.     (set! processIndicators
  20.       (cons (list 0 aContinuation) processIndicators))
  21.     (stopAtMonitorLevel #f))
  22.  
  23.   (define (startSimulation! aDuration)
  24.     (set! stopTime aDuration)
  25.     (if (not (null? processIndicators))
  26.     (let ((firstIndicatorOnList (car processIndicators)))
  27.       (set! processIndicators
  28.         (remove firstIndicatorOnList processIndicators))
  29.       (resumeSimulation! firstIndicatorOnList))
  30.     (displayLine "*** no active process recorded!")))
  31.   
  32.   (define (resumeSimulation! aProcessState)
  33.     (set! processIndicators
  34.       (cons aProcessState processIndicators))
  35.     (let ((nextProcessState aProcessState))
  36.       (for-each (lambda (aStatePair)
  37.           (if (< (car aStatePair) (car nextProcessState))
  38.               (set! nextProcessState aStatePair)))
  39.         processIndicators)
  40.       (let ((time (car nextProcessState))
  41.         (continuation (cadr nextProcessState)))
  42.     (set! processIndicators
  43.           (remove nextProcessState processIndicators))
  44.     (if (<= time stopTime)
  45.         (begin (set! clock time)
  46.            (continuation #f))
  47.         (begin (displayLine "*** simulation stops at:" clock)
  48.            (stopAtMonitorLevel #f))))))
  49.  
  50.   (define (dispatch aMessage . someArguments)
  51.     (cond ((eq? aMessage 'initialize)
  52.        (setInitialProcessState! (car someArguments)))
  53.       ((eq? aMessage 'startSimulation)
  54.        (startSimulation! (car someArguments)))
  55.       ((eq? aMessage 'proceed)
  56.        (resumeSimulation! (car someArguments)))
  57.       ((eq? aMessage 'time)
  58.        clock)
  59.       ((eq? aMessage 'processIndicators)
  60.        processIndicators)
  61.       (else
  62.        "Sorry, I don't know how to do this!")))
  63.  
  64.   (call-with-current-continuation
  65.    (lambda (anArg)
  66.      (set! stopAtMonitorLevel anArg)))
  67.   dispatch)
  68.         
  69.               
  70.     
  71.     
  72. (define (Tourist aName aMonitor)
  73.   (call-with-current-continuation
  74.    (lambda (anArg)
  75.      (aMonitor 'initialize anArg)))
  76.   (displayLine aName "starts at" (aMonitor 'time))
  77.   (while #t
  78.    (displayLine aName "walks on at" (aMonitor 'time))
  79.    (call-with-current-continuation
  80.     (lambda (anArg)
  81.       (aMonitor 'proceed
  82.         (list (+ (aMonitor 'time) 1) anArg))))
  83.     (displayLine aName "arrives at new attraction at" (aMonitor 'time))
  84.     (call-with-current-continuation
  85.      (lambda (anArg)
  86.        (aMonitor 'proceed
  87.          (list (+ (aMonitor 'time) 2)
  88.                anArg))))))
  89.  
  90.  
  91. (define Gallery (Monitor))
  92.  
  93. (Tourist 'Jane  Gallery)
  94. (Tourist 'Bruce Gallery)
  95.  
  96. (Gallery 'startSimulation 5)
  97.