[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Jan 19:
; roman numeral puzzle
; http://www.johndcook.com/blog/2012/01/14/roman-numeral-puzzle/

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define (filter pred? xs)
  (let loop ((xs xs) (ys '()))
    (cond ((null? xs) (reverse ys))
          ((pred? (car xs))
            (loop (cdr xs) (cons (car xs) ys)))
          (else (loop (cdr xs) ys)))))

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (unique eql? xs)
  (cond ((null? xs) '())
        ((null? (cdr xs)) xs)
        ((eql? (car xs) (cadr xs))
          (unique eql? (cdr xs)))
        (else (cons (car xs) (unique eql? (cdr xs))))))

(define (compose . fns)
  (let comp ((fns fns))
    (cond
      ((null? fns) 'error)
      ((null? (cdr fns)) (car fns))
      (else
        (lambda args
          (call-with-values
            (lambda ()
              (apply
                (comp (cdr fns))
                args))
            (car fns)))))))

(define (number->roman n)
  (if (and (integer? n) (> n 0))
      (let loop ((n n)
                 (romans '((1000 #\M) (500 #\D) (100 #\C)
                   (50 #\L) (10 #\X) (5 #\V) (1 #\I)))
                 (boundaries '(100 100 10 10 1 1 #f))
                 (s '()))
        (if (null? romans)
            (list->string (reverse s))
            (let ((roman-val (caar romans))
                  (roman-dgt (cadar romans))
                  (bdry (car boundaries)))
              (let loop2 ((q (quotient n roman-val))
                          (r (remainder n roman-val))
                          (s s))
                (if (= q 0)
                    (if (and bdry (>= r (- roman-val bdry)))
                        (loop (remainder r bdry) (cdr romans)
                              (cdr boundaries)
                              (cons roman-dgt
                                    (append
                                      (cdr (assv bdry romans))
                                      s)))
                        (loop r (cdr romans) (cdr boundaries) s))
                    (loop2 (- q 1) r (cons roman-dgt s)))))))
      (error 'number->roman "only positive integers can be romanized")))

(define (duplicate? str)
  (let ((cs (sort char<? (string->list str))))
    (not (equal? cs (unique char=? cs)))))

(display
  (length
    (filter (compose not duplicate?)
      (map number->roman
        (range 1 10000)))))


Output:
1
316


Create a new paste based on this one


Comments: