codepad

Language:

; the next palindrome

(define (take n xs)
  (let loop ((n n) (xs xs) (ys '()))
    (if (or (zero? n) (null? xs))
        (reverse ys)
        (loop (- n 1) (cdr xs)
              (cons (car xs) ys)))))

(define (drop n xs)
  (let loop ((n n) (xs xs))
    (if (or (zero? n) (null? xs)) xs
      (loop (- n 1) (cdr xs)))))

(define-syntax fold-of
  (syntax-rules (range in is)
    ((_ "z" f b e) (set! b (f b e)))
    ((_ "z" f b e (v range fst pst stp) c ...)
      (let* ((x fst) (p pst) (s stp)
             (le? (if (positive? s) <= >=)))
        (do ((v x (+ v s))) ((le? p v) b)
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (v range fst pst) c ...)
      (let* ((x fst) (p pst) (s (if (< x p) 1 -1)))
        (fold-of "z" f b e (v range x p s) c ...)))
    ((_ "z" f b e (v range pst) c ...)
      (fold-of "z" f b e (v range 0 pst) c ...))
    ((_ "z" f b e (x in xs) c ...)
      (do ((t xs (cdr t))) ((null? t) b)
        (let ((x (car t)))
          (fold-of "z" f b e c ...))))
    ((_ "z" f b e (x is y) c ...)
      (let ((x y)) (fold-of "z" f b e c ...)))
    ((_ "z" f b e p? c ...)
      (if p? (fold-of "z" f b e c ...)))
    ((_ f i e c ...)
      (let ((b i)) (fold-of "z" f b e c ...)))))

(define-syntax list-of (syntax-rules ()
  ((_ arg ...) (reverse (fold-of
    (lambda (d a) (cons a d)) '() arg ...)))))

(define (all-nines? ds)
  (cond ((null? ds) #t)
        ((not (char=? (car ds) #\9)) #f)
        (else (all-nines? (cdr ds)))))

(define (lt? a b)
  (cond ((< (length a) (length b)) #t)
        ((< (length b) (length a)) #f)
        (else (let loop ((a a) (b b))
                (cond ((null? a) #f)
                      ((char<? (car a) (car b)) #t)
                      ((char<? (car b) (car a)) #f)
                      (else (loop (cdr a) (cdr b))))))))

(define (plus1 ds)
  (let loop ((ds (reverse ds)) (carry 0) (xs '()))
    (cond ((null? ds)
            (if (zero? carry)
                (reverse xs)
                (cons #\1 (reverse xs))))
          ((char=? (car ds) #\9)
            (loop (cdr ds) 1 (cons #\0 xs)))
          (else (append (reverse (cdr ds))
                        (list (integer->char
                                (+ (char->integer (car ds)) 1)))
                        (reverse xs))))))

(define (palin n)
  (let* ((ds (string->list n)) (len (length ds)) (len2 (quotient len 2)))
    (cond ((equal? ds (list #\9)) "11")
          ((= len 1) (list->string (plus1 ds)))
          ((all-nines? ds)
            (let loop ((ds ds) (ps (list #\1)))
              (if (null? ds)
                  (list->string (cons #\1 (cdr ps)))
                  (loop (cdr ds) (cons #\0 ps)))))
          ((even? len)
            (let* ((left (take len2 ds)) (right (drop len2 ds)))
              (if (lt? right (reverse left))
                  (list->string (append left (reverse left)))
                  (let ((x (plus1 left)))
                    (list->string (append x (reverse x)))))))
          (else (let* ((left (take len2 ds))
                       (middle (car (drop len2 ds)))
                       (right (cdr (drop len2 ds))))
                  (if (lt? right (reverse left))
                      (list->string (append left (list middle) (reverse left)))
                      (if (char=? middle #\9)
                          (let ((x (plus1 left)))
                            (list->string (append x (list #\0) (reverse x))))
                          (list->string (append left (plus1 (list middle)) (reverse left))))))))))

(display (equal?
  (list-of (list->string x)
    (n range 1 1000002)
    (x is (string->list (number->string n)))
    (equal? x (reverse x)))
  (let loop ((p "0") (ps '()))
    (if (< 6 (string-length p)) (reverse ps)
      (let ((x (palin p)))
        (loop x (cons x ps)))))))

(newline)

(display (map palin '("0" "88" "808" "1999" "2133" "9999" "99999")))

Private [?]

Run code