; natural join
(define (string-split sep str)
(define (f cs xs) (cons (list->string (reverse cs)) xs))
(let loop ((ss (string->list str)) (cs '()) (xs '()))
(cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
(else (loop (cdr ss) (cons (car ss) cs) xs)))))
(define (string-join sep ss)
(define (f s ss)
(string-append s (string sep) ss))
(define (join ss)
(if (null? (cdr ss)) (car ss)
(f (car ss) (join (cdr ss)))))
(if (null? ss) "" (join ss)))
(define (read-line . port)
(define (eat p c)
(if (and (not (eof-object? (peek-char p)))
(char=? (peek-char p) c))
(read-char p)))
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((c (read-char p)) (line '()))
(cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
(else (loop (read-char p) (cons c line)))))))
(define (join file1 file2)
(let ((f1 (open-input-file file1)) (f2 (open-input-file file2)))
(let loop ((line1 (read-line f1)) (group2 (get-group f2)))
(cond ((or (eof-object? line1) (null? group2))
(close-input-port f1) (close-input-port f2))
((string<? (prefix line1) (prefix (car group2)))
(loop (read-line f1) group2))
((string<? (prefix (car group2)) (prefix line1))
(loop line1 (get-group f2)))
(else (do ((group2 group2 (cdr group2))) ((null? group2))
(display line1) (display #\tab)
(display (string-join #\tab (suffix (car group2))))
(newline))
(loop (read-line f1) group2))))))
(define (get-group f)
(let loop ((line (getone f)) (xs '()))
(cond ((eof-object? line) (reverse xs))
((null? xs) (loop (getone f) (cons line xs)))
((string=? (prefix line) (prefix (car xs)))
(loop (getone f) (cons line xs)))
(else (unget line) (reverse xs)))))
(define ungot-line #f)
(define (getone f)
(if ungot-line
(let ((x ungot-line)) (set! ungot-line #f) x)
(read-line f)))
(define (unget line) (set! ungot-line line))
(define (prefix line) (car (string-split #\tab line)))
(define (suffix line) (cdr (string-split #\tab line)))