Add new recurrence generator.

3 files changed, 342 insertions, 1 deletions

diff --git a/module/vcomponent/parse.scm b/module/vcomponent/parse.scm
index fdae22dc..e98761c7 100644
--- a/module/vcomponent/parse.scm
+++ b/module/vcomponent/parse.scm
@@ -6,6 +6,7 @@
   :use-module (datetime)
   :use-module (datetime util)
   :use-module (srfi srfi-26)
+  :use-module ((ice-9 hash-table) :select (alist->hash-table))
   :use-module ((ice-9 rdelim) :select (read-line))
   :use-module ((ice-9 textual-ports) :select (unget-char))
   :use-module ((ice-9 ftw) :select (scandir ftw))
@@ -379,6 +380,11 @@ row ~a	column ~a	ctx = ~a
                           (rest (delete head events eq?)))
 
                      (set! (attr head 'X-HNH-ALTERNATIVES)
+                       (alist->hash-table
+                        (map cons
+                             (map (extract 'RECURRENCE-ID) rest)
+                             rest))
+                       #;
                        (sort*! rest ;; HERE
                                date/-time< (extract 'RECURRENCE-ID)))
                      (add-child! calendar head))])
diff --git a/module/vcomponent/recurrence.scm b/module/vcomponent/recurrence.scm
index 12f901d2..28decce7 100644
--- a/module/vcomponent/recurrence.scm
+++ b/module/vcomponent/recurrence.scm
@@ -1,5 +1,5 @@
 (define-module (vcomponent recurrence)
-  #:use-module (vcomponent recurrence generate)
+  #:use-module (vcomponent recurrence generate-alt)
   #:use-module (vcomponent recurrence parse)
   #:use-module (vcomponent recurrence internal)
   #:re-export (generate-recurrence-set
diff --git a/module/vcomponent/recurrence/generate-alt.scm b/module/vcomponent/recurrence/generate-alt.scm
new file mode 100644
index 00000000..67dd3981
--- /dev/null
+++ b/module/vcomponent/recurrence/generate-alt.scm
@@ -0,0 +1,335 @@
+(define-module (vcomponent recurrence generate-alt)
+  :export (generate-recurrence-set)
+  :use-module (util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-26)
+  :use-module (srfi srfi-41)
+  :use-module (srfi srfi-41 util)
+  :use-module (vcomponent base)
+  :use-module (vcomponent recurrence internal)
+  :use-module (vcomponent recurrence parse)
+
+  :use-module (datetime)
+  :use-module (datetime util)
+  :use-module (ice-9 curried-definitions) )
+
+
+
+
+
+
+(eval-when (expand)
+ (define (stx->bystx syntax-fragment syntax-ctx str-transformer)
+   (->> syntax-fragment
+        syntax->datum
+        symbol->string
+        str-transformer
+        (string-append (str-transformer "by"))
+        string->symbol
+        (datum->syntax syntax-ctx))))
+
+;; a → b → (a . b)
+(define ((con x) y)
+  (cons x y))
+
+(define-syntax (by stx)
+  (syntax-case stx ()
+    [(_ type rr)
+     #`(and=> (#,(stx->bystx #'type stx string-downcase)
+               rr)
+              (cut map
+                (con (quote #,(stx->bystx #'type stx string-upcase)))
+                <>))]))
+
+
+;; (define-syntax (single-rule stx)
+;;   (syntax-case stx (when)
+;;     [(_ (when condition expr)
+;;         #`(when
+;;               #,(let-syntax ((and (syntax-rules ()
+;;                                     [(_ expr ...)
+;;                                      ]
+;;                                     ))
+;;                              (or (syntax-rules ()
+;;                                    )))
+;;                   #'condition)
+;;             expr))]
+;;     [(_ expr)
+;;      expr
+;;      ]))
+
+(define-syntax make-single-extender
+  (syntax-rules (||)
+    [(_ rr field ...)
+     (apply cross-product
+            (filter identity
+                    (list
+                     (by field rr) ...)))]))
+
+(define-syntax make-extenders
+  (syntax-rules (||)
+    [(_ rr (key || cc ...) ...)
+     (case (freq rr)
+       [(key)
+        (make-single-extender rr cc ...)] ...)]))
+
+;; TODO compliacted fields
+(define (all-extenders rrule)
+  (make-extenders
+   rrule
+   [YEARLY  || month weekno yearday monthday #| day |# hour minute second]
+   [MONTHLY || monthday #| day |# hour minute second]
+   [WEEKLY  || day hour minute second]
+   [DAILY   || hour minute second]
+   [HOURLY  || minute second]
+   [MINUTELY || second]
+   [SECONDLY || #| null |#]))
+
+;; TODO this isn't nuted for limiting, only for extension
+;; TODO I think the fix would be to not do a cross-product,
+;; but rather have a list of fileds, each with a list of values
+(define (all-limiters rrule)
+  (make-extenders
+   rrule
+   [YEARLY   ||  day #| setpos |#]
+   [MONTHLY  || month #| day |# #|setpos|#]
+   [WEEKLY   || month #|setpos|#]
+   [DAILY    || month monthday day #|setpos|#]
+   [HOURLY   || month yearday monthday day hour #|setpos|#]
+   [MINUTELY || month yearday monthday day hour minute #|setpos|#]
+   [SECONDLY || month yearday monthday day hour minute second #|setpos|#]
+   ;; [else]
+   ))
+
+(define (branching-fold proc init collection)
+  (if (null? collection)
+      init
+      (let ((v (proc (car collection) init)))
+        (if (list? v)
+            (map (lambda (c) (branching-fold proc c (cdr collection))) v)
+            (branching-fold proc v (cdr collection))))))
+
+;; TODO more special expands (p. 44)
+;; (a := (date|datetime)), rrule, extension-rule → a
+(define (update date-object rrule extension-rule)
+  ;; Branching fold instead of regular fold since BYDAY
+  ;; can extend the recurrence set in weird ways.
+  (branching-fold
+   (lambda (rule dt)
+     (let* (((key . value) rule)
+            (d (if (date? dt) dt (get-date dt)))
+            ;; NOTE It's proably an error to give BYHOUR, BYMINUTE, and BYSECOND
+            ;; rules for a date object. This doesn't warn if those are given, but
+            ;; instead silently discards them.
+            (t (as-time dt))
+            (to-dt (lambda (o)
+                     (if (date? dt)
+                         (cond [(date? o) o]
+                               [(time? o) d]
+                               [else (error "faoeuhtnsaoeu htnaoeu" )])
+                         (cond [(date? o) (datetime date: o time: t tz: (get-timezone dt))]
+                               [(time? o) (datetime date: d time: o tz: (get-timezone dt))]
+                               [else (error "faoeuhtnsaoeu htnaoeu" )])))))
+       (case key
+         [(BYMONTH)
+          (if (and (eq? 'YEARLY (freq rrule))
+                   (byday rrule)
+                   (not (or (byyearday rrule)
+                            (bymonthday rrule))))
+              (map to-dt
+                   (concatenate
+                    (map (lambda (wday)
+                           (all-wday-in-month
+                            wday (set (month d) value)))
+                         (map cdr (byday rrule)))))
+
+              ;; else
+              (to-dt (set (month d) value)))]
+
+         [(BYDAY)
+          (let* (((offset . value) value))
+            (case (freq rrule)
+              [(WEEKLY)
+               ;; set day to that day in the week which d lies within
+               (to-dt (date+ (start-of-week d (wkst rrule))
+                             ;; TODO check that this actually is the correct calculation
+                             (date day: (modulo (- value (wkst rrule))
+                                                7))))]
+              [(MONTHLY)
+               ;; TODO
+               dt
+               ]
+              [(YEARLY)
+               ;; TODO
+               dt
+               ]))
+          ]
+         [(BYWEEKNO)
+          (to-dt (date-starting-week value d (wkst rrule)))]
+         [(BYYEARDAY) (to-dt (date+ (start-of-year d) (date day: value)))]
+         [(BYMONTHDAY) (to-dt (set (day d) value))]
+         [(BYHOUR) (to-dt (set (hour t) value))]
+         [(BYMINUTE) (to-dt (set (minute t) value))]
+         [(BYSECOND) (to-dt (set (second t) value))]
+         [else (error "Unrecognized by-extender" key)])))
+   date-object
+   extension-rule))
+
+
+(define (make-date-increment rr)
+  (case (freq rr)
+    [(YEARLY)   (datetime date: (date year: (interval rr)))]
+    [(MONTHLY)  (datetime date: (date month: (interval rr)))]
+    ;; please say that a week has always seven days...
+    [(WEEKLY)   (datetime date: (date day: (* 7 (interval rr))))]
+    [(DAILY)    (datetime date: (date day: (interval rr)))]
+    [(HOURLY)   (datetime time: (time hour: (interval rr)))]
+    [(MINUTELY) (datetime time: (time minute: (interval rr)))]
+    [(SECONDLY) (datetime time: (time second: (interval rr)))]
+    [else (error "Bad freq")]))
+
+;; NOTE
+;; [3.8.5.3. description]
+;; The initial DTSTART SHOULD be synchronized with the RRULE.
+;; An unsynchronized DTSTART/RRULE results in an undefined recurrence set.
+
+;; TODO ought to be [rrule, a → (stream a)] where a := (date | datetime)
+;; rrule, date → (stream datetime)
+(define-stream (extend-recurrence-set rrule base-date)
+  (stream-append
+   ;; If no BY-rules are present just add the base-date to the set.
+   ;; NOTE a possible alternative version (which would probably be better)
+   ;; would be to always add the base-date to the set, and make sure that the
+   ;; updated date ≠ base-date
+   ;; A third alternative would be to add a by rule for the current type. for example:
+   ;; FREQ=MONTHLY => BYMONTHDAY=(day base-date)
+   (if (null? (all-extenders rrule))
+       (stream base-date)
+       ;; NOTE weird stream->list stuff since a regular
+       ;; interleave currently is unwritten.
+       (interleave-streams
+        (if (date? base-date) date< datetime<)
+        (map (lambda (ext)
+               (list->stream (let ((v (update base-date rrule ext)))
+                               (if (list? v) v (list v)))))
+             (all-extenders rrule))))
+   (extend-recurrence-set
+    rrule
+    (if (date? base-date)
+        (date+ base-date (get-date (make-date-increment rrule)))
+        (datetime+ base-date (make-date-increment rrule))))
+   ))
+
+
+;; limiters → (a → bool)
+(define (limiters->predicate limiters)
+  (lambda (dt)
+   (let loop ((remaining limiters))
+     (if (null? remaining)
+         #t
+         (let* (((key . value) (car remaining))
+                (t (as-time dt))
+                (d (if (date? dt) dt (get-date dt))))
+           (and (case key
+                  [(BYMONTH) (eqv? value (month d))]
+                  [(BYMONTHDAY) (eqv? value (day d))]
+                  [(BYYEARDAY) (eqv? value (year-day d))]
+                  ;; TODO special cases?
+                  [(BYDAY) (eqv? (cdr value) (week-day d))]
+                  [(BYHOUR) (eqv? value (hour t))]
+                  [(BYMINUTE) (eqv? value (minute t))]
+                  [(BYSECOND) (eqv? value (second t))]
+                  ;; TODO
+                  ;; [(BYSETPOS)]
+                  [else
+                   (error "Unknown by-limiter")])
+                (loop (cdr remaining))))))))
+
+
+(define-stream (limit-recurrence-set rrule date-stream)
+  ;; TODO BYSETPOS
+  (stream-filter
+   ;; filter inlavid datetimes (feb 30, times droped due to zone-shift, ...)
+   (lambda (dt)
+     (let ((d (as-date dt))
+           (t (as-time dt)))
+       (and (<= 0 (hour t) 23)
+            (<= 0 (minute t) 59)
+            (<= 0 (second t) 60)
+            (<= 1 (month d) 12)
+            (<= 1 (day d) (days-in-month d)))))
+   (stream-filter
+    ;; TODO fix limiter generation
+    ;; ===========================
+    (limiters->predicate (car (append (all-limiters rrule) '(()))))
+    date-stream)))
+
+(define-stream (generate-posibilities rrule base-date)
+  (limit-recurrence-set
+   rrule
+   (extend-recurrence-set
+    rrule base-date)))
+
+(define-stream (rrule-instances event)
+  (define rrule  (parse-recurrence-rule
+                  (attr event 'RRULE)
+                  (if (date? (attr event 'DTSTART))
+                      parse-ics-date parse-ics-datetime)))
+
+  ;; 3.8.5.1 exdate are evaluated AFTER rrule (and rdate)
+  (let ((date-stream (stream-remove
+                      (cut member <> (or (attr event 'EXDATE) '()))
+                      (generate-posibilities rrule (attr event 'DTSTART))
+                      ;; TODO ideally I should merge the limited recurrence set
+                      ;; with the list of rdates here. However, I have never
+                      ;; sen an event with an RDATE attribute, so I wont worry
+                      ;; about it for now.
+                      ;; (stream-merge (list->stream (#|rdate's|#))
+                      )))
+    (cond [(count rrule) => (lambda (c) (stream-take c date-stream))]
+          [(until rrule) => (lambda (end) (stream-take-while
+                                      (cut (if (date? (attr event 'DTSTART)) date<= datetime<=) <> end)
+                                      date-stream))]
+          [else date-stream])))
+
+(define (generate-recurrence-set base-event)
+
+
+  (define duration
+    ;; NOTE DTEND is an optional field. However, my current configuration for
+    ;; the parser always adds a DTEND field.
+    (let ((end (attr base-event 'DTEND)))
+      (if (date? end)
+          (date-difference end (attr base-event 'DTSTART))
+          (datetime-difference end (attr base-event 'DTSTART)))))
+
+  (define rrule-stream (rrule-instances base-event))
+
+  (stream-map
+   (aif (attr base-event 'X-HNH-ALTERNATIVES)
+        (lambda (dt)
+          (aif (hash-ref it dt)
+               it ; RECURRENCE-ID objects come with their own DTEND
+               (let ((ev (copy-vcomponent base-event)))
+                 (set! (attr ev 'DTSTART) dt
+                       ;; p. 123 (3.8.5.3 Recurrence Rule)
+                       ;; specifies that the DTEND should be updated to match how the
+                       ;; initial dtend related to the initial DTSTART. It also notes
+                       ;; that an event of 1 day in length might be longer or shorter
+                       ;; than 24h depending on timezone shifts.
+                       (attr ev 'DTEND) ((cond [(date? dt) date+]
+                                               [(datetime? dt) datetime+]
+                                               [else (error "Bad type")])
+                                         dt duration))
+                 ev)))
+        (lambda (dt)
+          (let ((ev (copy-vcomponent base-event)))
+            (set! (attr ev 'DTSTART) dt
+                  (attr ev 'DTEND) ((cond [(date? dt) date+]
+                                          [(datetime? dt) datetime+]
+                                          [else (error "Bad type")])
+                                    dt duration)
+                  )
+            ev)))
+   rrule-stream))
+