;;; PROBLEM 5. Paragraph filling
;;; Some auxiliary string-manipulation procedures that will be useful:
;;; ------------------------------------------------------------------
(define STRING-NULL
(lambda [string]
(= string "")))
(define STRING-FIRST
(lambda [string]
(nth-char 1 string)))
(define STRING-REST
(lambda [string]
(substring 2 (string-length string) string)))
;;; Some test:
(string-null "abc") ; normalizes to $FALSE
(string-null "") ; normalizes to $TRUE
(string-first "abc") ; normalizes to #a
(string-rest "abc") ; normalizes to "bc"
;;; Routines to read in text from the terminal:
;;; -------------------------------------------
;;; READLINE reads a line of text from the terminal and returns a
;;; -------- stringer designating the string of characters typed in.
;;; A line is a series of characters delimited by a carriage
;;; return. The carriage return character is not included in the
;;; returned string.
(define read-line
(lambda []
(string-in ps cr)))
;;; READ-PARAGRAPH reads a paragraph of text from the terminal, where
;;; -------------- a paragraph is a series of lines delimited by the
;;; empty line.
(define read-paragraph
(lambda []
(let [[line (read-line)]]
(if (string-null line)
line
(string-append line " "
(read-paragraph))))))
;;; Note that READ-PARAGRAPH returns a string with no carriage returns
;;; in it. The carriage returns are not part of the line returned by
;;; READ-LINE and the inter-line character used by READ-PARAGRAPH is a
;;; normal space. However, if we wanted to be able to get rid of
;;; carriage returns in strings, we could do so with the following
;;; procedure.
;;; REMOVE-CRS removes all carriage returns from a string.
;;; ----------
(define REMOVE-CRS
(lambda [string]
(cond [(string-null string) string]
[(= (string-first string) cr)
(string-cons # (remove-crs (string-rest string)))]
[$true (string-cons (string-first string)
(remove-crs (string-rest string)))])))
;;; Some tests:
(remove-crs "abc
def ghi
jkl
mno pqr stu
vwx yz") ; normalizes to "abc def ghi jkl mno pqr stu vwx yz"
(remove-crs "") ; normalizes to ""
;;; PROBLEM 5-b and 5-c
;;; Paragraph-filling procedures.
;;; -----------------------------
;;; We are going to break a string into lines (i.e. strings delimited
;;; by carriage returns) such that no line is longer than some
;;; parameter FILL-COLUMN and as many words are packed into a line as
;;; possible. We decompose the problem recursively as follows. First,
;;; find the first line, then recursively break the remaining text into
;;; pieces. The base case occurs when no breaking needs to be done,
;;; that is, when the string is shorter than the fill-column requires.
;;; First, a routine to find the index of a good place to break off
;;; the first line.
;;; BREAK-LINE returns the index in a string of the appropriate place
;;; ---------- to break off the first line of a text. It does this
;;; by finding the last space in the first FILL-COLUMN
;;; characters of the text. It assumes that the text is longer than
;;; fill-column.
(define BREAK-LINE
(lambda [text fill-column]
(letseq [[first-few-chars (substring 1 fill-column text)]
[last-space (reverse-string-search " "
first-few-chars)]]
last-space)))
;;; REVERSE-STRING-SEARCH returns the index of the last occurrence
;;; --------------------- of a string KEY in another string TEXT.
(define REVERSE-STRING-SEARCH
(lambda [key text]
(let [[reverse-location (string-search (string-reverse key)
(string-reverse text))]]
(- (- (1+ (string-length text))
reverse-location)
(1- (string-length key))))))
;;; STRING-REVERSE reverses a string.
;;; --------------
(define string-reverse
(lambda [string]
(if (string-null string)
string
(string-append (string-reverse (string-rest string))
(string-cons (string-first string))))))
;;; Some tests:
(string-reverse "") ; normalizes to ""
(string-reverse "abc") ; normalizes to "cba"
(reverse-string-search "abc" "xyz abc xyz") ; normalizes to 5
(reverse-string-search "aba" "ababababa") ; normalizes to 7
(reverse-string-search "abc" "defghijkl") ; normalizes to
;;; FILL-PARAGRAPH takes a string TEXT and a column FILL-COLUMN and
;;; -------------- returns a string with carriage returns inserted so
;;; that the text is filled relative to the
;;; fill-column.
(define FILL-PARAGRAPH
(lambda [text fill-column]
(if (< (string-length text)
fill-column) ; text is short enough
text ; so return it
(let [[break (break-line text fill-column)]]
(string-append ; else put together
(substring 1 break text) ; the first line
(string-cons cr "") ; a carriage return
(fill-paragraph ; and a filled paragraph
(substring (1+ break) ; based on the rest of
; the text
(string-length text)
text)
fill-column))))))
;;; Some tests. See attached window image for the results.
(set test (remove-crs
"She told me you had been to her
and mentioned me to him.
He gave me a good character
but said I could not swim."
))
(fill-paragraph test 30)
(fill-paragraph test 20)
(fill-paragraph test 10)
(fill-paragraph test 7)
;;; Note the behavior if a word is longer than the fill-column.
;;; It breaks the word in half at the fill-column. Perhaps a
;;; better solution would be to break the line after the long
;;; word, even if it spills over the fill-column. Thus:
(define BREAK-LINE
(lambda [text fill-column]
(letseq [[first-few-chars (substring 1 fill-column text)]
[last-space (reverse-string-search " "
first-few-chars)]]
(if (> last-space fill-column)
(string-search " " text)
last-space))))
;;; Now testing the new version:
(fill-paragraph test 7)
;;; Of course, one could imagine a BREAK-LINE that tried to hyphenate
;;; words at reasonable places, and so forth. We won't attempt to
;;; give examples of this. See the TeXbook by Donald Knuth for
;;; information about hyphenation algorithms (and algorithms for
;;; many other text formatting tasks, like line and page breaking).
;;; Finally, a routine to act as an interactive paragraph filler,
;;; allowing a user to enter a paragraph from the terminal, and
;;; printing the filled-paragraph to the terminal.
(define TEST
(lambda [fill-column]
(string-out ps
(fill-paragraph (read-paragraph) fill-column))))