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