; happy new year
(define (mappend f . xss) (apply append (apply map f xss)))
(define (catenate ss) (apply string (mappend string->list ss)))
(define (numb xs)
(let loop ((n (- (char->integer (car xs)) 48)) (xs (cdr xs)))
(cond ((null? xs) (values n xs))
((member (car xs) (string->list "0123456789"))
(loop (+ (* 10 n) (- (char->integer (car xs)) 48)) (cdr xs)))
(else (values n xs)))))
(define (fact xs)
(cond ((null? xs) (error 'fact "missing factor"))
((char=? (car xs) #\space) (fact (cdr xs)))
((member (car xs) (string->list "0123456789"))
(let-values (((n rest) (numb xs)))
(values n rest)))
((char=? (car xs) #\()
(let-values (((n rest) (expr (cdr xs))))
(if (or (null? rest) (not (char=? (car rest) #\))))
(error 'fact "missing right parenthesis")
(values n (cdr rest)))))
(else (error 'fact "expected number or left parenthesis"))))
(define (term xs)
(let-values (((f rest) (fact xs)))
(let loop ((n f) (xs rest))
(cond ((null? xs) (values n xs))
((char=? (car xs) #\space)
(loop n (cdr xs)))
((char=? (car xs) #\*)
(let-values (((f rest) (fact (cdr xs))))
(loop (* n f) rest)))
((char=? (car xs) #\/)
(let-values (((f rest) (fact (cdr xs))))
(loop (/ n f) rest)))
(else (values n xs))))))
(define (expr xs)
(let-values (((t rest) (term xs)))
(let loop ((n t) (xs rest))
(cond ((null? xs) (values n xs))
((char=? (car xs) #\space)
(loop n (cdr xs)))
((char=? (car xs) #\+)
(let-values (((t rest) (term (cdr xs))))
(loop (+ n t) rest)))
((char=? (car xs) #\-)
(let-values (((t rest) (term (cdr xs))))
(loop (- n t) rest)))
(else (values n xs))))))
(define (evaluate str)
(let-values (((x xs) (expr (string->list str))))
(if (null? xs) x
(error 'evaluate "extra characters at end"))))
(define nums (list "10" "9" "8" "7" "6" "5" "4" "3" "2" "1"))
(define ops (list "" "+" "-" "*" "/"))
(define (tuples xs n)
(let loop ((n (- n 1)) (zs (map list xs)))
(if (zero? n) zs
(loop (- n 1)
(mappend (lambda (z)
(map (lambda (x) (cons x z)) xs))
zs)))))
(define (riffle xs ys)
(let loop ((xs xs) (ys ys) (zs (list)))
(if (null? xs)
(reverse (append (reverse ys) zs))
(loop ys (cdr xs) (cons (car xs) zs)))))
(define (happy-new-year n)
(let loop ((xs (tuples ops 9)) (zs (list)))
(if (null? xs) zs
(let ((expr (catenate (riffle nums (car xs)))))
(loop (cdr xs) (if (= (evaluate expr) n) (cons expr zs) zs))))))
(for-each
(lambda (x) (display x) (newline))
(happy-new-year 2013))