問題3.31

;wireの実装上、信号が切り替わったときにしか登録したactionは実行されないため、
;もし、ある回路シミュレーターの入力値が変化しなかった場合、出力側が正しくない値だったとしても、actionが実行されず修正されないことが起こりうる。
;よって初めに、回路シミュレーターの入力と出力の値を対応しあった正しい状態に初期化する必要がある。
;(define (accept-action-procedure! proc) (set! action-procedures (cons proc action-procedures))) とした場合
;上記の理由から、inverterのactionが働かず、出力側が初期化されずに間違った値となるため、正しく計算が出来ずsumが変化しない。


(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)))