diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-23 17:08:27 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2019-04-23 17:08:27 +0200 |
commit | 55d3eb755b32b782e731f219383a4c3872bc2913 (patch) | |
tree | 916f8ed3aec233f43ed2a425a2b4c85cbff67ff3 | |
parent | Add some utilitiy functions. (diff) | |
download | calp-55d3eb755b32b782e731f219383a4c3872bc2913.tar.gz calp-55d3eb755b32b782e731f219383a4c3872bc2913.tar.xz |
Rewrote fix-event-widths!
Diffstat (limited to '')
-rw-r--r-- | module/html/html.scm | 44 |
1 files changed, 24 insertions, 20 deletions
diff --git a/module/html/html.scm b/module/html/html.scm index 3546a476..6c77030b 100644 --- a/module/html/html.scm +++ b/module/html/html.scm @@ -5,12 +5,12 @@ #:use-module (vcalendar) #:use-module (vcalendar datetime) #:use-module (util) + #:use-module (util tree) #:use-module (srfi srfi-19) #:use-module (srfi srfi-19 util) ) - (define-stream (group-stream in-stream) (define (ein? day) (lambda (e) (event-in? e (date->time-utc day)))) @@ -34,23 +34,27 @@ (define x-pos (make-object-property)) (define width (make-object-property)) -;; Takes a list of vcomponents. -;;; And makes each sublist have better laid out elements. -;;; It's not perfect if there are many elements that overlap -;;; In different ways. But it works perfectly for a block -;;; schedule! -(define (fix-event-widths! ev-list) - (if (null? ev-list) - #f - (let* ((pred? (lambda (next) - (time<? (attr next 'DTSTART) - (attr (car ev-list) 'DTEND)))) - (overlapping (take-while pred? ev-list)) - (rest (drop-while pred? ev-list))) - (for-each (lambda (o x) (set! (x-pos o) x)) overlapping (iota (length overlapping))) - (for-each (lambda (o) (set! (width o) (/ (length overlapping)))) - overlapping) - (fix-event-widths! rest)))) +;; Takes a list of vcomponents, sets their widths and x-positions to optimally +;; fill out the space, without any overlaps. +(define (fix-event-widths! 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>? event-length)))) (define (time->decimal-hour time) "This should only be used on time intervals, @@ -75,7 +79,7 @@ never on absolute times. For that see date->decimal-hour" 0) ;; left - (* 100 (width ev) (x-pos ev)) + (* 100 (x-pos ev)) ;; height (* (/ 24) 100 @@ -169,7 +173,7 @@ never on absolute times. For that see date->decimal-hour" (filter-sorted-stream (compose (in-date-range? (d "2019-04-15") - (d "2019-04-22")) + (d "2019-05-10")) car) (group-stream events))))))))) |