codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; uncle bob's bowling game kata (define-syntax list-match (syntax-rules () ((_ expr (pattern fender ... template) ...) (let ((obj expr)) (cond ((list-match-aux obj pattern fender ... (list template)) => car) ... (else (error 'list-match "pattern failure"))))))) (define-syntax list-match-aux (lambda (stx) (define (underscore? x) (and (identifier? x) (free-identifier=? x (syntax _)))) (syntax-case stx (quote quasiquote) ((_ obj pattern template) (syntax (list-match-aux obj pattern #t template))) ((_ obj () fender template) (syntax (and (null? obj) fender template))) ((_ obj underscore fender template) (underscore? (syntax underscore)) (syntax (and fender template))) ((_ obj var fender template) (identifier? (syntax var)) (syntax (let ((var obj)) (and fender template)))) ((_ obj (quote datum) fender template) (syntax (and (equal? obj (quote datum)) fender template))) ((_ obj (quasiquote datum) fender template) (syntax (and (equal? obj (quasiquote datum)) fender template))) ((_ obj (kar . kdr) fender template) (syntax (and (pair? obj) (let ((kar-obj (car obj)) (kdr-obj (cdr obj))) (list-match-aux kar-obj kar (list-match-aux kdr-obj kdr fender template)))))) ((_ obj const fender template) (syntax (and (equal? obj const) fender template)))))) (define (pins . xs) (list-match xs ((10 a b . x) (+ 10 a b (if (null? x) 0 (apply pins a b x)))) ((a b c . x) (= (+ a b) 10) (+ 10 c (if (null? x) 0 (apply pins c x)))) ((a b . x) (+ a b (if (null? x) 0 (apply pins x)))))) (display (pins 1 4 4 5 6 4 5 5 10 0 1 7 3 6 4 10 2 8 6))
Private
[
?
]
Run code
Submit