; greedy text justification
(define (sum xs) (apply + xs))
(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 (justify str line-width)
(let loop ((words (string-split #\space str)) (line (list)) (curr-width 0))
(cond ((null? words)
(when (pair? line)
(write-line line (+ (length line) -1
(sum (map string-length line))))))
((< line-width (+ curr-width (string-length (car words))))
(write-line line line-width)
(loop words (list) 0))
(else (loop (cdr words) (cons (car words) line)
(+ curr-width (string-length (car words)) 1))))))
(define (write-line rev-words width)
(let* ((words (reverse rev-words))
(first-word (car words))
(width (- width (string-length first-word)))
(words (cdr words)))
(display first-word)
(if (null? words) (newline)
(let* ((nblanks (- width (sum (map string-length words))))
(sep (make-string (quotient nblanks (length words)) #\space))
(nextra (remainder nblanks (length words))))
(do ((n 0 (+ n 1)) (words words (cdr words)))
((null? words) (newline))
(display sep)
(when (< n nextra) (display #\space))
(display (car words)))))))
(justify "This is an example of text justification." 16)