R6RS Enumerations を実装しテストが通った
R6RS Enumerations の仕様を読む。集合の話が出てきて少しばかり数学の香り。
相変わらず自分が理解できるかどうかのぎりぎりの線を攻めてくる＞ R6RS
仕様を眺めていたら、Pure Scheme で実装できそうなことに気づく。R6RS Records の Procedural layer を利用すれば良かろう。
Scheme で書くと楽。仕上がるのが速い。
テストも含めて貼っておく。まだバグがあるかも。
(define (symbol-append . symbols) (string->symbol (apply string-append (map symbol->string symbols)))) (define-macro (define-simple-struct name fields) (let ([rtd (symbol-append name '-rtd)] [rcd (symbol-append name '-rcd)] [accessors (map (lambda (field) (symbol-append name '- field)) fields)] [field-set (list->vector (map (lambda (field) (list 'mutable field)) fields))] [constructor (symbol-append 'make- name)]) `(begin (define ,rtd (make-record-type-descriptor ',name #f #f #f #f ',field-set)) (define ,rcd (make-record-constructor-descriptor ,rtd #f #f)) (define ,constructor (record-constructor ,rcd)) ,@(let loop ([i 0] [accessors accessors] [ret '()]) (if (null? accessors) ret (loop (+ i 1) (cdr accessors) (cons (list 'define (car accessors) (list 'record-accessor rtd i) ) ret)))) ))) (define-macro (t exp equal expected ) (let ([val (gensym)]) `(let ([,val ,exp]) (unless (equal? ,expected ,val) (error 'test (format "~a failed" ',exp) (list ,expected '=> ,val)))))) (define-simple-struct enum-set (type members)) (define-simple-struct enum-type (universe indexer)) (define (make-enumeration-type symbol-list) (let ([ht (make-eq-hashtable)]) (let loop ([symbol-list symbol-list] [i 0]) (if (null? symbol-list) '() (begin (hashtable-set! ht (car symbol-list) i) (loop (cdr symbol-list) (+ i 1))))) (make-enum-type symbol-list (lambda (symbol) (hashtable-ref ht symbol #f))))) (define (make-enumeration symbol-list) (make-enum-set (make-enumeration-type symbol-list) symbol-list)) (define (enum-set-universe enum-set) (make-enum-set (enum-set-type enum-set) (enum-type-universe (enum-set-type enum-set)))) (define (enum-set-indexer enum-set) (enum-type-indexer (enum-set-type enum-set))) (define (enum-set-constructor enum-set) (lambda (symbol-list) (let ([universe (enum-type-universe (enum-set-type enum-set))]) (if (for-all (lambda (x) (memq x universe)) symbol-list) (make-enum-set (enum-set-type enum-set) symbol-list) (assertion-violation 'enum-set-constructor "the symbol list must all belong to the universe." (list universe symbol-list)))))) (define (enum-set->list enum-set) (let ([universe (enum-type-universe (enum-set-type enum-set))] [members (enum-set-members enum-set)]) (let loop ([universe universe]) (cond [(null? universe) '()] [(memq (car universe) members) (cons (car universe) (loop (cdr universe)))] [else (loop (cdr universe))])))) (define (enum-set-member? symbol enum-set) (and (memq symbol (enum-set-members enum-set)) #t)) (define (enum-set-subset? enum-set1 enum-set2) (and (let ([enum-set2-univese (enum-set->list (enum-set-universe enum-set2))]) (for-all (lambda (symbol) (memq symbol enum-set2-univese)) (enum-set->list (enum-set-universe enum-set1)))) (for-all (lambda (symbol) (enum-set-member? symbol enum-set2)) (enum-set-members enum-set1)))) (define (enum-set=? enum-set1 enum-set2) (and (enum-set-subset? enum-set1 enum-set2) (enum-set-subset? enum-set2 enum-set1))) (define (enum-set-union enum-set1 enum-set2) (define (union lst1 lst2) (let loop ([ret lst1] [lst lst2]) (cond [(null? lst) ret] [(memq (car lst) ret) (loop ret (cdr lst))] [else (loop (cons (car lst) ret) (cdr lst))]))) (if (eq? (enum-set-type enum-set1) (enum-set-type enum-set2)) (make-enum-set (enum-set-type enum-set1) (union (enum-set-members enum-set1) (enum-set-members enum-set2))) (assertion-violation 'enum-set-union "enum-set1 and enum-set2 must be enumeration sets that have the same enumeration type."))) (define (enum-set-intersection enum-set1 enum-set2) (define (intersection lst1 lst2) (let loop ([ret '()] [lst lst1]) (if (null? lst) ret (cond [(memq (car lst) lst2) (loop (cons (car lst) ret) (cdr lst))] [else (loop ret (cdr lst))])))) (if (eq? (enum-set-type enum-set1) (enum-set-type enum-set2)) (make-enum-set (enum-set-type enum-set1) (intersection (enum-set-members enum-set1) (enum-set-members enum-set2))) (assertion-violation 'enum-set-intersection "enum-set1 and enum-set2 must be enumeration sets that have the same enumeration type."))) (define (enum-set-difference enum-set1 enum-set2) (define (difference lst1 lst2) (let loop ([ret '()] [lst lst1]) (if (null? lst) ret (cond [(memq (car lst) lst2) (loop ret (cdr lst))] [else (loop (cons (car lst) ret) (cdr lst))])))) (if (eq? (enum-set-type enum-set1) (enum-set-type enum-set2)) (make-enum-set (enum-set-type enum-set1) (difference (enum-set-members enum-set1) (enum-set-members enum-set2))) (assertion-violation 'enum-set-difference "enum-set1 and enum-set2 must be enumeration sets that have the same enumeration type."))) (define (enum-set-complement enum-set) (let ([members (enum-set-members enum-set)]) (make-enum-set (enum-set-type enum-set) (filter (lambda (symbol) (not (memq symbol members))) (enum-type-universe (enum-set-type enum-set)))))) (define (enum-set-projection enum-set1 enum-set2) (if (enum-set-subset? enum-set1 enum-set2) enum-set1 (let ([universe2 (enum-type-universe (enum-set-type enum-set2))] [members1 (enum-set-members enum-set1)]) (make-enum-set (enum-set-type enum-set2) (filter (lambda (symbol) (memq symbol universe2)) members1))))) (t (let* ((e (make-enumeration '(red green blue))) (i (enum-set-indexer e))) (list (i 'red) (i 'green) (i 'blue) (i 'yellow))) => '(0 1 2 #f)) (t (enum-set->list (make-enumeration '(red green blue))) => '(red green blue)) (t (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (enum-set->list (c '(blue red)))) => '(red blue)) (t (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (list (enum-set-member? 'blue (c '(red blue))) (enum-set-member? 'green (c '(red blue))) (enum-set-subset? (c '(red blue)) e) (enum-set-subset? (c '(red blue)) (c '(blue red))) (enum-set-subset? (c '(red blue)) (c '(red))) (enum-set=? (c '(red blue)) (c '(blue red))))) => '(#t #f #t #t #f #t)) (t (guard [c (#t 'error)] (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (c '(pink)))) => 'error) (let* ((e (make-enumeration '(red green blue))) (r ((enum-set-constructor e) '(red)))) (t (enum-set->list (enum-set-universe e)) => '(red green blue)) (t (enum-set->list (enum-set-universe r)) => '(red green blue)) (t ((enum-set-indexer ((enum-set-constructor e) '(red))) 'green) => 1) (t (enum-set-member? 'red e) => #t) (t (enum-set-member? 'black e) => #f) (t (enum-set-subset? e e) => #t) (t (enum-set-subset? r e) => #t) (t (enum-set-subset? e r) => #f) (t (enum-set-subset? e (make-enumeration '(blue green red))) => #t) (t (enum-set-subset? e (make-enumeration '(blue green red black))) => #t) (t (enum-set-subset? (make-enumeration '(blue green red black)) e) => #f) (t (enum-set-subset? ((enum-set-constructor (make-enumeration '(blue green red black))) '(red)) e) => #f) (t (enum-set-subset? ((enum-set-constructor (make-enumeration '(green red))) '(red)) e) => #t) (t (enum-set=? e e) => #t) (t (enum-set=? r e) => #f) (t (enum-set=? e r) => #f) (t (enum-set=? e (make-enumeration '(blue green red))) => #t) ) (t (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (list (enum-set-member? 'blue (c '(red blue))) (enum-set-member? 'green (c '(red blue))) (enum-set-subset? (c '(red blue)) e) (enum-set-subset? (c '(red blue)) (c '(blue red))) (enum-set-subset? (c '(red blue)) (c '(red))) (enum-set=? (c '(red blue)) (c '(blue red))))) => (list #t #f #t #t #f #t)) (t (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (enum-set->list (c '(blue red)))) => '(red blue)) (t (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (list (enum-set->list (enum-set-union (c '(blue)) (c '(red)))) (enum-set->list (enum-set-intersection (c '(red green)) (c '(red blue)))) (enum-set->list (enum-set-difference (c '(red green)) (c '(red blue)))))) => '((red blue) (red) (green))) (t (let* ((e (make-enumeration '(red green blue))) (c (enum-set-constructor e))) (enum-set->list (enum-set-complement (c '(red))))) => '(green blue)) (t (let ((e1 (make-enumeration '(red green blue black))) (e2 (make-enumeration '(red black white)))) (enum-set->list (enum-set-projection e1 e2))) => '(red black))
