fork download
copy 
  1. ; what comes next
  2.  
  3. (define (range . args)
  4.   (case (length args)
  5.     ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
  6.     ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
  7.     ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
  8.            (let loop ((x(car args)) (xs '()))
  9.              (if (le? (cadr args) x)
  10.                  (reverse xs)
  11.                  (loop (+ x (caddr args)) (cons x xs))))))
  12.     (else (error 'range "unrecognized arguments"))))
  13.  
  14. (define (filter pred? xs)
  15.   (let loop ((xs xs) (ys '()))
  16.     (cond ((null? xs) (reverse ys))
  17.           ((pred? (car xs))
  18.             (loop (cdr xs) (cons (car xs) ys)))
  19.           (else (loop (cdr xs) ys)))))
  20.  
  21. (define (roman->number roman)
  22.   (let ((romans '((#\M 1000) (#\D 500) (#\C 100) (#\L 50) (#\X 10) (#\V 5) (#\I 1))))
  23.     (let loop ((roman (map char-upcase (string->list roman))) (prior 10000) (number 0))
  24.       (cond ((null? roman) number)
  25.             ((< prior (cadr (assoc (car roman) romans)))
  26.               (loop (cdr roman)
  27.                     10000
  28.                     (+ number (cadr (assoc (car roman) romans)) (* prior -2))))
  29.             (else (loop (cdr roman)
  30.                         (cadr (assoc (car roman) romans))
  31.                         (+ number (cadr (assoc (car roman) romans)))))))))
  32.  
  33. (define (number->roman n)
  34.   (if (and (integer? n) (> n 0))
  35.       (let loop ((n n)
  36.                  (romans '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) (10 #\X) (5 #\V) (1 #\I)))
  37.                  (boundaries '(100 100 10 10 1 1 #f))
  38.                  (s '()))
  39.         (if (null? romans)
  40.             (list->string (reverse s))
  41.             (let ((roman-val (caar romans))
  42.                   (roman-dgt (cadar romans))
  43.                   (bdry (car boundaries)))
  44.               (let loop2 ((q (quotient n roman-val))
  45.                           (r (remainder n roman-val))
  46.                           (s s))
  47.                 (if (= q 0)
  48.                     (if (and bdry (>= r (- roman-val bdry)))
  49.                         (loop (remainder r bdry) (cdr romans)
  50.                               (cdr boundaries)
  51.                               (cons roman-dgt
  52.                                     (append
  53.                                       (cdr (assv bdry romans))
  54.                                       s)))
  55.                         (loop r (cdr romans) (cdr boundaries) s))
  56.                     (loop2 (- q 1) r (cons roman-dgt s)))))))
  57.       (error 'number->roman "only positive integers can be romanized")))
  58.  
  59. (display (filter (lambda (s) (= (string-length s) 4))
  60.                  (map number->roman (range 1 100))))
  61. (newline)
  62.  
  63. (display (map roman->number
  64.        (filter (lambda (s) (= (string-length s) 4))
  65.                (map number->roman (range 1 100)))))
  66. (newline)
Success #stdin #stdout 0.01s 8204KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
(VIII XIII XVII XXII XXIV XXVI XXIX XXXI XXXV XLII XLIV XLVI XLIX LIII LVII LXII LXIV LXVI LXIX LXXI LXXV LXXX XCII XCIV XCVI XCIX)
(8 13 17 22 24 26 29 31 35 42 44 46 49 53 57 62 64 66 69 71 75 80 92 94 96 99)
https://ideone.com/09fKbI
language:
Scheme (chicken 4.13)
created:
4 years ago
visibility:
public

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!