From a89a4b152fda1c6346e82ea92af498fcfbc53089 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Fri, 27 Oct 2023 16:08:39 +0200 Subject: Add proper text calendar. Previously the program `cal` was used, this was slow and unreliable. --- module/calp/terminal.scm | 4 +- module/text/calendar.scm | 86 +++++++++++++++++++++++++++++++++++++++ module/vulgar/components.scm | 17 -------- tests/unit/text/text-calendar.scm | 83 +++++++++++++++++++++++++++++++++++++ 4 files changed, 171 insertions(+), 19 deletions(-) create mode 100644 module/text/calendar.scm delete mode 100644 module/vulgar/components.scm create mode 100644 tests/unit/text/text-calendar.scm diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm index c4b30a54..395c85d6 100644 --- a/module/calp/terminal.scm +++ b/module/calp/terminal.scm @@ -10,7 +10,6 @@ :use-module (vulgar) :use-module (vulgar info) :use-module (vulgar color) - :use-module (vulgar components) :use-module (vcomponent) :use-module (vcomponent datetime) @@ -18,6 +17,7 @@ :use-module (vcomponent util group) :use-module (text util) + :use-module ((text calendar) :select (cal-3)) :use-module (text flow) :use-module (ice-9 format) @@ -127,7 +127,7 @@ (display (G_ "== Day View ==")) (newline) - (display-calendar-header! (current-page this)) + (cal-3 (current-page this)) ;; display event list (display-event-table diff --git a/module/text/calendar.scm b/module/text/calendar.scm new file mode 100644 index 00000000..79341114 --- /dev/null +++ b/module/text/calendar.scm @@ -0,0 +1,86 @@ +(define-module (text calendar) + :use-module (srfi srfi-1) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module ((hnh util) :select (when unless group ->)) + :use-module ((hnh util lens) :select (modify)) + :use-module ((hnh util io) :select (displayln)) + :use-module (hnh util type) + :use-module (ice-9 format) + :use-module ((texinfo string-utils) :select (center-string)) + :use-module (datetime) + :use-module ((text util) :select (unwords)) + :export (graphical-calendar cal-3)) + +;; Done manually rather than through vulgar, so the text +;; utilities can become standalone. +(define (ansi-invert str) + (format #f "\x1b[7m~a\x1b[m" str)) + +(define line-length (+ 6 (* 7 2))) +(define placeholder (gensym)) + +;;; Always returns 8 lines +;;; All lines are exactly 20 characters +(define* (graphical-calendar target-date + key: + (wkst mon) + (highlight-proc ansi-invert)) + (typecheck target-date date?) + (typecheck target-date (or false? date?)) + + ;; Date which starts the target month + (define month-start (start-of-month target-date)) + + ;; Number of days in the current way which is part of the previous month. + (define to-skip (modulo (- (week-day (day target-date 1)) wkst) 7)) + + (define lines ; (list-of (list-of (or integer? (eq? placeholder)))) + (let ((lines trail (floor/ (- (days-in-month target-date) + (- 7 to-skip)) + 7))) + (append + (list (append (make-list to-skip placeholder) (iota (- 7 to-skip) 1))) + (group (iota (* 7 lines) (1+ (- 7 to-skip))) 7) + (list (append (iota trail (+ 1 (* 7 lines) (- 7 to-skip)) ) + (make-list (- 7 trail) placeholder))) + (when (= 3 lines) + (list (make-list 7 placeholder)))))) + + (append + ;; Month and year declaration + (list (center-string (date->string target-date "~B ~Y") + line-length)) + ;; Names of week days + (list (unwords + (map (lambda (d) (string-pad (week-day-name d 2) 2)) + (weekday-list wkst)))) + + (map (lambda (group) + (unwords + (map (lambda (entry) + (cond ((and (integer? entry) + (= entry (day target-date))) + (highlight-proc (format #f "~2d" entry))) + ((integer? entry) + (format #f "~2d" entry)) + (else " "))) + group))) + lines))) + + +(define* (cal-3 optional: (d (current-date))) + (typecheck d date?) + ;; Day is set to one for month arithmetic, + ;; and then to zero to not highlight any day + (for-each displayln + (map string-append + (graphical-calendar (-> d (day 1) + (date- (date month: 1)) + (day 0))) + (make-list 8 " ") + (graphical-calendar d) + (make-list 8 " ") + (graphical-calendar (-> d (day 1) + (date+ (date month: 1)) + (day 0)))))) diff --git a/module/vulgar/components.scm b/module/vulgar/components.scm deleted file mode 100644 index 74420f18..00000000 --- a/module/vulgar/components.scm +++ /dev/null @@ -1,17 +0,0 @@ -(define-module (vulgar components) - :use-module (datetime) - :use-module (hnh util) - :export (display-calendar-header!)) - -(define (display-calendar-header! date) - (let ((day (number->string (day date))) - (month (number->string (month date))) - (year (number->string (year date)))) - ;; BSD cal only supports setting highlighted day explicitly for - ;; testing the functionality. This seems to at least give me - ;; an (almost) working display, albeit ugly. - (if (file-exists? "/usr/bin/ncal") - (system* "ncal" "-3" "-H" (date->string date) - month year) - (system* "cal" "-3" day month year)))) - diff --git a/tests/unit/text/text-calendar.scm b/tests/unit/text/text-calendar.scm new file mode 100644 index 00000000..43064ad1 --- /dev/null +++ b/tests/unit/text/text-calendar.scm @@ -0,0 +1,83 @@ +(define-module (test text-calendar) + :use-module (srfi srfi-64) + :use-module (srfi srfi-71) + :use-module (srfi srfi-88) + :use-module (datetime) + :use-module (text calendar)) + +;;; TODO these tests are locale-dependant + +(test-equal "Start and end week are partial" + '(" oktober 2023 " + "må ti on to fr lö sö" + " 1" + " 2 3 4 5 6 7 8" + " 9 10 11 12 13 14 15" + "16 17 18 19 20 21 22" + "23 24 25 26 27 28 29" + "30 31 ") + (graphical-calendar (date year: 2023 month: oct) wkst: mon)) + +(test-equal "End week is full, start is partial" + '(" april 2023 " + "må ti on to fr lö sö" + " 1 2" + " 3 4 5 6 7 8 9" + "10 11 12 13 14 15 16" + "17 18 19 20 21 22 23" + "24 25 26 27 28 29 30" + " ") + (graphical-calendar (date year: 2023 month: apr) wkst: mon)) + +(test-equal "Start week is full, end is partial" + '(" oktober 2023 " + "sö må ti on to fr lö" + " 1 2 3 4 5 6 7" + " 8 9 10 11 12 13 14" + "15 16 17 18 19 20 21" + "22 23 24 25 26 27 28" + "29 30 31 " + " ") + (graphical-calendar (date year: 2023 month: oct) wkst: sun)) + +(test-equal "Exact lineup" + '(" februari 1800 " + "to fr lö sö må ti on" + " 1 2 3 4 5 6 7" + " 8 9 10 11 12 13 14" + "15 16 17 18 19 20 21" + "22 23 24 25 26 27 28" + " " + " ") + (graphical-calendar (date year: 1800 month: feb) wkst: thu)) + +(test-equal "Exact lineup" + '(" februari 1800 " + "to fr lö sö må ti on" + " 1 2 3 4 5 6 7" + " 8 9 10 11 12 13 14" + "15 16 17 \x1b[7m18\x1b[m 19 20 21" + "22 23 24 25 26 27 28" + " " + " ") + (graphical-calendar (date year: 1800 month: feb day: 18) wkst: thu)) + + + +;;; This also tests that month overflow into next year works +(test-equal "Displayed calendar + overflowing into next year" + (string-append + " november 2023 december 2023 januari 2024 \n" + "må ti on to fr lö sö må ti on to fr lö sö må ti on to fr lö sö\n" + " 1 2 3 4 5 1 2 3 1 2 3 4 5 6 7\n" + " 6 7 8 9 10 11 12 4 5 6 7 8 9 10 8 9 10 11 12 13 14\n" + "13 14 15 16 17 18 19 11 12 13 14 15 16 17 15 16 17 18 19 20 21\n" + "20 21 22 23 24 25 26 18 19 20 21 22 23 24 22 23 24 25 26 27 28\n" + "27 28 29 30 25 26 27 28 29 30 31 29 30 31 \n" + " \n") + (with-output-to-string + (lambda () + (cal-3 (date year: 2023 month: dec))))) + + +'((text calendar)) -- cgit v1.2.3