; mangarevan counting (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-syntax list-match (syntax-rules () ((_ expr (pattern fender ... template) ...) (let ((obj expr)) (cond ((list-match-aux obj pattern fender ... (list template)) => car) ... (else (error 'list-match "pattern failure"))))))) (define-syntax list-match-aux (lambda (stx) (define (underscore? x) (and (identifier? x) (free-identifier=? x (syntax _)))) (syntax-case stx (quote quasiquote) ((_ obj pattern template) (syntax (list-match-aux obj pattern #t template))) ((_ obj () fender template) (syntax (and (null? obj) fender template))) ((_ obj underscore fender template) (underscore? (syntax underscore)) (syntax (and fender template))) ((_ obj var fender template) (identifier? (syntax var)) (syntax (let ((var obj)) (and fender template)))) ((_ obj (quote datum) fender template) (syntax (and (equal? obj (quote datum)) fender template))) ((_ obj (quasiquote datum) fender template) (syntax (and (equal? obj (quasiquote datum)) fender template))) ((_ obj (kar . kdr) fender template) (syntax (and (pair? obj) (let ((kar-obj (car obj)) (kdr-obj (cdr obj))) (list-match-aux kar-obj kar (list-match-aux kdr-obj kdr fender template)))))) ((_ obj const fender template) (syntax (and (equal? obj const) fender template)))))) (define-syntax assert (syntax-rules () ((assert expr result) (if (not (equal? expr result)) (for-each display `( #\newline "failed assertion:" #\newline expr #\newline "expected: " ,result #\newline "returned: " ,expr #\newline)))))) (define (integer->mangareva n) (when (not (<= 1 n 799)) (error 'integer->mangareva "out of range")) (let loop ((n n) (m (list))) (cond ((<= 80 n) (loop (remainder n 80) (cons "V" (cons (number->string (quotient n 80)) m)))) ((<= 40 n) (loop (- n 40) (cons "T" m))) ((<= 20 n) (loop (- n 20) (cons "P" m))) ((<= 10 n) (loop (- n 10) (cons "K" m))) ((<= 1 n) (loop 0 (cons (number->string n) m))) (else (apply string-append (reverse m)))))) (define (mangareva->integer str) (define (digit? c) (char<=? #\1 c #\9)) (let loop ((cs (string->list str)) (n 0)) (list-match cs (() n) ((m) (digit? m) (loop '() (+ n (char->integer m) -48))) ((#\K . rest) (loop rest (+ n 10))) ((#\P . rest) (loop rest (+ n 20))) ((#\T . rest) (loop rest (+ n 40))) ((m #\V . rest) (digit? m) (loop rest (+ n (* (- (char->integer m) 48) 80)))) (else (error 'mangareva->integer "not a number"))))) (do ((n 1 (+ n 1))) ((= n 800)) (assert (mangareva->integer (integer->mangareva n)) n)) (display (map integer->mangareva (range 1 800))) (newline)