codepad

Language:

; generating palindromes

(define (digits n . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((n n) (d '()))
      (if (zero? n) d
          (loop (quotient n b)
                (cons (modulo n b) d))))))

(define (undigits ds . args)
  (let ((b (if (null? args) 10 (car args))))
    (let loop ((ds ds) (n 0))
      (if (null? ds) n
          (loop (cdr ds) (+ (* n b) (car ds)))))))

(define-syntax define-generator
  (lambda (x)
    (syntax-case x (lambda)
      ((stx name (lambda formals e0 e1 ...))
         (with-syntax ((yield (datum->syntax-object (syntax stx) 'yield)))
           (syntax (define name
             (lambda formals
               (let ((resume #f) (return #f))
                 (define yield
                   (lambda args
                     (call-with-current-continuation
                      (lambda (cont)
                        (set! resume cont)
                        (apply return args)))))
                 (lambda ()
                   (call-with-current-continuation
                    (lambda (cont)
                      (set! return cont)
                      (cond (resume (resume))
                      (else (let () e0 e1 ...)
                            (error 'name "unexpected return"))))))))))))
        ((stx (name . formals) e0 e1 ...)
          (syntax (stx name (lambda formals e0 e1 ...)))))))

(define-generator (palindromes)
  (do ((k 0 (+ k 1))) ((= k 10))
    (yield k))
  (do ((i 1 (* i 10))) (#f)
    (do ((j i (+ j 1))) ((= j (* 10 i)))
      (let ((ds (digits j)))
        (yield (undigits (append ds (reverse ds))))))
    (do ((j i (+ j 1))) ((= j (* 10 i)))
      (let ((ds (digits j)))
        (do ((k 0 (+ k 1))) ((= k 10))
          (yield (undigits (append ds (list k) (reverse ds)))))))))

(define (nth-palindrome n)
  (let ((p (palindromes)))
    (do ((n n (- n 1))) ((= n 1) (p)) (p))))

(let ((p (palindromes)))
  (do ((n 100 (- n 1))) ((zero? n) (newline))
    (display (p)) (newline)))

(display (nth-palindrome 100)) (newline)
(display (nth-palindrome 10000)) (newline)

Private [?]

Run code