; READ-CHARS N [PORT]
(define (read-chars n . port)
(let ((p (if (null? port) (current-input-port) (car port))))
(if (eof-object? (peek-char p))
(peek-char p)
(let loop ((n n) (c (peek-char p)) (s '()))
(cond ((and (eof-object? c) (pair? s)) (list->string (reverse s)))
((eof-object? c) c)
((zero? n) (list->string (reverse s)))
(else (let ((c (read-char p)))
(loop (sub1 n) (peek-char p) (cons c s)))))))))
; READ-LINE [PORT]
(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)))))))
; READ-FIXED-RECORD SIZE DEF-LIST [PORT]
(define (read-fixed-record size defs . port)
(let ((p (if (null? port) (current-input-port) (car port))))
(let ((fix-rec (read-chars size p)))
(if (eof-object? fix-rec)
fix-rec
(let loop ((defs defs) (result '()))
(if (null? defs)
(reverse result)
(loop (cdr defs)
(cons (substring fix-rec (caar defs) (cadar defs)) result))))))))
; READ-DELIM-RECORD [DELIM] [PORT]
(define (read-delim-record . args)
(define (eat p c)
(if (and (not (eof-object? (peek-char p)))
(char=? (peek-char p) c))
(read-char p)))
(define (read-delim delim port)
(cond ((eof-object? (peek-char port)) (peek-char port))
((and delim (or (char=? delim #\return) (char=? delim #\newline)))
(let loop ((f (read-line port)) (fields '()))
(if (or (eof-object? f) (string=? f ""))
(reverse fields)
(loop (read-line port) (cons f fields)))))
(else
(let loop ((c (read-char port)) (field '()) (fields '()))
(cond ((eof-object? c) (reverse (cons (list->string (reverse field)) fields)))
((char=? #\return) (eat port #\newline)
(reverse (cons (list->string (reverse field)) fields)))
((char=? #\newline c) (eat port #\return)
(reverse (cons (list->string (reverse field)) fields)))
((and delim (char=? delim c))
(loop (read-char port) '() (cons (list->string (reverse field)) fields)))
((char-whitespace? c)
(if (char-whitespace? (peek-char port))
(loop (read-char port) field fields)
(loop (read-char port) '()
(cons (list->string (reverse field)) fields))))
(else (loop (read-char port) (cons c field) fields)))))))
(cond ((null? args) (read-delim \#f (current-input-port)))
((and (null? (cdr args)) (char? (car args)))
(read-delim (car args) (current-input-port)))
((and (null? (cdr args)) (port? (car args)))
(read-delim \#f (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(read-delim (car args) (cadr args)))
(else (read-delim \#f (current-input-port)))))
; READ-CSV-RECORD [DELIM] [PORT]
(define (read-csv-record . args)
(define (read-csv delim port)
(define (add-field field fields)
(cons (list->string (reverse field)) fields))
(define (start field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (reverse fields))
((char=? #\return c) (carriage-return field fields))
((char=? #\newline c) (line-feed field fields))
((char=? #\" c) (quoted-field field fields))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (not-field field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (cons "" fields))
((char=? #\return c) (carriage-return '() (add-field field fields)))
((char=? #\newline c) (line-feed '() (add-field field fields)))
((char=? #\" c) (quoted-field field fields))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (quoted-field field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (add-field field fields))
((char=? #\" c) (may-be-doubled-quotes field fields))
(else (quoted-field (cons c field) fields)))))
(define (may-be-doubled-quotes field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (add-field field fields))
((char=? #\return c) (carriage-return '() (add-field field fields)))
((char=? #\newline c) (line-feed '() (add-field field fields)))
((char=? #\" c) (quoted-field (cons #\" field) fields))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (unquoted-field field fields)
(let ((c (read-char port)))
(cond ((eof-object? c) (add-field field fields))
((char=? #\return c) (carriage-return '() (add-field field fields)))
((char=? #\newline c) (line-feed '() (add-field field fields)))
((char=? delim c) (not-field '() (add-field field fields)))
(else (unquoted-field (cons c field) fields)))))
(define (carriage-return field fields)
(let ((c (peek-char port)))
(cond ((eof-object? c) fields)
((char=? #\newline c) (read-char port) fields)
(else fields))))
(define (line-feed field fields)
(let ((c (peek-char port)))
(cond ((eof-object? c) fields)
((char=? #\return c) (read-char port) fields)
(else fields))))
(if (eof-object? (peek-char port)) (peek-char port) (reverse (start '() '()))))
(cond ((null? args) (read-csv #\, (current-input-port)))
((and (null? (cdr args)) (char? (car args)))
(read-csv (car args) (current-input-port)))
((and (null? (cdr args)) (port? (car args)))
(read-csv #\, (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(read-csv (car args) (cadr args)))
(else (read-csv #\, (current-input-port)))))
; READ-NAME-VALUE-RECORD [DELIM] [PORT]
(define (read-name-value-record . args)
(define (eat p c)
(if (and (not (eof-object? (peek-char p)))
(char=? (peek-char p) c))
(read-char p)))
(define (read-name-value delim port)
(if (eof-object? (peek-char port))
(peek-char port)
(let loop ((c (read-char port)) (key '()) (value '()) (fields '()))
(if (string? key)
(cond ((eof-object? c)
(reverse (cons (cons key (list->string (reverse value))) fields)))
((char=? #\return c) (eat port #\newline)
(loop (read-char port) '() '()
(cons (cons key (list->string (reverse value))) fields)))
((char=? #\newline c) (eat port #\return)
(loop (read-char port) '() '()
(cons (cons key (list->string (reverse value))) fields)))
(else (loop (read-char port) key (cons c value) fields)))
(cond ((eof-object? c)
(reverse (cons (cons (list->string (reverse key)) "") fields)))
((char=? #\return c) (eat port #\newline)
(reverse (cons (cons (list->string (reverse key)) "") fields)))
((char=? #\newline c) (eat port #\return)
(reverse (cons (cons (list->string (reverse key)) "") fields)))
((and delim (char=? delim c))
(loop (read-char port) (list->string (reverse key)) value fields))
((and (not delim) (char-whitespace? c))
(if (char-whitespace? (peek-char port))
(loop (read-char port) key value fields)
(loop (read-char port) (list->string (reverse key)) value fields)))
(else (loop (read-char port) (cons c key) value fields)))))))
(cond ((null? args) (read-name-value \#f (current-input-port)))
((and (null? (cdr args)) (char? (car args)))
(read-name-value (car args) (current-input-port)))
((and (null? (cdr args)) (port? (car args)))
(read-name-value \#f (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(read-name-value (car args) (cadr args)))
(else (read-name-value \#f (current-input-port)))))
; FILTER-PORT READER PRED?
(define (filter-port reader pred?)
(lambda args
(let loop ((x (apply reader args)))
(cond ((eof-object? x) x)
((pred? x) x)
(else (loop (apply reader args)))))))
; FOR-EACH-PORT READER PROC [PORT]
(define (for-each-port reader proc . port)
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((item (reader p)))
(if (not (eof-object? item))
(begin (proc item) (loop (reader p)))))))
; MAP-PORT READER MAPPER [PORT]
(define (map-port reader mapper . port)
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((item (reader p)) (result '()))
(if (eof-object? item)
(reverse result)
(loop (reader p) (cons (mapper item) result))))))
; FOLD-PORT READER FOLDER BASE [PORT]
(define (fold-port reader folder base . port)
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((item (reader p)) (result base))
(if (eof-object? item)
result
(loop (reader p) (folder result item))))))
; MAP-REDUCE-PORT READER MAPPER REDUCER LT? [PORT]
(define (map-reduce-port reader mapper reducer lt? . port)
(define (tree c k v l r) (vector c k v l r))
(define empty (tree 'black 'nil 'nil 'nil 'nil))
(define (empty? t) (eqv? t empty))
(define (color t) (vector-ref t 0))
(define (key t) (vector-ref t 1))
(define (value t) (vector-ref t 2))
(define (lkid t) (vector-ref t 3))
(define (rkid t) (vector-ref t 4))
(define (red? c) (eqv? c 'red))
(define (black? c) (eqv? c 'black))
(define (balance c k v l r)
(cond ((and (black? c) (red? (color l)) (red? (color (lkid l))))
(tree 'red (key l) (value l)
(tree 'black (key (lkid l)) (value (lkid l))
(lkid (lkid l)) (rkid (lkid l)))
(tree 'black k v (rkid l) r)))
((and (black? c) (red? (color l)) (red? (color (rkid l))))
(tree 'red (key (rkid l)) (value (rkid l))
(tree 'black (key l) (value l) (lkid l) (lkid (rkid l)))
(tree 'black k v (rkid (rkid l)) r)))
((and (black? c) (red? (color r)) (red? (color (lkid r))))
(tree 'red (key (lkid r)) (value (lkid r))
(tree 'black k v l (lkid (lkid r)))
(tree 'black (key r) (value r) (rkid (lkid r)) (rkid r))))
((and (black? c) (red? (color r)) (red? (color (rkid r))))
(tree 'red (key r) (value r)
(tree 'black k v l (lkid r))
(tree 'black (key (rkid r)) (value (rkid r))
(lkid (rkid r)) (rkid (rkid r)))))
(else (tree c k v l r))))
(define (insert t k v)
(define (ins t)
(let ((tc (color t)) (tk (key t)) (tv (value t)) (tl (lkid t)) (tr (rkid t)))
(cond ((empty? t) (tree 'red k v empty empty))
((lt? k tk) (balance tc tk tv (ins tl) tr))
((lt? tk k) (balance tc tk tv tl (ins tr)))
(else (tree tc tk (reducer k tv v) tl tr)))))
(let* ((z (ins t)) (zk (key z)) (zv (value z)) (zl (lkid z)) (zr (rkid z)))
(tree 'black zk zv zl zr)))
(define (enlist t base)
(cond ((empty? t) base)
((and (empty? (lkid t)) (empty? (rkid t)))
(cons (cons (key t) (value t)) base))
(else (enlist (lkid t)
(cons (cons (key t) (value t))
(enlist (rkid t) base))))))
(let ((p (if (null? port) (current-input-port) (car port))))
(let loop ((item (reader p)) (t empty))
(if (eof-object? item)
(enlist t '())
(call-with-values
(lambda () (mapper item))
(lambda (k v) (loop (reader p) (insert t k v))))))))
; QUOTE-CSV DELIM STR
(define (quote-csv delim str)
(define (string-find str pat)
(let loop ((i 0))
(cond ((<= (string-length str) i) \#f)
((string=? (substring str i (+ i (string-length pat))) pat) i)
(else (loop (+ i 1))))))
(define (string-replace-all str pat repl)
(let ((len-str (string-length str))
(len-pat (string-length pat))
(spot (string-find str pat)))
(if spot
(string-append
(substring str 0 spot)
repl
(string-replace-all (substring str (+ spot len-pat) len-str) pat repl))
str)))
(let ((new-str (string-replace-all str "\"" "\"\"")))
(if (or (string-find str (string delim))
(not (string=? str new-str))
(string-find str (string #\return))
(string-find str (string #\newline)))
(string-append "\"" new-str "\"")
str)))
; WRITE-FIXED-RECORD REC SIZE DEFS [PORT]
(define (write-fixed-record rec size defs . port)
(let ((p (if (null? port) (current-output-port) (car port)))
(out (make-string size #\space)))
(do ((rec rec (cdr rec))
(defs defs (cdr defs)))
((or (null? rec) (null? defs)) (display out p))
(do ((s 0 (+ s 1))
(t (caar defs) (+ t 1)))
((or (= s (string-length (car rec))) (= (cadar defs) t)))
(string-set! out t (string-ref (car rec) s))))))
; WRITE-DELIM-RECORD REC [DELIM] [PORT]
(define (write-delim-record rec . args)
(define (write-delim delim port)
(do ((rec rec (cdr rec)))
((null? rec) (newline port))
(display (car rec) port)
(if (pair? (cdr rec)) (display delim port)))
(if (or (char=? delim #\return) (char=? delim #\newline)) (newline port)))
(cond ((null? args) (write-delim #\space (current-output-port)))
((and (null? (cdr args)) (char? (car args)))
(write-delim (car args) (current-output-port)))
((and (null? (cdr args)) (port? (car args)))
(write-delim #\space (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(write-delim (car args) (cadr args)))
(else (write-delim #\space (current-output-port)))))
; WRITE-CSV-RECORD REC [DELIM] [PORT]
(define (write-csv-record rec . args)
(define (write-csv delim port)
(do ((rec rec (cdr rec)))
((null? rec) (newline port))
(display (quote-csv delim (car rec)) port)
(if (pair? (cdr rec)) (display delim port))))
(cond ((null? args) (write-csv #\, (current-output-port)))
((and (null? (cdr args)) (char? (car args)))
(write-csv (car args) (current-output-port)))
((and (null? (cdr args)) (port? (car args)))
(write-csv #\, (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(write-csv (car args) (cadr args)))
(else (write-csv #\, (current-output-port)))))
; WRITE-NAME-VALUE-RECORD REC [DELIM] [PORT]
(define (write-name-value-record rec . args)
(define (write-name-value delim port)
(do ((rec rec (cdr rec)))
((null? rec) (newline port))
(display (caar rec) port)
(display delim port)
(display (cdar rec) port)
(newline port)))
(cond ((null? args) (write-name-value #\space (current-output-port)))
((and (null? (cdr args)) (char? (car args)))
(write-name-value (car args) (current-output-port)))
((and (null? (cdr args)) (port? (car args)))
(write-name-value #\space (car args)))
((and (pair? (cdr args)) (null? (cddr args)) (char? (car args)) (port? (cadr args)))
(write-name-value (car args) (cadr args)))
(else (write-name-value #\space (current-output-port)))))
Programming Praxis 