From d46183860c1f3f10095e95023adcb79b1896ab0e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Fri, 22 Mar 2019 20:11:11 +0100
Subject: Move C and Scheme code into subdirs.

---
 module/srfi/srfi-19/setters.scm | 15 ++++++++
 module/srfi/srfi-19/util.scm    | 83 +++++++++++++++++++++++++++++++++++++++++
 module/srfi/srfi-41/util.scm    | 29 ++++++++++++++
 3 files changed, 127 insertions(+)
 create mode 100644 module/srfi/srfi-19/setters.scm
 create mode 100644 module/srfi/srfi-19/util.scm
 create mode 100644 module/srfi/srfi-41/util.scm

(limited to 'module/srfi')

diff --git a/module/srfi/srfi-19/setters.scm b/module/srfi/srfi-19/setters.scm
new file mode 100644
index 00000000..45876382
--- /dev/null
+++ b/module/srfi/srfi-19/setters.scm
@@ -0,0 +1,15 @@
+(define-module (srfi srfi-19 setters) 
+  #:use-module (srfi srfi-19)           ; Date/Time
+  ;; (record-type-fields (@@ (srfi srfi-19) date))
+  #:export (nanosecond second minute hour day month year zone-offset))
+
+
+(define nanosecond (make-procedure-with-setter date-nanosecond (@@ (srfi srfi-19) set-date-nanosecond!)))
+(define second (make-procedure-with-setter date-second (@@ (srfi srfi-19) set-date-second!)))
+(define minute (make-procedure-with-setter date-minute (@@ (srfi srfi-19) set-date-minute!)))
+(define hour (make-procedure-with-setter date-hour (@@ (srfi srfi-19) set-date-hour!)))
+(define day (make-procedure-with-setter date-day (@@ (srfi srfi-19) set-date-day!)))
+(define month (make-procedure-with-setter date-month (@@ (srfi srfi-19) set-date-month!)))
+(define year (make-procedure-with-setter date-year (@@ (srfi srfi-19) set-date-year!)))
+(define zone-offset (make-procedure-with-setter date-zone-offset (@@ (srfi srfi-19) set-date-zone-offset!)))
+
diff --git a/module/srfi/srfi-19/util.scm b/module/srfi/srfi-19/util.scm
new file mode 100644
index 00000000..a4b704b0
--- /dev/null
+++ b/module/srfi/srfi-19/util.scm
@@ -0,0 +1,83 @@
+(define-module (srfi srfi-19 util)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 setters)
+  #:export (copy-date
+            drop-time! drop-time
+            in-day? today?
+            ;; seconds minutes hours days weeks
+            ;; time-add
+            make-duration
+            time->string
+            add-day remove-day))
+
+#;
+(define (copy-date date)
+  "Returns a copy of the given date structure"
+  (let* ((date-type (@@ (srfi srfi-19) date))
+         (access (lambda (field) ((record-accessor date-type field) date))))
+    (apply make-date (map access (record-type-fields date-type)))))
+
+(define (drop-time! date)
+  "Sets the hour, minute, second and nanosecond attribute of date to 0."
+  (set! (hour date) 0)
+  (set! (minute date) 0)
+  (set! (second date) 0)
+  (set! (nanosecond date) 0)
+  date)
+
+(define (drop-time date)
+  "Returns a copy of date; with the hour, minute, second and nanosecond
+attribute set to 0. Can also be seen as \"Start of day\""
+  (set-fields date
+              ((date-hour) 0)
+              ((date-minute) 0)
+              ((date-second) 0)
+              ((date-nanosecond) 0)))
+
+(define (make-duration s)
+  (make-time time-duration 0 s))
+
+(define (in-day? day-date time)
+  (let* ((now (date->time-utc (drop-time day-date)))
+         (then (add-duration now (make-duration (* 60 60 24)))))
+    (and (time<=? now time)
+         (time<=? time then))))
+
+(define (today? time)
+  (in-day? (current-date) time))
+
+(define* (time->string time #:optional (format "~1 ~3"))
+  (date->string (time-utc->date time) format))
+
+
+(define (add-day time)
+  (add-duration time (make-time time-duration 0 (* 60 60 24))))
+
+(define (remove-day time)
+  (add-duration time (make-time time-duration 0 (- (* 60 60 24)))))
+
+;;    A          B          C          D         ¬E
+;; |s1|     :     |s2| : |s1|     :     |s2| : |s1|
+;; |  |     :     |  | : |  ||s2| : |s1||  | : |  |
+;; |  ||s2| : |s1||  | : |  ||  | : |  ||  | :
+;;     |  | : |  |     : |  ||  | : |  ||  | :     |s2|
+;;     |  | : |  |     : |  |     :     |  | :     |  |
+(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
+  "Return whetever or not two timespans overlap."
+  (or
+   ;; A
+   (and (time<=? s2-begin s1-end)
+        (time<=? s1-begin s2-end))
+
+   ;; B
+   (and (time<=? s1-begin s2-end)
+        (time<=? s2-begin s1-end))
+
+   ;; C
+   (and (time<=? s1-begin s2-begin)
+        (time<=? s2-end s1-end))
+
+   ;; D
+   (and (time<=? s2-begin s1-begin)
+        (time<=? s1-end s2-end))))
diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm
new file mode 100644
index 00000000..5bef95cb
--- /dev/null
+++ b/module/srfi/srfi-41/util.scm
@@ -0,0 +1,29 @@
+(define-module (srfi srfi-41 util)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-41)
+  #:use-module (util) ; let*, find-min
+  #:export (stream-car+cdr interleave-streams))
+
+(define (stream-car+cdr stream)
+  (values (stream-car stream)
+          (stream-cdr stream)))
+
+;; Merges a number of totally ordered streams into a single
+;; totally ordered stream.
+;; ((≺, stream)) → (≺, stream)
+(define (interleave-streams < streams)
+  ;; Drop all empty streams
+  (let ((streams (remove stream-null? streams)))
+    ;; If all streams where empty, end the output stream
+    (if (null? streams)
+        stream-null
+        (let* ((min other (find-min < stream-car streams))
+               (m ms (stream-car+cdr min)))
+          (stream-cons m (interleave-streams < (cons ms other)))))))
+
+;;; Varför är allting så långsamt‽‽‽‽‽‽‽‽
+
+(define-public (filter-sorted-stream proc stream)
+  (stream-take-while
+   proc (stream-drop-while
+         (negate proc) stream)))
-- 
cgit v1.2.3