; carl hewitt's same-fringe problem
(define-syntax define-record-type
(syntax-rules ()
((define-record-type type
(constructor constructor-tag ...)
predicate
(field-tag accessor . more) ...)
(begin
(define type
(make-record-type 'type '(field-tag ...)))
(define constructor
(record-constructor type '(constructor-tag ...)))
(define predicate
(record-predicate type))
(define-record-field type field-tag accessor . more)
...))))
(define-syntax define-record-field
(syntax-rules ()
((define-record-field type field-tag accessor)
(define accessor (record-accessor type 'field-tag)))
((define-record-field type field-tag accessor modifier)
(begin
(define accessor (record-accessor type 'field-tag))
(define modifier (record-modifier type 'field-tag))))))
(define record-marker (list 'record-marker))
(define real-vector? vector?)
(define (vector? x)
(and (real-vector? x)
(or (= 0 (vector-length x))
(not (eq? (vector-ref x 0)
record-marker)))))
(define eval
(let ((real-eval eval))
(lambda (exp env)
((real-eval `(lambda (vector?) ,exp))
vector?))))
(define (record? x)
(and (real-vector? x)
(< 0 (vector-length x))
(eq? (vector-ref x 0)
record-marker)))
(define (make-record size)
(let ((new (make-vector (+ size 1))))
(vector-set! new 0 record-marker)
new))
(define (record-ref record index)
(vector-ref record (+ index 1)))
(define (record-set! record index value)
(vector-set! record (+ index 1) value))
(define (record-type record)
(record-ref record 0))
(define :record-type (make-record 3))
(record-set! :record-type 0 :record-type)
(record-set! :record-type 1 ':record-type)
(record-set! :record-type 2 '(name field-tags))
(define (make-record-type name field-tags)
(let ((new (make-record 3)))
(record-set! new 0 :record-type)
(record-set! new 1 name)
(record-set! new 2 field-tags)
new))
(define (record-type-name record-type)
(record-ref record-type 1))
(define (record-type-field-tags record-type)
(record-ref record-type 2))
(define (field-index type tag)
(let loop ((i 1) (tags (record-type-field-tags type)))
(cond ((null? tags)
(error 'field-index "record type has no such field" type tag))
((eq? tag (car tags))
i)
(else
(loop (+ i 1) (cdr tags))))))
(define (record-constructor type tags)
(let ((size (length (record-type-field-tags type)))
(arg-count (length tags))
(indexes (map (lambda (tag)
(field-index type tag))
tags)))
(lambda args
(if (= (length args)
arg-count)
(let ((new (make-record (+ size 1))))
(record-set! new 0 type)
(for-each (lambda (arg i)
(record-set! new i arg))
args
indexes)
new)
(error 'record-constructor "wrong number of arguments to constructor" type args)))))
(define (record-predicate type)
(lambda (thing)
(and (record? thing)
(eq? (record-type thing)
type))))
(define (record-accessor type tag)
(let ((index (field-index type tag)))
(lambda (thing)
(if (and (record? thing)
(eq? (record-type thing)
type))
(record-ref thing index)
(error 'record-accessor "accessor applied to bad value" type tag thing)))))
(define (record-modifier type tag)
(let ((index (field-index type tag)))
(lambda (thing value)
(if (and (record? thing)
(eq? (record-type thing)
type))
(record-set! thing index value)
(error 'record-modifier "modifier applied to bad value" type tag thing)))))
(define-record-type stream-type
(make-stream box)
stream?
(box stream-promise stream-promise!))
(define-syntax stream-lazy
(syntax-rules ()
((stream-lazy expr)
(make-stream
(cons 'lazy (lambda () expr))))))
(define (stream-eager expr)
(make-stream
(cons 'eager expr)))
(define-syntax stream-delay
(syntax-rules ()
((stream-delay expr)
(stream-lazy (stream-eager expr)))))
(define (stream-force promise)
(let ((content (stream-promise promise)))
(case (car content)
((eager) (cdr content))
((lazy) (let* ((promise* ((cdr content)))
(content (stream-promise promise)))
(if (not (eqv? (car content) 'eager))
(begin (set-car! content (car (stream-promise promise*)))
(set-cdr! content (cdr (stream-promise promise*)))
(stream-promise! promise* content)))
(stream-force promise))))))
(define stream-null (stream-delay (cons 'stream 'null)))
(define-record-type stream-pare-type
(make-stream-pare kar kdr)
stream-pare?
(kar stream-kar)
(kdr stream-kdr))
(define (stream-pair? obj)
(and (stream? obj) (stream-pare? (stream-force obj))))
(define (stream-null? obj)
(and (stream? obj)
(eqv? (stream-force obj)
(stream-force stream-null))))
(define-syntax stream-cons
(syntax-rules ()
((stream-cons obj strm)
(stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
(define (stream-car strm)
(cond ((not (stream? strm)) (error 'stream-car "non-stream"))
((stream-null? strm) (error 'stream-car "null stream"))
(else (stream-force (stream-kar (stream-force strm))))))
(define (stream-cdr strm)
(cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
((stream-null? strm) (error 'stream-cdr "null stream"))
(else (stream-kdr (stream-force strm)))))
(define-syntax stream-lambda
(syntax-rules ()
((stream-lambda formals body0 body1 ...)
(lambda formals (stream-lazy (let () body0 body1 ...))))))
(define (exists pred? xs)
(cond ((null? xs) #f)
((pred? (car xs)) #t)
(else (exists pred? (cdr xs)))))
(define (stream-append . strms)
(define stream-append
(stream-lambda (strms)
(cond ((null? (cdr strms)) (car strms))
((stream-null? (car strms)) (stream-append (cdr strms)))
(else (stream-cons (stream-car (car strms))
(stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
(cond ((null? strms) stream-null)
((exists (lambda (x) (not (stream? x))) strms)
(error 'stream-append "non-stream argument"))
(else (stream-append strms))))
(define-syntax define-stream
(syntax-rules ()
((define-stream (name . formal) body0 body1 ...)
(define name (stream-lambda formal body0 body1 ...)))))
(define (stream-equal? eql? xs ys)
(cond ((and (stream-null? xs)
(stream-null? ys)) #t)
((or (stream-null? xs)
(stream-null? ys)) #f)
((not (eql? (stream-car xs)
(stream-car ys))) #f)
(else (stream-equal? eql?
(stream-cdr xs)
(stream-cdr ys)))))
(define-stream (flatten tree)
(cond ((null? tree) stream-null)
((pair? (car tree))
(stream-append
(flatten (car tree))
(flatten (cdr tree))))
(else (stream-cons
(car tree)
(flatten (cdr tree))))))
(define (same-fringe? eql? tree1 tree2)
(stream-equal? = (flatten tree1) (flatten tree2)))
(display (same-fringe? = '(1 (2 3)) '((1 2) 3)))