(sicp40)m3.29~m3.32

途中からファイルを2つに分割した。
useが一度読み込んだファイルを再度読みこまないことに気づかなかった。
しばらく、どうして変更が反映されないんだろうと考えてしまった。
(あと、面倒だったのでutil.queueを使いました＞＜）

(use lc-module); lc-module.scmにわけた。

(define a (make-wire))
(define b (make-wire))
(define c (make-wire))
(define d (make-wire))
(define e (make-wire))
(define s (make-wire))

(define (half-adder a b s c)
  (let ((d (make-wire)) (e (make-wire)))
    (or-gate a b d)
    (and-gate a b c)
    (inverter c e)
    (and-gate d e s)
    'ok))

(define (full-adder a b c-in sum c-out)
  (let ((s (make-wire))
        (c1 (make-wire))
        (c2 (make-wire)))
    (half-adder b c-in s c1)
    (half-adder a s sum c2)
    (or-gate c1 c2 c-out)
    'ok))

(define (inverter input output)
  (define (inverter-input)
    (let ((new-value (logical-not (get-signal input))))
      (after-delay inverter-delay
                   (lambda ()
                     (set-signal! output new-value)))))
    (add-action! input inverter-input)
    'ok)

(define (logical-not s)
  (cond ((= 0 s) 1)
        ((= 1 s) 0)
        (else (error "Invalid signal" s))))

(define (and-gate a1 a2 output)
  (define (and-action-procedure)
    (let ((new-value
           (logical-and (get-signal a1) (get-signal a2))))
      (after-delay and-gate-delay
                   (lambda ()
                     (set-signal! output new-value)))))
  (add-action! a1 and-action-procedure)
  (add-action! a2 and-action-procedure)
  'ok)

(define (logical-and x y)
  (if (and (= 1 x) (= 1 y)) 1 0))
;;m3.28
(define (logical-or x y)
  (if (or (= 1 x) (= 1 y)) 1 0))

(define (or-gate a1 a2 output)
  (define (or-action-procedure)
    (let ((new-value
           (logical-or (get-signal a1) (get-signal a2))))
      (after-delay or-gate-delay
                   (lambda ()
                     (set-signal! output new-value)))))
  ;(print "\n" "or-gate" (current-time the-agenda))
  (add-action! a1 or-action-procedure)
  (add-action! a2 or-action-procedure)
  'ok)

;;m3.29
(define (or-gate2 a1 a2 output)
  (let ((c1 (make-wire))
        (c2 (make-wire))
        (c3 (make-wire)))
    (inverter a1 c1)
    (inverter a2 c2)
    (and-gate c1 c2 c3)
    (inverter c3 output)
    'ok))
;;inverterの遅延*2倍遅くなる(たぶん）
;; or2 = and+(inv*2)
;; or = or
;; if or == and ;;delayについて
;; or2 - or = inv*2 > 0
;;（上のOr-gateより)


;;m3.30
(define (ripple-carry as bs ss c-out)
  (let ((c0 (make-wire)))
    (define (next-ripple a b c s)
      (if (null? a)
          (set-signal! c-out (get-signal c))
          (let ((cout (make-wire)))
            (full-adder (car a) (cdr b) c (car s) cout)
            (next-ripple (cdr a) (cdr b) cout (cdr s)))))
    (next-ripple as bs 0 s)))

;; delay = n * full-adder<c>
;;       = n * (half-adder<max c, s> + half-adder<c> + or-gate)
;; 	 = n * (((2 * and-gate) + inverter) + (and-gate) + or-gate)
;;       = n * ((3 * and-gate) + or-gate + inverter)


;;m3.31
(define (accept-action-procedure! proc)
  (set! action-procedures (cons proc action-procedures))
  proc) ;;このprocが必要な理由を説明する。

;; procがある場合は、queに追加＋procを実行という感じになる。
;; procが無い場合には、queに追加だけになる。（あとでまとめて実行するのかもしれない）
;; procをなくしてしまうとafter-delayとかが呼ばれない。
;; (シミュレーション結果が加算されない)
                                          

;;乱雑なものはlc-module.scmに退避
(define (run)
  (define input-1 (make-wire))
  (define input-2 (make-wire))
  (define sum (make-wire))
  (define carry (make-wire))
  (probe 'sum sum)
  (probe 'carry carry)
  (half-adder input-1 input-2 sum carry)
  (set-signal! input-1 1)
  (propagete)
  (set-signal! input-2 1)
  (propagete)
)

(run)
	;; sum 0 New-value = 0
	;; carry 0 New-value = 0
	;; sum 8 New-value = 1
	;; carry 11 New-value = 1
	;; sum 16 New-value = 0=> #t

;;m3.32
;; A->Bという回路があったとして、(add A), (add B)という順に格納していった場合、
;; FIFOなら（A,B）という順に取り出される。
;; LIFOなら（B,A）という順に取り出される。
;; このコードは取り出す度に評価して結果（delayとか）を加算していく。
;; なので、普通のリストをつかった場合、A->Bという回路がB->Aという回路に変わってしまう。
;;　ということで、queueが必要。

分けたもう一つのファイルの方

(define-module lc-module
  (export-all))
(select-module lc-module)

;;util.queとの対応
(use util.queue)
(define insert-queue! queue-push!)
(define front-queue queue-front)
(define empty-queue? queue-empty?)
(define delete-queue! dequeue!)


(define (make-agenda) (list 0))

(define (make-wire)
  (let ((signal-value 0)
        (action-procedures '()))
    (define (call-each procedures)
      (if (null? procedures)
          'done
          (begin
            ((car procedures))
            (call-each (cdr procedures)))))
    (define (set-my-signal! new-value)
      (if (not (= signal-value new-value))
          (begin
            (set! signal-value new-value)
            (call-each action-procedures))
          'done))

    (define (accept-action-procedure! proc)
      (set! action-procedures (cons proc action-procedures))
      (proc))

    (define (dispatch m)
      (cond ((eq? m 'get-signal) signal-value)
            ((eq? m 'set-signal!) set-my-signal!)
            ((eq? m 'add-action!) accept-action-procedure!)
            (else (error "Unknown operation -- WIRE" m))))
    dispatch))

(define (inverter input output)
  (define (invert-input)
    (let ((new-value (logical-not (get-signal input))))
      (after-delay the-agenda
                   inverter-delay
                   (lambda ()
                     (set-signal! output new-value)))))
  (add-action! input invert-input)
  'ok)

(define (logical-not s)
  (cond ((= 0 s) 1)
        ((= 1 s) 0)
        (else (error "Invalid signal" s))))


(define (half-adder a b s c)
  (let ((d (make-wire)) (e (make-wire)))
    (or-gate a b d)
    (and-gate a b c)
    (inverter c e)
    (and-gate d e s)
    'ok))

(define (full-adder a b c-in sum c-out)
  (let ((s (make-wire))
        (c1 (make-wire))
        (c2 (make-wire)))
    (half-adder b c-in s c1)
    (half-adder a s sum c2)
    (or-gate c1 c2 c-out)
    'ok))

(define (logical-and x y)
  (if (and (= 1 x) (= 1 y)) 1 0))

(define (logical-or x y)
  (if (or (= 1 x) (= 1 y)) 1 0))


(define (and-gate a1 a2 output)
  (define (and-action-procedure)
    (let ((new-value (logical-and (get-signal a1) (get-signal a2))))
      (after-delay the-agenda
                   and-gate-delay
                   (lambda ()
                     (set-signal! output new-value)))))
  (add-action! a1 and-action-procedure)
  (add-action! a2 and-action-procedure)
  'ok)

(define (or-gate o1 o2 output)
  (define (or-action-procedure)
    (let ((new-value (logical-or (get-signal o1) (get-signal o2))))
      (after-delay the-agenda
                   or-gate-delay
                   (lambda ()
                     (set-signal! output new-value)))))
  (add-action! o1 or-action-procedure)
  (add-action! o2 or-action-procedure)
  'ok)

(define (call-each procedures)
  (for-each (cut <>) procedures)
  'done)

(define (get-signal w)  (w 'get-signal))
(define (set-signal! w value) ((w 'set-signal!) value))
(define (add-action! w p) ((w 'add-action!) p))

(define (after-delay delay action)
  (add-to-agenda! (+ delay (current-time the-agenda))
                  action
                  the-agenda)
;  (print (+ delay (current-time the-agenda))))
)

(define (propagete)
  (if (empty-agenda? the-agenda)
      'done
      (let ((first-item (first-agenda-item the-agenda)))
        (first-item)
        (remove-first-agenda-item! the-agenda)
        (propagete))))

(define the-agenda (make-agenda))
(define inverter-delay 2)
(define and-gate-delay 3)
(define or-gate-delay 5)

(define (probe name wire)
  (add-action! wire
               (lambda ()
                 (newline)
                 (display name)
                 (display " ")
                 (display (current-time the-agenda))
                 (display " New-value = ")
                 (display (get-signal wire)))))


(define (make-time-segment time queue)
  (cons time queue))

(define (segment-time s) (car s))

(define (segment-queue s) (cdr s))

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