(define (make-time-segment time queue) (cons time queue))
(define (segment-time s) (car s))
(define (segment-queue s) (cdr s))
(define (make-agenda) (list 0))
(define (current-time agenda) (car agenda))
(define (set-current-time! agenda time) (set-car! agenda time))
(define (segments agenda) (cdr agenda))
(define (set-segments! agenda segments) (set-cdr! agenda segments))
(define (first-segment agenda) (car (segments agenda)))
(define (rest-segments agenda) (cdr (segments agenda)))
(define (empty-agenda? agenda)
(null? (segments agenda)))
(define (add-to-agenda! time action agenda)
(define (belongs-before? segments)
(or (null? segments)
(< time (segment-time (car segments)))))
(define (make-new-time-segment time action)
(let ((q (make-queue)))
(insert-queue! q action)
(make-time-segment time q)))
(define (add-to-segments! segments)
(if (= (segment-time (car segments)) time)
(insert-queue! (segment-queue (car segments))
action)
(let ((rest (cdr segments)))
(if (belongs-before? rest)
(set-cdr!
segments
(cons (make-new-time-segment time action)
(cdr segments)))
(add-to-segments! rest)))))
(let ((segments (segments agenda)))
(if (belongs-before? segments)
(set-segments!
agenda
(cons (make-new-time-segment time action)
segments))
(add-to-segments! segments))))
(define (remove-first-agenda-item! agenda)
(let ((q (segment-queue (first-segment agenda))))
(delete-queue! q)
(if (empty-queue? q)
(set-segments! agenda (rest-segments agenda)))))
(define (first-agenda-item agenda)
(if (empty-agenda? agenda)
(error "Agenda is empty -- FIRST-AGENDA-ITEM")
(let ((first-seg (first-segment agenda)))
(set-current-time! agenda (segment-time first-seg))
(front-queue (segment-queue first-seg)))))
(define (make-queue)
(let ((front-ptr '())
(rear-ptr '()))
(define (empty?) (null? front-ptr))
(define (set-front-ptr! item) (set! front-ptr item))
(define (set-rear-ptr! item) (set! rear-ptr item))
(define (insert! item)
(let ((new-pair (cons item '())))
(if (empty?)
(begin (set-front-ptr! new-pair)
(set-rear-ptr! new-pair)
#f)
(begin (set-cdr! rear-ptr new-pair)
(set-rear-ptr! new-pair)
#f))))
(define (delete!)
(if (empty?)
(error "DELETE! called with an empty queue.")
(begin (set-front-ptr! (cdr front-ptr))
#f)))
(define (front)
(if (empty?)
(error "FRONT called with an empty queue")
(car front-ptr)))
(define (print-queue)
(print front-ptr))
(define (dispatch m)
(cond ((eq? m 'insert!) insert!)
((eq? m 'delete!) delete!)
((eq? m 'front) front)
((eq? m 'empty?) empty?)
((eq? m 'print) print-queue)
(else (error "Undefined operation -- " m))))
dispatch))
(define (insert-queue! queue item)
((queue 'insert!) item))
(define (delete-queue! queue)
((queue 'delete!)))
(define (empty-queue? queue)
((queue 'empty?)))
(define (front-queue queue)
((queue 'front)))