|
| 1 | +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 2 | +;; Copyright 2019 Linus Björnstam |
| 3 | +;; |
| 4 | +;; You may use this code under either the license in the SRFI document or the |
| 5 | +;; license below. |
| 6 | +;; |
| 7 | +;; Permission to use, copy, modify, and/or distribute this software for any |
| 8 | +;; purpose with or without fee is hereby granted, provided that the above |
| 9 | +;; copyright notice and this permission notice appear in all source copies. |
| 10 | +;; The software is provided "as is", without any express or implied warranties. |
| 11 | +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 12 | + |
| 13 | +;; A reduced value is stops the transduction. |
| 14 | +(define-record-type <reduced> |
| 15 | + (reduced val) |
| 16 | + reduced? |
| 17 | + (val unreduce)) |
| 18 | + |
| 19 | + |
| 20 | +;; helper function which ensures x is reduced. |
| 21 | +(define (ensure-reduced x) |
| 22 | + (if (reduced? x) |
| 23 | + x |
| 24 | + (reduced x))) |
| 25 | + |
| 26 | + |
| 27 | +;; helper function that wraps a reduced value twice since reducing functions (like list-reduce) |
| 28 | +;; unwraps them. tconcatenate is a good example: it re-uses it's reducer on it's input using list-reduce. |
| 29 | +;; If that reduction finishes early and returns a reduced value, list-reduce would "unreduce" |
| 30 | +;; that value and try to continue the transducing process. |
| 31 | +(define (preserving-reduced reducer) |
| 32 | + (lambda (a b) |
| 33 | + (let ((return (reducer a b))) |
| 34 | + (if (reduced? return) |
| 35 | + (reduced return) |
| 36 | + return)))) |
| 37 | + |
| 38 | + |
| 39 | +;; This is where the magic tofu is cooked |
| 40 | +(define (list-reduce f identity lst) |
| 41 | + (if (null? lst) |
| 42 | + identity |
| 43 | + (let ((v (f identity (car lst)))) |
| 44 | + (if (reduced? v) |
| 45 | + (unreduce v) |
| 46 | + (list-reduce f v (cdr lst)))))) |
| 47 | + |
| 48 | +(define (vector-reduce f identity vec) |
| 49 | + (let ((len (vector-length vec))) |
| 50 | + (let loop ((i 0) (acc identity)) |
| 51 | + (if (= i len) |
| 52 | + acc |
| 53 | + (let ((acc (f acc (vector-ref vec i)))) |
| 54 | + (if (reduced? acc) |
| 55 | + (unreduce acc) |
| 56 | + (loop (+ i 1) acc))))))) |
| 57 | + |
| 58 | +(define (string-reduce f identity str) |
| 59 | + (let ((len (string-length str))) |
| 60 | + (let loop ((i 0) (acc identity)) |
| 61 | + (if (= i len) |
| 62 | + acc |
| 63 | + (let ((acc (f acc (string-ref str i)))) |
| 64 | + (if (reduced? acc) |
| 65 | + (unreduce acc) |
| 66 | + (loop (+ i 1) acc))))))) |
| 67 | + |
| 68 | +(define (bytevector-u8-reduce f identity vec) |
| 69 | + (let ((len (bytevector-length vec))) |
| 70 | + (let loop ((i 0) (acc identity)) |
| 71 | + (if (= i len) |
| 72 | + acc |
| 73 | + (let ((acc (f acc (bytevector-u8-ref vec i)))) |
| 74 | + (if (reduced? acc) |
| 75 | + (unreduce acc) |
| 76 | + (loop (+ i 1) acc))))))) |
| 77 | + |
| 78 | +(define (port-reduce f identity reader port) |
| 79 | + (let loop ((val (reader port)) (acc identity)) |
| 80 | + (if (eof-object? val) |
| 81 | + acc |
| 82 | + (let ((acc (f acc val))) |
| 83 | + (if (reduced? acc) |
| 84 | + (unreduce acc) |
| 85 | + (loop (reader port) acc)))))) |
0 commit comments