codepad

Language:

; 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)))

Private [?]

Run code