[ create a new paste ] login | about

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

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


Output:
1
Timeout


Create a new paste based on this one


Comments: