; base conversion

(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 (2to4 str)
  (let loop ((bits (reverse (string->list str))) (quads (list)))
    (cond ((null? bits)
            (list->string quads))
          ((null? (cdr bits))
            (loop (cdr bits) (cons (car bits) quads)))
          ((and (char=? (cadr bits) #\0) (char=? (car bits) #\0))
            (loop (cddr bits) (cons #\0 quads)))
          ((and (char=? (cadr bits) #\0) (char=? (car bits) #\1))
            (loop (cddr bits) (cons #\1 quads)))
          ((and (char=? (cadr bits) #\1) (char=? (car bits) #\0))
            (loop (cddr bits) (cons #\2 quads)))
          ((and (char=? (cadr bits) #\1) (char=? (car bits) #\1))
            (loop (cddr bits) (cons #\3 quads)))
          (else (error '2to4 "can't happen")))))

(display (2to4 "11011000")) (newline)

(define (2to4 str)
  (let loop ((bits (reverse (string->list str))) (quads (list)))
    (list-match bits
      (() (list->string quads))
      ((b) (loop '() (cons b quads)))
      ((#\0 #\0 . bs) (loop bs (cons #\0 quads)))
      ((#\1 #\0 . bs) (loop bs (cons #\1 quads)))
      ((#\0 #\1 . bs) (loop bs (cons #\2 quads)))
      ((#\1 #\1 . bs) (loop bs (cons #\3 quads)))
      (else (error '2to4 "can't happen")))))

(display (2to4 "11011000")) (newline)

(define (2to4 str)
  (number->string (string->number str 2) 4))

(display (2to4 "11011000")) (newline)

(define (convert in out str)
  (number->string (string->number str in) out))

(display (convert 2 4 "11011000")) (newline)