codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; 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)))
Private
[
?
]
Run code
Submit