; Datebook access
; $Rev: 9 $

; (reduce f 0 '(1 2 3)) -> f(f(f(0, 1), 2), 3)
(define (reduce f init lst)
  (do ((res init (f res (car ls)))
       (ls lst (cdr ls)))
      ((null? ls) res)))

(define (dbdb-rec-times buf)
  (list (buf-get-date buf 4)            ; Date (start & end)
        (buf-get-time buf 0)            ; Start time
        (buf-get-time buf 2)))          ; End time

(define (dbdb-rec-desc buf)
  (let* ((flag-alist '((#x40 . 2) (#x20 . 8)))
         (flags (buf-get-u8 buf 6))
         (except-offset (reduce (lambda (s p)
                                  (if (= 0 (bit-and flags (car p)))
                                      s
                                      (+ s (cdr p))))
                                8 flag-alist))
         (descr-offset (if (= 0 (bit-and flags #x8))
                           except-offset
                           (+ except-offset 2
                              (* 2 (buf-get-u16 buf except-offset))))))
    (if (= 0 (bit-and flags #x4))
        ""
        (buf-get-cstr buf descr-offset))))

(define (dbdb-n-map f)
  (let* ((db (dm-open-db "DatebookDB" 1))
         (nrec (car (dm-db-size db))))
    (do ((i 0 (+ i 1))
         (lst '() (let ((rec (dm-read-rec db i)))
                    (if rec
                        (cons (f i rec) lst)
                        lst))))
        ((>= i nrec)
         (dm-close-db db)
         (reverse! lst)))))

(define (dbdb-map f)
  (dbdb-n-map (lambda (n buf) (f buf))))

(define (time< a b)
  (let ((ha (time-hour a))
        (hb (time-hour b)))
    (cond ((< ha hb) #t)
          ((> ha hb) #f)
          (else (< (time-minute a) (time-minute b))))))

(define (dbdb< a b)
  (let ((dd (date-diff (car a) (car b))))
    (cond ((< dd 0) #t)
          ((> dd 0) #f)
          (else ((lexcmp time< time< <) (cdr a) (cdr b))))))

(define (dbdb-events)
  (sort (dbdb-map (lambda (buf)
                    (append (dbdb-rec-times buf)
                            (list (dbdb-rec-desc buf)))))
        dbdb<))

(define (dbdb-show events)
  (do ((evs events (cdr evs)))
      ((null? evs) #n)
    (let ((ev (car evs)))
      (display (car ev))
      (display " ")
      (display (cadr ev))
      (display "-")
      (display (caddr ev))
      (newline)
      (display (substring (cadddr ev) 0 40))
      (newline))))

; Bug: does not find repeating events.
(define (dbdb-week)
  (let ((today (ts->date (current-ts))))
    (filter! (lambda (rec)
                     (let ((d (date-diff (car rec) today)))
                       (and (<= 0 d) (<= d 6))))
                   (dbdb-events))))

(define (dbdb-dupes)
  (dupes (dbdb-events) equal?))