fork(15) download
copy 
  1. ; aronson's sequence
  2.  
  3. (define (take-while pred? xs)
  4.   (let loop ((xs xs) (ys '()))
  5.     (if (or (null? xs) (not (pred? (car xs))))
  6.         (reverse ys)
  7.         (loop (cdr xs) (cons (car xs) ys)))))
  8.  
  9. (define (filter pred? xs)
  10.   (let loop ((xs xs) (ys '()))
  11.     (cond ((null? xs) (reverse ys))
  12.           ((pred? (car xs))
  13.             (loop (cdr xs) (cons (car xs) ys)))
  14.           (else (loop (cdr xs) ys)))))
  15.  
  16.  
  17. (define (cardinal n) ; a quadrillion is too much for anybody
  18.   (letrec ((ones '("" "one" "two" "three" "four" "five" "six"
  19.              "seven" "eight" "nine" "ten" "eleven" "twelve"
  20.              "thirteen" "fourteen" "fifteen" "sixteen"
  21.              "seventeen" "eighteen" "nineteen"))
  22.            (tens '("" "" "twenty" "thirty" "forty" "fifty"
  23.              "sixty" "seventy" "eighty" "ninety"))
  24.            (groups '("" "thousand" "million" "billion" "trillion"))
  25.            (nnn->words (lambda (n) ; three-digit numbers
  26.              (cond ((<= 100 n)
  27.                      (string-append
  28.                        (list-ref ones (quotient n 100))
  29.                        " hundred"
  30.                        (if (positive? (modulo n 100)) " " "")
  31.                        (nnn->words (modulo n 100))))
  32.                    ((<= 20 n)
  33.                      (string-append
  34.                        (list-ref tens (quotient n 10))
  35.                        (if (zero? (modulo n 10)) ""
  36.                          (string-append "-" (list-ref ones (modulo n 10))))))
  37.                    (else (list-ref ones n))))))
  38.     (cond ((negative? n) (string-append "negative " (cardinal (- n))))
  39.           ((<= 1000000000000000 n) (error 'cardinal "domain error"))
  40.           ((zero? n) "zero")
  41.           ((< n 1000) (nnn->words n))
  42.           (else (let loop ((n n) (groups groups))
  43.                   (let ((prev (quotient n 1000))
  44.                         (group (modulo n 1000)))
  45.                     (string-append
  46.                       (if (zero? prev) ""
  47.                         (loop prev (cdr groups)))
  48.                       (if (zero? group) ""
  49.                         (string-append
  50.                           (if (positive? prev) " " "")
  51.                           (nnn->words group)
  52.                           (if (string=? "" (car groups)) ""
  53.                             (string-append " " (car groups))))))))))))
  54.  
  55. (define (ordinal n)
  56.   (let* ((oddballs '(("one" . "first")
  57.             ("two" . "second") ("three" . "third")
  58.             ("five" . "fifth") ("eight" . "eighth")
  59.             ("nine" . "ninth") ("twelve" . "twelfth")))
  60.          (card-words (cardinal n))
  61.          (last-element (list->string (reverse (take-while
  62.            char-alphabetic? (reverse (string->list card-words))))))
  63.          (beginning (substring card-words 0
  64.            (- (string-length card-words) (string-length last-element)))))
  65.     (cond ((assoc last-element oddballs) =>
  66.             (lambda (x) (string-append beginning (cdr x))))
  67.           ((char=? #\y (string-ref last-element
  68.                    (- (string-length last-element) 1)))
  69.             (string-append beginning (substring last-element 0
  70.                 (- (string-length last-element) 1)) "ieth"))
  71.           (else (string-append card-words "th")))))
  72.  
  73. (define (aronson n) ; first n items of aronson's sequence
  74.   (let loop ((k 1) (n n) (result (list))
  75.              (front (string->list "tisthe")) (back (list)))
  76.     (cond ((zero? n) (reverse result)) ; return result
  77.           ((null? front) ; rearrange queue, reverse back to front
  78.             (loop k n result (reverse back) (list)))
  79.           ((char=? (car front) #\t) ; next item in sequence
  80.             (loop (+ k 1) (- n 1) (cons k result) (cdr front)
  81.               (append (filter char-alphabetic?
  82.                         (reverse (string->list (ordinal k))))
  83.                       back)))
  84.           (else ; keep searching for next item in sequence
  85.             (loop (+ k 1) n result (cdr front) back)))))
  86.  
  87. (display (aronson 75)) (newline)
Success #stdin #stdout 0.01s 8392KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(1 4 11 16 24 29 33 35 39 45 47 51 56 58 62 64 69 73 78 80 84 89 94 99 104 111 116 122 126 131 136 142 147 158 164 169 174 181 183 193 199 205 208 214 220 226 231 237 243 249 254 270 288 303 307 319 323 341 345 350 362 366 372 383 387 392 407 428 435 450 456 471 477 492 497)
https://ideone.com/jySD2l
language:
Scheme (chicken 4.13)
created:
2 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!