[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/h8YcTvLO    [ raw code | output | fork ]

programmingpraxis - Scheme, pasted on Sep 20:
; map-reduce

(define sort #f)
(define merge #f)
(let ()
  (define dosort
    (lambda (pred? ls n)
      (if (= n 1)
          (list (car ls))
          (let ((i (quotient n 2)))
            (domerge pred?
                     (dosort pred? ls i)
                     (dosort pred? (list-tail ls i) (- n i)))))))
  (define domerge
    (lambda (pred? l1 l2)
      (cond
        ((null? l1) l2)
        ((null? l2) l1)
        ((pred? (car l2) (car l1))
         (cons (car l2) (domerge pred? l1 (cdr l2))))
        (else (cons (car l1) (domerge pred? (cdr l1) l2))))))
  (set! sort
    (lambda (pred? l)
      (if (null? l) l (dosort pred? l (length l)))))
  (set! merge
    (lambda (pred? l1 l2)
      (domerge pred? l1 l2))))

(define (map-reduce mapper reducer lt? items)
  (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 loop ((items items) (t empty))
    (if (pair? items)
        (call-with-values
          (lambda () (mapper (car items)))
          (lambda (k v) (loop (cdr items) (insert t k v))))
        (enlist t '()))))

(write
  (map-reduce
    (lambda (x) (values x 1))
    (lambda (k v1 v2) (+ v1 v2))
    char<?
    (string->list "banana")))
(newline)

(define (xref file)
  (with-input-from-file file
    (lambda ()
      (map-reduce
        (lambda (x) (values (car x) (list (cdr x))))
        (lambda (k v1 v2) (if (eq? (car v1) (car v2)) v1 (cons (car v2 v1))))
        string<?
        (get-words)))))

(define (get-words . port)
  (define (get-word p)
    (let loop ((c (peek-char p)) (rev-word '()))
      (cond ((eof-object? c) (if (pair? rev-word) (list->string (reverse rev-word)) c))
            ((char-in-word? c)
              (let ((x (read-char p))) (loop (peek-char p) (cons x rev-word))))
            ((pair? rev-word) (list->string (reverse rev-word)))
            ((char=? #\newline c) (read-char p) "")
            (else (read-char p) (loop (peek-char p) rev-word)))))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((w (get-word p)) (line 1) (word-list '()))
      (cond ((eof-object? w) word-list)
            ((string=? "" w) (loop (get-word p) (add1 line) word-list))
            (else (loop (get-word p) line (cons (cons w line) word-list)))))))

(define (anagrams words)
  (map cdr
    (map-reduce
      (lambda (x)
        (values
          (list->string (sort char<? (string->list x)))
          x))
      (lambda (k v1 v2) (string-append v1 " " v2))
      string<?
      words)))

(write (anagrams '("time" "stop" "pots" "cars" "emit")))
(newline)

(define (map-reduce-input reader mapper reducer lt? . pof)
  (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* ((f? (and (pair? pof) (string? (car pof))))
         (p (cond (f? (open-input-file (car pof)))
                  ((pair? pof) (car pof))
                  (else (current-input-port)))))
    (let loop ((item (reader p)) (t empty))
      (if (eof-object? item)
          (begin (if f? (close-input-port p))
                 (enlist t '()))
          (call-with-values
            (lambda () (mapper item))
            (lambda (k v) (loop (reader p) (insert t k v))))))))


Output:
1
2
((#\a . 3) (#\b . 1) (#\n . 2))
("cars" "time emit" "stop pots")


Create a new paste based on this one


Comments: