CL-USER> (repl)
LISP>
(define (unless condition usual exceptional)
(if condition exceptional usual))
OK
LISP> (unless (= 1 0) 'hoge (/ 1 0))
HOGE
CL-USER> (repl)
LISP> (define (fibonacci n)
(if (<= n 1)
n
(+ (fibonacci (- n 2)) (fibonacci (- n 1)))))
make-lamba parameters: (N)
make-lamba body: ((IF (<= N 1)
N
(+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1)))))
lambda: (LAMBDA
((N) (IF (<= N 1) N (+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1))))))
lambda parameters: (N)
lambda body: ((IF (<= N 1)
N
(+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1)))))
OK
LISP> (fibonacci 10)
t-eval: (FIBONACCI 10)
t-eval: FIBONACCI
t-eval: 10
t-eval: (IF (<= N 1)
N
(+ (FIBONACCI (- N 2)) (FIBONACCI (- N 1))))
t-eval: (<= N 1)
t-eval: <=
t-eval: N
t-eval: 1
..snip..
6765
(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)))))
CL-USER> (stream-take (sieve (stream-integers-starting-from 2)) 10) (2 3 5 7 11 13 17 19 23 29)おおっ。素晴しい。
CL-USER> (stream-nth 999 (sieve (stream-integers-starting-from 2))) 7919
CL-USER> (stream-take (sieve (stream-integers-starting-from 2)) 9999) 帰ってこない...
fatal error encountered in SBCL pid 26815(tid 140737295218432): Heap exhausted, game over.
;; 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>
