diff options
Diffstat (limited to 'module/vcomponent/util/group.scm')
-rw-r--r-- | module/vcomponent/util/group.scm | 71 |
1 files changed, 71 insertions, 0 deletions
diff --git a/module/vcomponent/util/group.scm b/module/vcomponent/util/group.scm new file mode 100644 index 00000000..f328cd18 --- /dev/null +++ b/module/vcomponent/util/group.scm @@ -0,0 +1,71 @@ +(define-module (vcomponent util group) + #:use-module (vcomponent) + #:use-module (vcomponent datetime) + #:use-module (datetime) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-41 util) + #:export (group-stream get-groups-between)) + +;; TODO templetize this +(define-stream (group-stream in-stream) + (define (ein? day) (lambda (e) (event-contains? e day))) + + (if (stream-null? in-stream) + stream-null + (let loop ((days (day-stream (as-date (prop (stream-car in-stream) 'DTSTART)))) + (stream in-stream)) + (let* ((day (stream-car days)) + (tomorow (stream-car (stream-cdr days)))) + + (let ((head (stream-take-while (ein? day) stream)) + (tail + ;; This is a filter, instead of a stream-span together with head, + ;; since events can span multiple days. + ;; This starts with taking everything which end after the beginning + ;; of tommorow, and finishes with the rest when it finds the first + ;; object which begins tomorow (after midnight, exclusize). + (filter-sorted-stream* + (lambda (e) (date/-time<? tomorow + (or (prop e 'DTEND) + (if (date? (prop e 'DTSTART)) + (date+ (prop e 'DTSTART) (date day: 1)) + (prop e 'DTSTART))))) + (lambda (e) (date/-time<=? tomorow (prop e 'DTSTART))) + stream))) + + + (stream-cons (cons day head) + (loop (stream-cdr days) + tail))))))) + +(define (get-groups-between groups start-date end-date) + + (define good-part + (filter-sorted-stream + (compose (in-date-range? start-date end-date) + car) + groups)) + + ;; NOTE slightly ugly hack. The first element in the return of group-stream shares + ;; it's date component with the lowest dtstart in the event set. This means that a + ;; group set might start after our start- (and end-!) date. + ;; To combat this I simple create a bunch of dummy groups below. + + (cond [(stream-null? good-part) + (list->stream + (map (lambda (d) (cons d stream-null)) + (date-range start-date end-date)))] + [(car (stream-car good-part)) + (lambda (d) (date< start-date d)) + => (lambda (d) + (stream-append + (list->stream + (map (lambda (d) (cons d stream-null)) + (date-range start-date + (date- d (date day: 1))))) + good-part))] + [else good-part])) + + +(define-public (group->event-list group) + (stream->list (cdr group))) |