-
-
Notifications
You must be signed in to change notification settings - Fork 68
/
aggregate.cljc
195 lines (170 loc) · 6.59 KB
/
aggregate.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
;;
;; Copyright © 2020 Sam Ritchie.
;; This work is based on the Scmutils system of MIT/GNU Scheme:
;; Copyright © 2002 Massachusetts Institute of Technology
;;
;; This is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3 of the License, or (at
;; your option) any later version.
;;
;; This software is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this code; if not, see <http://www.gnu.org/licenses/>.
;;
(ns sicmutils.util.aggregate
"Utilities for aggregating sequences."
(:require [sicmutils.generic :as g]))
;; I learned about "Kahan's summation trick" from `rational.scm` in the
;; `scmutils` package, where it shows up in the `sigma` function.
(defn kahan-sum
"Implements a fold that tracks the summation of a sequence of floating point
numbers, using Kahan's trick for maintaining stability in the face of
accumulating floating point errors."
([] [0.0 0.0])
([[sum c] x]
(let [y (- x c)
t (+ sum y)]
[t (- (- t sum) y)])))
(defn sum
"Sums either:
- a series `xs` of numbers, or
- the result of mapping function `f` to `(range low high)`
Using Kahan's summation trick behind the scenes to keep floating point errors
under control."
([xs]
(first
(reduce kahan-sum [0.0 0.0] xs)))
([f low high]
(sum (map f (range low high)))))
(defn scanning-sum
"Returns every intermediate summation from summing either:
- a series `xs` of numbers, or
- the result of mapping function `f` to `(range low high)`
Using Kahan's summation trick behind the scenes to keep floating point errors
under control."
([xs]
(->> (reductions kahan-sum [0.0 0.0] xs)
(map first)
(rest)))
([f low high]
(scanning-sum
(map f (range low high)))))
(defn generic-sum
"Sums either:
- a series `xs` of numbers, or
- the result of mapping function `f` to `(range low high)`
Using the generic [[sicmutils.generic/+]] function."
([xs]
(apply g/+ xs))
([f low high]
(transduce (map f) g/+ (range low high))))
(defn halt-at
"Returns a transducer that ends transduction when `pred` (applied to the
aggregation in progress) returns true for an aggregation step.
NOTE: This transducer should come first in a chain of transducers; it only
inspects the aggregate, never the value, so putting it first will prevent
unnecessary transformations of values if the aggregate signals completion."
[pred]
(fn [rf]
(fn
([] (rf))
([result]
(rf result))
([result input]
(if (pred result)
(reduced result)
(rf result input))))))
(defn- combiner
"If `stop?` is false, returns `f`. Else, returns a binary reducing function that
returns a `reduced` value if its left argument returns `true` for `stop?`,
else aggregates with `f`."
[f stop?]
(if stop?
(fn [l r]
(if (stop? l)
(reduced l)
(f l r)))
f))
(defn monoid
"Accepts a binary (associative) aggregation function `plus` and an identity
element `id` and returns a multi-arity function that will combine its
arguments via `plus`. A 0-arity call returns `id`.
optionally takes an `annihilate?` function that should return true for any `x`
such that `(plus x <any>) == x`.
If the `annihilate?` function is supplied, then if the aggregation produces a
value that returns `(annihilate? true)` at any point, the reduction will
return immediately."
([plus id]
(monoid plus id nil))
([plus id annihilate?]
(let [acc (combiner plus annihilate?)]
(fn
([] id)
([x] x)
([x y] (plus x y))
([x y & more]
(reduce acc x (cons y more)))))))
(defn group
"Similar to [[monoid]] for types with invertible elements. Accepts:
- binary `minus` and (associative) `plus` functions
- a unary `negate` function
- an element `id` that obeys `(plus id other) == (plus other id) == other`
- optionally, an `annihilate?` function that should return true for any `x`
such that `(plus x <any>) == x`.
Accepts a binary aggregation function `plus` and an identity element `id` and
returns a multi-arity function that will reduce its arguments via `plus`. A
0-arity call returns `id`.
If the `annihilate?` function is supplied, then if the aggregation produces a
value that returns `(annihilate? true)` at any point, the reduction will
return immediately."
([minus plus invert id]
(group minus plus invert id nil))
([minus plus invert id annihilate?]
(let [acc (combiner plus annihilate?)]
(fn
([] id)
([x] (invert x))
([x y] (minus x y))
([x y & more]
(minus x (reduce acc y more)))))))
(defn merge-fn
"NOTE that the returned function recurs on increasing indices internally instead
of walking through the lists directly. This method of traversing vectors is
more efficient, and this function is called so often that the performance gain
is worth it, and reads almost like the explicit sequence traversal."
[compare add zero? make]
(fn
([] [])
([xs] xs)
([xs ys]
(loop [i (long 0)
j (long 0)
result (transient [])]
(let [x (nth xs i nil)
y (nth ys j nil)]
(cond (not x) (into (persistent! result) (subvec ys j))
(not y) (into (persistent! result) (subvec xs i))
:else (let [[x-tags x-coef] x
[y-tags y-coef] y
compare-flag (compare x-tags y-tags)]
(cond
;; If the terms have the same tag set, add the coefficients
;; together. Include the term in the result only if the new
;; coefficient is non-zero.
(zero? compare-flag)
(let [sum (add x-coef y-coef)]
(recur (inc i)
(inc j)
(if (zero? sum)
result
(conj! result (make x-tags sum)))))
;; Else, pass the smaller term on unchanged and proceed.
(neg? compare-flag)
(recur (inc i) j (conj! result x))
:else
(recur i (inc j) (conj! result y))))))))))