[foo-cvs] foo/elkfoo/scm/control/processes Makefile.am,NONE,1.1 process.foo,NONE,1.1 scheduler.foo,NONE,1.1

[Martin R. <ru...@us...>]

Update of /cvsroot/foo/foo/elkfoo/scm/control/processes
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv6585/control/processes

Added Files:
	Makefile.am process.foo scheduler.foo 
Log Message:
initial checkin of scheme files, control, tools

--- NEW FILE: process.foo ---
(require 'oops 'oops.scm)

;;;
;;; abstract class Process
;;;

(define-class Process)

;;;
;;; subclasses of Process must override run
;;; run has to return either a non-negative number
;;; indicating the delay after which it will be
;;; called again by the scheduler, or #t to be deactivated,
;;; or #f to be removed from the scheduler
;;;

(define-method Process (run scheduler)
    (error 'run "subclass responsability"))

;;;
;;; the following two methods are envoked by the scheduler
;;; when the priority or the time of the process was changed
;;; at the moment these methods only print what happened (and
;;; show how one gets to the information of what happened)
;;;

(define-method Process (priorityChanged scheduler)
    (format #t "priority changed to ~a for process id ~a~%"
	(send scheduler 'priorityOfProcess self)
	(send scheduler 'idOfProcess self)))

(define-method Process (timeChanged scheduler)
    (format #t "time changed to ~a for process id ~a~%"
	(send scheduler 'timeOfProcess self)
	(send scheduler 'idOfProcess self)))

--- NEW FILE: Makefile.am ---
# foo/elkfoo/scm/control/processes/Makefile.am
# 2004 rumori

# $Id: Makefile.am,v 1.1 2004/08/07 22:53:01 rumori Exp $

NULL = 

pkgprocesses_DATA = $(ELKFOO_PROCESSES_FILES)

pkgprocessesdir = $(pkgdatadir)/control/processes

ELKFOO_PROCESSES_FILES = \
	process.foo \
	scheduler.foo \
	$(NULL)

--- NEW FILE: scheduler.foo ---
(require 'oops 'oops.scm)
(require 'struct 'struct.scm)

;;;
;;; structure thread
;;;

(define-structure thread identifier process priority)

;;;
;;; class Scheduler
;;;

(define-class Scheduler
    (instance-vars
	(time 0)
	(lastId 0)
	(processes (list 'head))
	(waiting (list 'head))
	(queue (list 'head))))

;;;
;;; public methods:
;;;
;;; activateProcess <aProcess>			=> #t | #f
;;; addProcess <aProcess> <aPriority> <aDelay>	=> process id | #f
;;; getTime					=> time
;;; idOfProcess <aProcess>			=> process id | #f
;;; priorityOfProcess <aProcess>		=> process priority | #f
;;; processActive? <aProcess>			=> #t | #f
;;; processOfId <aNumber>			=> process | #f
;;; removeProcess <aProcess>			=> #t | #f
;;; runUntil {<end> | #f}			=> time
;;; setProcessPriority <aProcess> <aPriority>	=> #t | #f
;;; setProcessTime <aProcess> <aTime>		=> #t | #f
;;; setTime <aTime>				=> old time
;;; step					=> time | #f
;;; timeOfProcess <aProcess>			=> process time | #f
;;;

(define-method Scheduler (getTime)
    time)

(define-method Scheduler (setTime aTime)
    (set! time aTime))

(define-method Scheduler (addProcess aProcess aPriority aDelay)
    (if (number? (send self 'idOfProcess aProcess))
	#f
	(set! lastId (1+ lastId))
	(let ((thread (make-thread lastId aProcess aPriority)))
	    (set! processes (append! processes (list thread)))
	    (send self 'enqueue thread (+ aDelay time))
	    lastId)))

(define-method Scheduler (removeProcess aProcess)
    (let ((thread (send self 'remove thread-process aProcess processes)))
	(if (not thread)
	    #f
	    (send self 'dequeue thread)
	    #t)))

(define-method Scheduler (setProcessPriority aProcess aPriority)
    (let ((thread (send self 'find thread-process aProcess processes))
	  (theTime 0))
	(if (not thread)
	    #f
	    (set! theTime (send self 'dequeue thread))
	    (if (not theTime)
		#f
		(set-thread-priority! thread aPriority)
		(send self 'enqueue thread theTime)
		(send (thread-process thread) 'priorityChanged self)
		#t))))

(define-method Scheduler (setProcessTime aProcess aTime)
    (let ((thread (send self 'find thread-process aProcess processes)))
	(if (not thread)
	    #f
	    (send self 'dequeue thread)
	    (send self 'enqueue thread aTime)
	    (send (thread-process thread) 'timeChanged self)
	    #t)))

(define-method Scheduler (priorityOfProcess aProcess)
    (send self 'finder thread-process thread-priority aProcess))

(define-method Scheduler (timeOfProcess aProcess)
    (let* ((keyFunc (lambda (x) (thread-process (cdr x))))
	   (result (send self 'find keyFunc aProcess queue)))
	(if (not result)
	    #f
	    (car result))))

(define-method Scheduler (idOfProcess aProcess)
    (send self 'finder thread-process thread-identifier aProcess))

(define-method Scheduler (processOfId anId)
    (send self 'finder thread-identifier thread-process anId))

(define-method Scheduler (processActive? aProcess)
    (and (send self 'idOfProcess aProcess)
	 (not (send self 'find thread-process aProcess waiting))))

(define-method Scheduler (activateProcess aProcess aDelay)
    (let ((thread (send self 'find thread-process aProcess waiting)))
	(if (not thread)
	    #f
	    (send self 'activate thread aDelay))))

(define-method Scheduler (step)
    (if (null? (cdr queue))
	#f
	(let* ((thread (cdadr queue)) (telay 0)
	       (process (thread-process thread)))
	    (set! time (caadr queue))
	    (set-cdr! queue (cddr queue))
	    (set! telay (send process 'run self))
	    (if (number? telay)
		(send self 'enqueue thread (+ time telay))
		(if (not telay)
		    (send self 'removeProcess process)
		    (send self 'deactivate thread)))
	    time)))

(define-method Scheduler (runUntil end)
    (if (number? end)
	(while (and (not (null? (cdr queue))) (<= (caadr queue) end))
	    (send self 'step))
	(while (send self 'step) '()))
    time)

;;;
;;; private methods
;;;

(define-method Scheduler (finder keyFunc valueFunc anObject)
    (let ((result (send self 'find keyFunc anObject processes)))
	(if (not result)
	    #f
	    (valueFunc result))))

(define-method Scheduler (find keyFunc anObject source)
    (define (loop x)
	(if (null? x)
	    #f
	    (if (eq? (keyFunc (car x)) anObject)
		(car x)
		(loop (cdr x)))))
    (loop (cdr source)))

(define-method Scheduler (remove keyFunc anObject source)
    (define (loop x)
	(if (null? (cdr x))
	    #f
	    (if (eq? (keyFunc (cadr x)) anObject)
		(begin1
		    (cadr x)
		    (set-cdr! x (cddr x)))
		(loop (cdr x)))))
    (loop source))
		
(define-method Scheduler (enqueue thread time)
    (let ((priority (thread-priority thread))
          (id (thread-identifier thread)))
	(define (insert x)
	    (if (null? (cdr x))
		(set! queue (append! queue (list (cons time thread))))
		(if (or (< (caadr x) time)
			(or (and (= (caadr x) time)
				 (> (thread-priority (cdadr x)) priority))
			    (and (= (caadr x) time)
				 (= (thread-priority (cdadr x)) priority)
				 (< (thread-identifier (cdadr x)) id))))
		    (insert (cdr x))
		    (set-cdr! x
			(append! (list (cons time thread)) (cdr x))))))
	(insert queue)))

(define-method Scheduler (dequeue thread)
    (let ((result (send self 'remove cdr thread queue)))
	(if result
	    (car result)
	    result)))

(define-method Scheduler (deactivate thread)
    (set! waiting (append! waiting (list thread))))

(define-method Scheduler (activate thread telay)
    (define (remove x)
	(if (null? (cdr x))
	    #f
	    (if (eq? (cadr x) thread)
		(begin1
		    (cadr x)
		    (set-cdr! x (cddr x)))
		(remove (cdr x)))))
    (let ((thread (remove waiting)))
	(if (not thread)
	    #f
	    (send self 'enqueue thread (+ time telay))
	    #t)))