schedule-segments-until and schedule-extract-until!

[8sync.git] / loopy.scm

diff --git a/loopy.scm b/loopy.scm
index 405ede178c363e3ec01753b24d428bca4e21bd18..7172e9b57b3a6d7cefcaad6fe29c00248f3c6bd1 100644 (file)
--- a/loopy.scm
+++ b/loopy.scm
@@ -3,6 +3,7 @@
   #:use-module (srfi srfi-9 gnu)
   #:use-module (ice-9 q)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
   #:export (make-agenda
             agenda?
             agenda-queue agenda-prompt-tag
@@ -14,10 +15,13 @@
             time-segment?
             time-segment-time time-segment-queue
 
-            time-< time-=
+            time-< time-= time-<=
 
             make-schedule
             schedule-add! schedule-empty?
+            schedule-segments
+
+            schedule-segments-until schedule-extract-until!
 
             make-port-mapping
             port-mapping-set! port-mapping-remove!
@@ -86,7 +90,7 @@
 (define (time-segment-right-format time)
   (match time
     ;; time is already a cons of second and microsecnd
-    (((? integer? s) (? integer? u)) time)
+    (((? integer? s) . (? integer? u)) time)
     ;; time was just an integer (just the second)
     ((? integer? _) (cons time 0))
     (_ (throw 'invalid-time "Invalid time" time))))
@@ -109,21 +113,96 @@
   (and (= (car time1) (car time2))
        (= (cdr time1) (cdr time2))))
 
-(define (make-schedule)
-  '())
+(define (time-<= time1 time2)
+  (or (time-< time1 time2)
+      (time-= time1 time2)))
+
+(define-record-type <schedule>
+  (make-schedule-intern segments)
+  schedule?
+  (segments schedule-segments set-schedule-segments!))
+
+(define* (make-schedule #:optional segments)
+  (make-schedule-intern (or segments '())))
 
+;; TODO: This code is reasonably easy to read but it
+;;   mutates AND is worst case of O(n) in both space and time :(
+;;   but at least it'll be reasonably easy to refactor to
+;;   a more functional setup?
 (define (schedule-add! time proc schedule)
   (let ((time (time-segment-right-format time)))
-    (define (belongs-before? segments)
-      (or (null? segments)
-          (error))
-    )
-
-  ;; Find and add a schedule segment
-  (error)))
+    (define (new-time-segment)
+      (let ((new-segment
+             (make-time-segment time)))
+        (enq! (time-segment-queue new-segment) proc)
+        new-segment))
+    (define (loop segments)
+      (define (segment-equals-time? segment)
+        (time-= time (time-segment-time segment)))
+
+      (define (segment-more-than-time? segment)
+        (time-< time (time-segment-time segment)))
+
+      ;; We could switch this out to be more mutate'y
+      ;; and avoid the O(n) of space... is that over-optimizing?
+      (match segments
+        ;; If we're at the end of the list, time to make a new
+        ;; segment...
+        ('() (cons (new-time-segment) '()))
+        ;; If the segment's time is exactly our time, good news
+        ;; everyone!  Let's append our stuff to its queue
+        (((? segment-equals-time? first) rest ...)
+         (enq! (time-segment-queue first) proc)
+         segments)
+        ;; If the first segment is more than our time,
+        ;; ours belongs before this one, so add it and
+        ;; start consing our way back
+        (((? segment-more-than-time? first) rest ...)
+         (cons (new-time-segment) segments))
+        ;; Otherwise, build up recursive result
+        ((first rest ... )
+         (cons first (loop rest)))))
+    (set-schedule-segments!
+     schedule
+     (loop (schedule-segments schedule)))))
 
 (define (schedule-empty? schedule)
-  (eq? schedule '()))
+  (eq? (schedule-segments schedule) '()))
+
+(define (schedule-segments-until schedule time)
+  "Does a multiple value return of time segments before/at and after TIME"
+  (let ((time (time-segment-right-format time)))
+    (define (segment-is-now? segment)
+      (time-= (time-segment-time segment) time))
+    (define (segment-is-before-now? segment)
+      (time-< (time-segment-time segment) time))
+
+    (let loop ((segments-before '())
+               (segments-left (schedule-segments schedule)))
+      (match segments-left
+        ;; end of the line, return
+        ('()
+         (values (reverse segments-before) '()))
+
+        ;; It's right now, so time to stop, but include this one in before
+        ;; but otherwise return
+        (((? segment-is-now? first) rest ...)
+         (values (reverse (cons first segments-before)) rest))
+
+        ;; This is prior or at now, so add it and keep going
+        (((? segment-is-before-now? first) rest ...)
+         (loop (cons first segments-before) rest))
+
+        ;; Otherwise it's past now, just return what we have
+        (segments-after
+         (values segments-before segments-after))))))
+
+(define (schedule-extract-until! schedule time)
+  "Extract all segments until TIME from SCHEDULE, and pop old segments off"
+  (receive (segments-before segments-after)
+      (schedule-split-segments-until schedule time)
+    (set-schedule-segments! schedule segments-after)
+    segments-before))
 
 
 \f