[SICP][Lisp]ストリーム

SICP 3.5 ストリーム Common Lisp で実装したので、コードを貼っておこう。

遅延ストリーム・無限ストリームを使って、エラトステネスのふるいを作成し、素数を求めた。

(defmacro stream-cons (a b)
  `(cons ,a
  (delay ,b)))

(defun stream-car (s)
  (car s))

(defun stream-cdr (s)
  (force (cdr s)))

(defmacro delay (func)
  `#'(lambda () ,func))

(defun force (delay-obj)
  (funcall delay-obj))

(defvar +stream-empty+ (delay nil))

(defun stream-null? (s)
  (eq s +stream-empty+))

(defun stream-enumerate-interval (a b)
  (format t "[~a]~%" a b)
  (if (= a b)
      +stream-empty+
      (stream-cons a
     (stream-enumerate-interval (1+ a) b))))

(defun stream-each (func s)
  (unless (stream-null? s)
    (funcall func (stream-car s))
    (stream-each func (stream-cdr s))))

(defun stream-cadr (s)
  (stream-car (stream-cdr s)))

(defun stream-caddr (s)
  (stream-car (stream-cdr (stream-cdr s))))

(defun stream-nth (n s)
  (if (= n 0)
      (stream-car s)
      (stream-nth (1- n) (stream-cdr s))))

(defun stream-integers-starting-from (n)
  (stream-cons n
        (stream-integers-starting-from (1+ n))))

(defun stream-map (func &rest ss)
  (if (null (car ss))
      +stream-empty+
      (stream-cons
       (apply func (mapcar #'car ss))
       (apply #'stream-map (cons func (mapcar #'stream-cdr ss))))))

(defun stream-filter (pred s)
  (if (stream-null? s)
      +stream-empty+
      (if (funcall pred (car s))
   (stream-cons (car s)
         (stream-filter pred (stream-cdr s)))
   (stream-filter pred (stream-cdr s)))))

(defun stream-take (s n)
  (labels ((iter (s ts n)
      (if (= n 0)
   (reverse ts)
   (iter (stream-cdr s)
         (cons (stream-car s) ts)
         (1- n)))))
    (iter s '() n)))

(defun divisible? (x y)
  (= (mod x y) 0))

(defun sieve (stream)
  (stream-cons
   (stream-car stream)
   (sieve
    (stream-filter
     #'(lambda (x) (not (divisible? x (stream-car stream))))
     (stream-cdr stream)))))

sieve関数に2から始まる整数の無限ストリームを渡すと、最初の要素の値2と、2で割れる数を除外した無限ストリームを引数とするsieve関数の結果をconsしたものとなり、素数を表す無限ストリームが得られる。

実行例

最初の10個の素数を取得する。

CL-USER> (stream-take (sieve (stream-integers-starting-from 2)) 10) 
(2 3 5 7 11 13 17 19 23 29)

おおっ。素晴しい。

1000個目の素数を取得する。

CL-USER> (stream-nth 999 (sieve (stream-integers-starting-from 2)))
7919

楽しいねー。

 

10000個目の素数を取得する。

CL-USER> (stream-take (sieve (stream-integers-starting-from 2)) 9999) 
帰ってこない...

と思ったら、SBCL(swankサーバー側)でエラーとなっていて、 ヒープを使い尽していた。

fatal error encountered in SBCL pid 26815(tid 140737295218432):
Heap exhausted, game over.

ゲームオーバー...

[SICP][Lisp]デジタル回路のシミュレータ

SCIP 3.3.4 ディジタル回路のシミュレータ をCommon Lisp で書いみたので、貼っておこう。
インバータしか作っていないけど、こういうの作っていて楽しいね。

;; SICP Circuit simulator

;;----------------------------------------
;; queue

(defun make-queue ()
  (cons '() '()))

(defun front-ptr (queue)
  (car queue))

(defun rear-ptr (queue)
  (cdr queue))

(defun set-front-ptr! (queue item)
  (rplaca queue item))

(defun set-rear-ptr! (queue item)
  (rplacd queue item))

(defun empty-queue? (queue)
  (null (front-ptr queue)))

(defun front-queue (queue)
  (if (empty-queue? queue)
      (error "FRONT called with an empty queue ~a" queue)
      (car (front-ptr queue))))

(defun insert-queue! (queue item)
  (let ((new-pair (cons item '())))
    (cond
      ((empty-queue? queue)
       (set-front-ptr! queue new-pair)
       (set-rear-ptr! queue new-pair)
       queue)
      (t
       (rplacd (rear-ptr queue) new-pair)
       (set-rear-ptr! queue new-pair)
       queue))))

(defun delete-queue! (queue)
  (cond
    ((empty-queue? queue)
     (error "DELETE! called with an empty queue ~a" queue))
    (t
     (set-front-ptr! queue (cdr (front-ptr queue)))
     queue)))

;;----------------------------------------
;; time segment

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

(defun segment-time (segment)
  (car segment))

(defun segment-queue (segment)
  (cdr segment))

;;----------------------------------------
;; agenda

(defun make-agenda ()
  (list 0))

(defun current-time (agenda)
  (car agenda))

(defun set-current-time! (agenda time)
  (rplaca agenda time))

(defun segments (agenda)
  (cdr agenda))

(defun set-segments! (agenda segments)
  (rplacd agenda segments))

(defun first-segment (agenda)
  (car (segments agenda)))

(defun rest-segment (agenda)
  (cdr (segments agenda)))

(defun empty-agenda? (agenda)
  (null (segments agenda)))

(defun add-to-agenda! (time action agenda)
  (labels
      ((belongs-before? (segments)
  (or (null segments)
      (< time (segment-time (car segments)))))
       (make-new-time-segment (time action)
  (let ((queue (make-queue)))
    (insert-queue! queue action)
    (make-time-segment time queue)))
       (add-to-segments! (segments)
  (if (= time (segment-time (car segments)))
      (insert-queue! (segment-queue (car segments))
       action)
      (let ((rest (cdr segments)))
        (if (belongs-before? rest)
     (rplacd segments
      (cons (make-new-time-segment time action) rest))
     (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)))))

(defun remove-first-agenda-item! (agenda)
  (let ((q (segment-queue (first-segment agenda))))
    (delete-queue! q)
    (if (empty-queue? q)
 (set-segments! agenda (rest-segment agenda)))))

(defun first-agenda-item (agenda)
  (if (empty-agenda? agenda)
      (error "Agenda is empty -- FIRST-AGENDA-ITEM")
      (let ((segment (first-segment agenda)))
 (set-current-time! agenda (segment-time segment))
 (front-queue (segment-queue segment)))))

;;----------------------------------------
;; simulator

(defvar *agenda* nil)

(setf *agenda* (make-agenda))

(defun after-delay (delay action)
  (add-to-agenda! (+ delay (current-time *agenda*)) action *agenda*))

(defun propagate ()
  (if (empty-agenda? *agenda*)
      'done
      (let ((first-item (first-agenda-item *agenda*)))
 (funcall first-item)
 (remove-first-agenda-item! *agenda*)
 (propagate))))

(defun call-each (procs)
  (if (null procs)
      'done
      (progn
 (funcall (car procs))
 (call-each (cdr procs)))))

(defun make-wire ()
  (let ((signal-value 0)
 (action-procs '()))
    (labels ((set-signal! (value)
        (if (= value signal-value)
     'done
     (progn
       (setf signal-value value)
       (call-each action-procs))))
      (add-action! (proc)
        (setf action-procs (cons proc action-procs))
        (funcall proc))
      (dispatch (method)
        (case method
   ('get-signal signal-value)
   ('set-signal! #'set-signal!)
   ('add-action! #'add-action!)
   (t (error "Unknown operation ~a -- WIRE" method)))))
      #'dispatch)))

(defun get-signal (wire)
  (funcall wire 'get-signal))

(defun set-signal! (wire value)
  (funcall (funcall wire 'set-signal!) value))

(defun add-action! (wire proc)
  (funcall (funcall wire 'add-action!) proc))

(defun logical-not (value)
  (cond
    ((= value 0) 1)
    ((= value 1) 0)
    (t (error "Invalid signal ~a" value))))

(defvar *inverter-delay* 2)

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

(defun probe (name wire)
  (add-action! wire
        #'(lambda ()
     (format t "~a ~a ~a~%"
      (current-time *agenda*)
      name
      (get-signal wire)))))

;;----------------------------------------
;; circuit

(defparameter w1 (make-wire))
(defparameter w2 (make-wire))

(inverter w1 w2)
(probe "w1" w1)
(probe "w2" w2)

動かしてみる。

0 w1 0
0 w2 0
CL-USER> (propagate)
2 w2 1
DONE
CL-USER> (set-signal! w1 1)
2 w1 1
DONE
CL-USER> (propagate)
4 w2 0
DONE
CL-USER>

もう少しいろいろ遊びたいところだけど、先に進もう。