[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Feb 24:
; look and say

(define (iterate n f . bs)
  (let loop ((n n) (b (car bs)) (bs (cdr bs)) (xs '()))
    (if (zero? n) (reverse xs)
      (let ((new-bs (append bs (list (apply f b bs)))))
        (loop (- n 1) (car new-bs) (cdr new-bs) (cons b xs))))))

(define (flatten xs)
  (cond ((null? xs) xs)
        ((pair? xs)
          (append (flatten (car xs))
                  (flatten (cdr xs))))
        (else (list xs))))

(define (uniq-c eql? xs)
  (if (null? xs) xs
    (let loop ((xs (cdr xs)) (prev (car xs)) (k 1) (result '()))
      (cond ((null? xs) (reverse (cons (cons prev k) result)))
            ((eql? (car xs) prev) (loop (cdr xs) prev (+ k 1) result))
            (else (loop (cdr xs) (car xs) 1 (cons (cons prev k) result)))))))

(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 (look-and-say n)
  (define (flip x) (cons (cdr x) (car x)))
  (undigits (flatten (map flip (uniq-c = (digits n))))))

(define (look-and-say-sequence n)
  (iterate n look-and-say 1))

(display (look-and-say-sequence 10))


Output:
1
(1 11 21 1211 111221 312211 13112221 1113213211 31131211131221 13211311123113112211)


Create a new paste based on this one


Comments: