Replace text-flow function.

2 files changed, 57 insertions, 9 deletions

diff --git a/module/output/terminal.scm b/module/output/terminal.scm
index 6779ee5b..f9796d68 100644
--- a/module/output/terminal.scm
+++ b/module/output/terminal.scm
@@ -1,5 +1,6 @@
 (define-module (output terminal)
   #:use-module (output general)
+  #:use-module (output text)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-19 util)
@@ -14,7 +15,6 @@
   #:use-module (vcomponent)
   #:use-module (vcomponent datetime)
 
-  #:use-module (texinfo string-utils)     ; string->wrapped-lines
   #:use-module (ice-9 format)
   #:use-module (ice-9 getopt-long)
   #:use-module (parameters)
@@ -71,14 +71,9 @@
                   (or (and=> (attr ev 'LOCATION) (cut string-append "Plats: " <> "\n")) "")
                   (time->string (attr ev 'DTSTART) "~1 ~3")
                   (time->string (attr ev 'DTEND) "~1 ~3")
-                  (string-join   ; TODO replace this with a better text flower
-                   (take-to      ; This one destroys newlines used for layout
-                    (string->wrapped-lines (or (attr ev 'DESCRIPTION) "")
-                                           #:line-width 60
-                                           #:collapse-whitespace? #f)
-                    10)
-                   (string #\newline))
-                  )))
+                  (flow-text (or (attr ev 'DESCRIPTION) "")
+                             #:width 70
+                             #:height 10))))
 
       (let ((char (read-char)))
         ;; (format (current-error-port)
diff --git a/module/output/text.scm b/module/output/text.scm
new file mode 100644
index 00000000..e86f4664
--- /dev/null
+++ b/module/output/text.scm
@@ -0,0 +1,53 @@
+(define-module (output text)
+  #:use-module (util)
+  #:export (justify-line flow-text))
+
+(define-public (words str) (string-split str #\space))
+(define-public (unwords list) (string-join list " " 'infix))
+
+(define-public (lines str) (string-split str #\newline))
+(define-public (unlines list) (string-join list "\n" 'infix))
+
+(define* (add-some list amount item #:optional flipflop?)
+  (cond ((zero? amount) list)
+        ((null? list) '())
+        (else
+         (cons (if flipflop? item (car list))
+               (add-some (if flipflop? list (cdr list))
+                         (if flipflop? (1- amount) amount)
+                         item (not flipflop?))))))
+
+;; (str) -> str
+(define* (justify-line-helper words #:key (width 70))
+  (let* ((len (1- (apply + (map (compose 1+ string-length) words))))
+         (to-add (- width len))
+         (slots (1- (length words)))
+         (sp-per (ceiling-quotient to-add slots)))
+
+    (unwords (add-some words to-add (make-string (1- sp-per) #\space)))))
+
+
+;; Splits and justifies the given line to @var{#:width}.
+;; Returns a list of justified strings.
+;; str -> (str)
+(define* (justify-line line #:key (width 70))
+  (let recur ((lst (words line)))
+    (let* ((head tail (take-drop-while
+                       (let ((w 0))
+                         (lambda (word)    ; Take words until we are above the limit.
+                           (< (mod! w = (+ 1 (string-length word)))
+                              width)))
+                       lst)))
+      (if (null? tail)
+          (list (unwords head)) ; Don't justify last line.
+          (cons (justify-line-helper head #:width width)
+                (recur tail))))))
+
+;; str -> str
+(define* (flow-text str #:key (width 70) (height 10))
+  (unlines
+   (take-to
+    (flatten
+     (map (lambda (line) (justify-line line #:width width))
+          (lines str)))
+    height)))