codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; benford's law (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))))) (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))))))) (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)))))))) (define (first-digit n . base) (let* ((b (if (null? base) 10 (car base))) (b2 (* b b))) (let loop ((n n) (i b) (k b2)) (cond ((< n b) n) ((< n k) (loop (quotient n i) b b2)) (else (loop n k (* i i))))))) (define (keep? xs) (string->number (list-ref xs 3))) (let* ((fds (with-input-from-file "mn-lakes.csv" (lambda () (map-reduce-port (filter-port read-csv-record keep?) (lambda (x) (values (first-digit (floor (string->number (list-ref x 3)))) 1)) (lambda (k v1 v2) (+ v1 v2)) <)))) (fds-count (apply + (map cdr fds)))) (for-each (lambda (x) (printf "~a ~f~%" (car x) (/ (cdr x) fds-count 0.01))) fds))
Private
[
?
]
Run code
Submit