Move stuff from main.

3 files changed, 287 insertions, 0 deletions

diff --git a/module/output/general.scm b/module/output/general.scm
new file mode 100644
index 00000000..f455f18b
--- /dev/null
+++ b/module/output/general.scm
@@ -0,0 +1,10 @@
+(define-module (output general)
+  )
+
+(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)))
diff --git a/module/output/html.scm b/module/output/html.scm
new file mode 100644
index 00000000..3df3c713
--- /dev/null
+++ b/module/output/html.scm
@@ -0,0 +1,164 @@
+(define-module (output html)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-41)
+  #:use-module (srfi srfi-41 util)
+  #:use-module (vcomponent)
+  #:use-module (vcomponent datetime)
+  #:use-module (util)
+  #:use-module (util tree)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 util)
+
+  #:use-module (parameters)
+  #:use-module (config))
+
+(define-stream (group-stream in-stream)
+  (define (ein? day) (lambda (e) (event-in? e (date->time-utc day))))
+
+  (let loop ((days (day-stream (time-utc->date (attr (stream-car in-stream) 'DTSTART))))
+             (stream in-stream))
+    (if (stream-null? stream)
+        stream-null
+        (let* ((day (stream-car days))
+               (tomorow (add-day (date->time-utc (drop-time day)))))
+          (let ((head (stream-take-while (ein? day) stream))
+                (tail
+                 (filter-sorted-stream*
+                  (lambda (e) (time<? tomorow (attr e 'DTEND)))
+                  (lambda (e) (time<=? tomorow (attr e 'DTSTART)))
+                  stream)))
+
+            (stream-cons (cons day head)
+                         (loop (stream-cdr days)
+                               tail)))))))
+
+(define x-pos (make-object-property))
+(define width (make-object-property))
+
+;; Takes a list of vcomponents, sets their widths and x-positions to optimally
+;; fill out the space, without any overlaps.
+(define (fix-event-widths! start-of-day lst)
+
+  ;; @var{x} is how for left in the container we are.
+  (define (inner x tree)
+    (if (null? tree) #f
+        (let ((w (/ (- 1 x)
+                    (+ 1 (length-of-longst-branch (left-subtree tree))))))
+          (set! (width (car tree)) w
+                (x-pos (car tree)) x)
+          (inner (+ x w) (left-subtree tree))
+          (inner x (right-subtree tree)))))
+
+  (inner 0 (make-tree (lambda (head e) (overlapping? head e))
+                        ;; The tree construction is greedy. This means
+                        ;; that if  a smaller  event preceeds a longer
+                        ;; event it would capture  the longer event to
+                        ;; only find  events which  also overlaps  the
+                        ;; smaller event.
+                      (sort* lst time>? (lambda (e) (event-length/day e start-of-day))))))
+
+;; This should only be used on time intervals, never on absolute times.
+;; For that see @var{date->decimal-hour}.
+(define (time->decimal-hour time)
+  (exact->inexact (/ (time-second time)
+                     3600)))
+
+(define (html-attr str)
+  (define cs (char-set-adjoin char-set:letter+digit #\- #\_))
+  (string-filter (lambda (c) (char-set-contains? cs c)) str))
+
+(define (vevent->sxml day ev)
+  (define time (date->time-utc day))
+  (define style
+    (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;"
+
+            (* 100 (x-pos ev))          ; left
+            (* 100 (width ev))          ; width
+
+            ;; top
+            (if (in-day? day (attr ev 'DTSTART))
+                (* 100/24
+                   (time->decimal-hour
+                    (time-difference (attr ev 'DTSTART)
+                                     (start-of-day* (attr ev 'DTSTART)))))
+                0)
+
+            ;; height
+            (* 100/24 (time->decimal-hour (event-length/day ev time)))))
+
+  `(div (@ (class "event CAL_" ,(html-attr (let ((l (attr (parent ev) 'NAME)))
+                                             (if (pair? l) (car l) l)))
+             ,(if (time<? (attr ev 'DTSTART) time)
+                  " continued" "")
+             ,(if (time<? (add-day time) (attr ev 'DTEND))
+                  " continuing" ""))
+           (style ,style))
+        ,((summary-filter) ev (attr ev 'SUMMARY))))
+
+(define (lay-out-day day)
+  (let* (((date . events) day))
+    ;; (format (current-error-port) "Processing ~a~%" (date->string date))
+    (fix-event-widths! (date->time-utc date) (stream->list events))
+    `(div (@ (class "day"))
+          (div (@ (class "meta"))
+               (span (@ (class "dayname")) ,(date->string date "~a"))
+               (span (@ (class "daydate")) ,(date->string date "~Y-~m-~d")))
+          (div (@ (class "events"))
+               " "
+               ,@(stream->list (stream-map (lambda (e) (vevent->sxml date e)) events))))))
+
+
+(define (time-marker-div)
+  (map (lambda (time)
+         `(div (@ (id ,(string-append "clock-" time))
+                  (class "clock"))
+               ,(string-append time ":00")))
+       (map number->string (iota 12 0 2))))
+
+(define (d str)
+  (string->date str "~Y-~m-~d"))
+
+
+(define (calculate-fg-color c)
+  (define (str->num c n) (string->number (substring/shared c n (+ n 2)) 16))
+  (let ((r (str->num c 1))
+        (g (str->num c 3))
+        (b (str->num c 5)))
+    (if (< 1/2 (/ (+ (* 0.299 r)
+                     (* 0.587 g)
+                     (* 0.144 b))
+                  #xFF))
+        "black" "#e5e8e6")))
+
+(define (include-css path)
+  `(link (@ (type "text/css")
+            (rel "stylesheet")
+            (href ,path))))
+
+(define-public (html-main calendars events args)
+
+  (define evs
+    (filter-sorted-stream
+     (compose (in-date-range?
+               (d "2019-04-15")
+               (d "2019-05-10"))
+              car)
+     (group-stream events)))
+
+  ((@ (sxml simple) sxml->xml)
+   `(html (head
+           (title "Calendar")
+           (meta (@ (charset "utf-8")))
+           ,(include-css "static/style.css")
+           (style ,(format #f "~:{.CAL_~a { background-color: ~a; color: ~a }~%~}"
+                           (map (lambda (c)
+                                  (list (html-attr (if (pair? (attr c 'NAME))
+                                                       (car (attr c 'NAME))
+                                                       (attr c 'NAME)))
+                                        (or (attr c 'COLOR) "white")
+                                        (or (and=> (attr c 'COLOR) calculate-fg-color) "black")))
+                                calendars))))
+          (body (div (@ (class "calendar"))
+                     ,@(time-marker-div)
+                     (div (@ (class "days"))
+                          ,@(stream->list (stream-map lay-out-day evs))))))))
diff --git a/module/output/terminal.scm b/module/output/terminal.scm
new file mode 100644
index 00000000..1d49896c
--- /dev/null
+++ b/module/output/terminal.scm
@@ -0,0 +1,113 @@
+(define-module (output terminal)
+  #:use-module (output general)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 util)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-41)
+  #:use-module (srfi srfi-41 util)
+  #:use-module (util)
+  #:use-module (terminal escape)
+  #:use-module (terminal util)
+  #:use-module (vcomponent output)
+
+  #:use-module (vcomponent)
+  #:use-module (vcomponent datetime)
+
+  #:use-module (texinfo string-utils)     ; string->wrapped-lines
+  #:use-module (ice-9 format)
+  #:use-module (parameters)
+  #:use-module (config)
+
+  #:export (terminal-main))
+
+(define (box-top intersection line . lengths)
+  (reduce (lambda (str done) (string-append done (string intersection) str))
+          "" (map (cut make-string <> line) lengths)))
+
+(define (display-event-table cur-event events)
+ (for-each
+  (lambda (ev i)
+    (format #t "~a │ ~a~a~a~a │ ~a~a~%"
+            (time->string (attr ev 'DTSTART) "~1 ~3") ; TODO show truncated string
+            (if (= i cur-event) "\x1b[7m" "")
+            (color-escape (attr (parent ev) 'COLOR))
+            ;; Summary filter is a hook for the user
+            (trim-to-width ((summary-filter) ev (attr ev 'SUMMARY)) 30)
+            STR-RESET
+            (trim-to-width
+             (or (attr ev 'LOCATION) "\x1b[1;30mINGEN LOKAL") 20)
+            STR-RESET))
+  events
+  (iota (length events))))
+
+(define (now)
+  (date->time-utc (current-date)))
+
+(define (displayln a)
+  (display a) (newline))
+
+(define (main-loop event-stream)
+  (define time (now))
+  (define cur-event 0)
+  (while #t
+    (let ((events
+           (stream->list
+            (filter-sorted-stream
+             (cut event-in? <> time)
+             event-stream))))
+
+      (cls)
+      (display-calendar-header! (time-utc->date time))
+
+      (displayln (box-top #\┬ #\─ 20 32 10))
+      (display-event-table cur-event events)
+      (displayln (box-top #\┴ #\─ 20 32 10))
+
+      (unless (null? events)
+        (let ((ev (list-ref events cur-event)))
+          (format #t "~a~%~a~%~aStart: ~a	Slut: ~a~%~%~a~%"
+                  (attr ev 'X-HNH-FILENAME)
+                  (attr ev 'SUMMARY)
+                  (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))
+                  )))
+
+      (let ((char (read-char)))
+        ;; (format (current-error-port)
+        ;;         "c = ~c (~d)~%" char (char->integer char))
+        (case char
+          ((#\L #\l)
+           (set! time (add-day time)
+                 cur-event 0))
+          ((#\h #\H)
+           (set! time (remove-day time)
+                 cur-event 0))
+          ((#\t)
+           (set! time (now)
+                 cur-event 0))
+          ((#\j #\J) (unless (= cur-event (1- (length events)))
+		       (mod! cur-event 1+)))
+          ((#\k #\K) (unless (= cur-event 0)
+		       (mod! cur-event 1-)))
+          ((#\p) (print-vcomponent (list-ref events cur-event)
+                                   (current-error-port)))
+	  ((#\g) (set! cur-event 0))
+	  ((#\G) (set! cur-event (1- (length events)))))
+
+        (when (or (eof-object? char)
+                  (memv char (list #\q (ctrl #\C))))
+          (break)))
+      )))
+
+(define (terminal-main calendars events args)
+  (with-vulgar
+   (lambda () (main-loop events))))