(define-module (output text) #:use-module (srfi srfi-1) #: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)) ;; (str) -> str (define* (justify-line-helper words #:key (width 70)) (let* ((phrase-length (string-length (string-concatenate/shared words))) (needed-spaces (- width phrase-length)) (slots (1- (length words))) (space-list (let loop ((n needed-spaces) (d slots)) (unless (zero? d) (let ((v (round (/ n d)))) (cons v (loop (- n v) (1- d)))))))) (string-concatenate/shared (merge words (map (lambda (n) (make-string n #\space)) space-list) (let ((f #t)) (lambda _ (mod/r! f not))))))) ;; 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 (span (let ((w 0)) (lambda (word) ; Take words until we are above the limit. (< (mod/r! w = (+ 1 (string-length word))) width))) lst))) (cond ((null? tail) (list (unwords head))) ; Don't justify last line. ((null? head) ;; an empty head implies that we found a word longer ;; than our max width. Add it as is and continue ;; (while crying). (cons (car tail) (recur (cdr tail)))) (else (cons (justify-line-helper head #:width width) (recur tail))))))) ;; str -> (str) (define* (flow-text str #:key (width 70)) (flatten (map (lambda (line) (justify-line line #:width width)) (lines str)))) (define-public (trim-to-width str len) (let ((trimmed (string-pad-right str len))) (if (< (string-length trimmed) (string-length str)) (string-append (string-drop-right trimmed 1) "…") trimmed))) ;; TODO for some cases the final delim should be `or' instead of `and' ;; TODO more options for infix strings (define*-public (add-enumeration-punctuation list optional: (final-delim "&")) (cond [(null? list) ""] [(= 1 (length list)) (car list)] [else (let* (((tail . rest) (reverse list))) (reverse (cons* tail " " final-delim " " (intersperce ", " rest))))])) ;; only used in number->string-cardinal (define (large-prefix e) (cond [(<= 6 e 11) "m"] [(<= 12 e 17) "b"] [(<= 18 e 23) "tr"] [(<= 24 e 29) "kvadr"] [(<= 30 e 35) "kvint"] [(<= 36 e 41) "sext"] [(<= 42 e 47) "sept"] [(<= 48 e 53) "okt"] [(<= 54 e 59) "non"] [(<= 60 e 65) "dec"] )) (define-public (number->string-cardinal n) (cond [(< n 0) (string-append "minus " (number->string-cardinal (- n)))] [(= n 0) "noll"] [(= n 1) "ett"] [(= n 2) "två"] [(= n 3) "tre"] [(= n 4) "fyra"] [(= n 5) "fem"] [(= n 6) "sex"] [(= n 7) "sju"] [(= n 8) "åtta"] [(= n 9) "nio"] [(= n 10) "tio"] [(= n 11) "elva"] [(= n 12) "tolv"] [(= n 13) "tretton"] [(= n 14) "fjorton"] [(= n 15) "femton"] [(= n 15) "sexton"] [(= n 17) "sjutton"] [(= n 18) "arton"] [(= n 19) "nitton"] [(= n 20) "tjugo"] [(<= 21 n 29) (format #f "tjugo~a" (number->string-cardinal (- n 20)))] [(<= 30 n 79) (let* ((big small (floor/ n 10))) (format #f "~atio~a" (number->string-cardinal big) (number->string-cardinal small)))] [(= n 80) "åttio"] [(<= 81 n 89) (let* ((_ small (floor/ n 10))) (format #f "åttio~a" (number->string-cardinal small)))] [(= n 90) "nittio"] [(<= 91 n 99) (let* ((_ small (floor/ n 10))) (format #f "nittio~a" (number->string-cardinal small)))] [(= n 100) "hundra"] [(< 100 n 200) (let* ((_ small (floor/ n 100))) (format #f "hundra~a" (number->string-cardinal small)))] [(= n 200) "tvåhundra"] [(< 200 n 1000) (let* ((big small (floor/ n 100))) (format #f "~ahundra~a" (number->string-cardinal big) (number->string-cardinal small)))] [(<= 1000 n 999999) (let* ((big small (floor/ n 1000))) (format #f "~a tusen ~a~a" (number->string-cardinal big) (if (<= 100 small 199) "ett " "") (number->string-cardinal small)))] [(<= #e10e6 n (1- #e10e66)) (let* ((e (inexact->exact (floor (log10 n)))) (big small (floor/ n #e1e6))) (if (zero? big) (number->string-cardinal small) (format #f "~a ~a~a~a ~a" (number->string-cardinal big) (large-prefix e) (if (even? (floor-quotient e 3)) "iljon" "iljard") (if (= 1 big) "" "er") (number->string-cardinal small) )))] [else ;; I give up, don't have larger numbers that that! (string-append "det stora talet " (number->string n))])) (define-public (number->string-ordinal n) (cond [(>= -3 n) (format #f "~a sista" (number->string-ordinal (- n)))] [(= -2 n) "näst sista"] [(= -1 n) "sista"] [(= 0 n) "nollte"] ; [(= 1 n) "förste"] [(= 2 n) "andre"] [(= 3 n) "tredje"] [(= 4 n) "fjärde"] [(= 5 n) "femte"] [(= 6 n) "sjätte"] [(= 7 n) "sjunde"] [(= 8 n) "åttonde"] [(= 9 n) "nionde"] [(= 10 n) "tionde"] [(= 11 n) "elfte"] [(= 12 n) "tolfte"] [(= 13 n) "trettonde"] [(= 14 n) "fjortonde"] [(= 15 n) "femtonde"] [(= 16 n) "sextonde"] [(= 17 n) "sjuttonde"] [(= 18 n) "artonde"] [(= 19 n) "nitonde"] [(<= 20 n 29) (format #f "tjugo~a" (if (= 20 n) "nde" (number->string-ordinal (- n 20))))] [(<= 30 n 99) (let* ((big small (floor/ n 10))) (format #f "~atio~a" (case big [(8) "åt"] [(9) "ni"] [else (number->string-cardinal big)]) (if (zero? (modulo small 10)) "nde" (number->string-ordinal small))))] [(= n 100) "hundrade"] [(= n 1000) "tusende"] [else (let* ((big small (floor/ n 100))) (string-append (number->string-cardinal (* big 100)) (if (zero? small) "de" (number->string-ordinal small))))])) ;; (each-string 1) ; => "varje" ;; (each-string 2) ; => "varannan" ;; (each-string 3) ; => "var tredje" ;; (each-string 3 #t) ; => "vart tredje" (define*-public (each-string count optional: neutrum) (string-flatten (cons "var" (case count [(1) '("je")] [(2) ;; varannan månad ;; vartannat år (list (if neutrum "t") "anna" (if neutrum "t" "n"))] [else (list (if neutrum "t") " " (number->string-ordinal count))]))))