[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
150/197: gurses: Reimplement pad-complex-string.
From: |
Danny Milosavljevic |
Subject: |
150/197: gurses: Reimplement pad-complex-string. |
Date: |
Mon, 3 Jul 2017 20:37:16 -0400 (EDT) |
dannym pushed a commit to branch wip-installer-2
in repository guix.
commit 265d0e32db7be571757d61943721941f657047ba
Author: John Darrington <address@hidden>
Date: Sun Jan 29 07:38:48 2017 +0100
gurses: Reimplement pad-complex-string.
* gurses/stexi.scm (pad-complex-string) : Simpler and better implementation.
---
gurses/stexi.scm | 79 +++++++++++++++++---------------------------------------
1 file changed, 24 insertions(+), 55 deletions(-)
diff --git a/gurses/stexi.scm b/gurses/stexi.scm
index 87a7572..3ef86aa 100644
--- a/gurses/stexi.scm
+++ b/gurses/stexi.scm
@@ -146,6 +146,11 @@ cdr is the remainder"
(loop rest (1+ count) (cons first line0) remainder)
(loop rest (1+ count) line0 (cons first remainder)))))))
+
+(define-public (insert-space line index)
+ (call-with-values (lambda () (split-at line index))
+ (lambda (x y) (append x (normal " ") y))))
+
(define (paragraph-format cs line-length)
(let loop ((pr (line-split cs line-length))
(acc '()))
@@ -188,61 +193,25 @@ cdr is the remainder"
(define (pad-complex-string str len)
"Return a complex string based on STR but with interword padding to make the
string of length LEN"
-
- (define (count-words str)
- (let loop ((in str)
- (x 0)
- (n 0)
- (prev-white #t))
- (match
- in
- (() n)
- ((first . rest)
- (let ((white (xchar-blank? first)))
- (loop rest (1+ x) (if (and prev-white (not white))
- (1+ n)
- n) white))))))
-
- (let* ((underflow (- len (length str)))
- (word-count (count-words str))
- (inter-word-space-count (1- word-count)))
-
- (if (zero? inter-word-space-count)
+ (let ((how-many (- len (length str)))
+ (endings (word-endings str)))
+ (if (null? endings)
str
- (begin
- (when (negative? underflow)
- (error
- (format
- #f
- "You asked to pad to ~a but the string is already ~a
characters long."
- len (length str))))
-
+ (let ((rem (remainder how-many (length endings)))
+ (quot (quotient how-many (length endings))))
(if (eqv? (xchar->char (last str)) #\newline)
str ; Don't justify the last line of a paragraph
- (let loop ((in str)
- (out '())
- (words 0)
- (spaces 0)
- (prev-white #t))
- (match
- in
- (() (reverse out))
- ((first . rest)
- (let* ((white (xchar-blank? first))
- (end-of-word (and white (not prev-white)))
- (words-processed (if end-of-word (1+ words) words))
- (spaces-inserted (if end-of-word
- (truncate (- (*
- (/ underflow
inter-word-space-count)
- words-processed)
- spaces))
- 0)))
- (loop rest
- ;; FIXME: Use a more intelligent algorithm.
- ;; (prefer spaces at sentence endings for example)
- (append
- (make-list spaces-inserted (normal #\space))
- (cons first out))
- words-processed
- (+ spaces spaces-inserted)
- white))))))))))
+ (begin
+ ;; FIXME: If quot is non zero, then we must pad EVERY space
with
+ ;; quot additional spaces.
+ (when (positive? quot)
+ (error "Quotient is positive"))
+
+ (let loop ((in str)
+ (ips
+ (sort (take endings rem) (lambda (x y) (> x y)))))
+ (if (null? ips)
+ in
+ (loop
+ (insert-space in (car ips))
+ (cdr ips))))))))))
- 114/197: installer: Check that swap spaces have not been assigned mount points, (continued)
- 114/197: installer: Check that swap spaces have not been assigned mount points, Danny Milosavljevic, 2017/07/03
- 112/197: gurses: form: Use match instead of car, cdr etc., Danny Milosavljevic, 2017/07/03
- 125/197: installer: Do not assume the root file system is of type "ext4"., Danny Milosavljevic, 2017/07/03
- 130/197: installer: Delete unused procedure "justify"., Danny Milosavljevic, 2017/07/03
- 134/197: installer: Tolerate an undefined system role in config generation., Danny Milosavljevic, 2017/07/03
- 137/197: installer: Prepare for new wireless network features., Danny Milosavljevic, 2017/07/03
- 140/197: installer: Fix the key map option., Danny Milosavljevic, 2017/07/03
- 132/197: installer: Add new procedure to check file system specifications., Danny Milosavljevic, 2017/07/03
- 145/197: gurses: Avoid yet another use of car and cdr., Danny Milosavljevic, 2017/07/03
- 129/197: installer: Emphasise that writing filesystems destroys existing data., Danny Milosavljevic, 2017/07/03
- 150/197: gurses: Reimplement pad-complex-string.,
Danny Milosavljevic <=
- 159/197: installer: Fix i18n in dialogs., Danny Milosavljevic, 2017/07/03
- 154/197: installer: Main page: Redisplay translatable strings upon refresh., Danny Milosavljevic, 2017/07/03
- 157/197: installer: Replace 'file-browser' with 'key-map'., Danny Milosavljevic, 2017/07/03
- 161/197: installer: Improve i18n in ping page., Danny Milosavljevic, 2017/07/03
- 162/197: gurses: Avoid one use of car/cdr., Danny Milosavljevic, 2017/07/03
- 166/197: installer: Provide verbose description of locale., Danny Milosavljevic, 2017/07/03
- 167/197: installer: Fix bug when changing languages., Danny Milosavljevic, 2017/07/03
- 156/197: installer: New page to select language., Danny Milosavljevic, 2017/07/03
- 168/197: installer: Fix the startup locale., Danny Milosavljevic, 2017/07/03
- 173/197: installer: Remove whitespace., Danny Milosavljevic, 2017/07/03