From 11f83cf1e3a179d3442ce5610a69483fececffb2 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Tue, 23 Apr 2019 21:28:40 +0200
Subject: Replace text-flow function.

---
 module/output/terminal.scm | 13 ++++--------
 module/output/text.scm     | 53 ++++++++++++++++++++++++++++++++++++++++++++++
 module/util.scm            | 22 +++++++++++++++++--
 3 files changed, 77 insertions(+), 11 deletions(-)
 create mode 100644 module/output/text.scm

(limited to 'module')

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)))
diff --git a/module/util.scm b/module/util.scm
index 8abf6877..01d2eeb1 100644
--- a/module/util.scm
+++ b/module/util.scm
@@ -153,8 +153,10 @@
 ;; Still requires all variables to be defined beforehand.
 (define-syntax set!
   (syntax-rules ()
-    ((_ field val)
-     ((@ (guile) set!) field val))
+    ((_ field expr)
+     (let ((val expr))
+       ((@ (guile) set!) field val)
+       val))
     ((_ field val rest ...)
      (begin ((@ (guile) set!) field val)
             (set! rest ...)))))
@@ -289,3 +291,19 @@
 (define-macro (catch-multiple thunk . cases)
   (catch-recur% (map car cases) thunk cases))
 
+(define-public (flatten lst)
+  (fold (lambda (subl done)
+          (append done ((if (list? subl) flatten list) subl)))
+        '() lst))
+
+;; Retuns two values. The longset head which satisfies @var{pred?},
+;; and the rest of the elements of list.
+;; Guarentees to only call @var{pred?} once for each element.
+(define-public (take-drop-while pred? list)
+  (let loop ((done '()) (rem list))
+    (cond ((null? rem) (values (reverse done) '()))
+          ((pred? (car rem)) (loop (cons (car rem) done) (cdr rem)))
+          (else (values (reverse done) rem)))))
+
+
+
-- 
cgit v1.2.3