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