diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-22 20:11:11 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-22 20:17:52 +0100 |
commit | d46183860c1f3f10095e95023adcb79b1896ab0e (patch) | |
tree | dd331a0efe9777bfe84160139da1e39df3226b71 /module/srfi | |
parent | Add stuff to test.scm. (diff) | |
download | calp-d46183860c1f3f10095e95023adcb79b1896ab0e.tar.gz calp-d46183860c1f3f10095e95023adcb79b1896ab0e.tar.xz |
Move C and Scheme code into subdirs.
Diffstat (limited to 'module/srfi')
-rw-r--r-- | module/srfi/srfi-19/setters.scm | 15 | ||||
-rw-r--r-- | module/srfi/srfi-19/util.scm | 83 | ||||
-rw-r--r-- | module/srfi/srfi-41/util.scm | 29 |
3 files changed, 127 insertions, 0 deletions
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))) |