[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/oissVw14    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Aug 7:
; 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))


Output:
1
133


Create a new paste based on this one


Comments: