[Racket] Ferti hydroponic nutrient solver, redux.
1
#lang racket
2
3
(provide nutrient-measurement
4
nutrient-measurement?
5
nutrient-measurement-id
6
nutrient-measurement-value
7
(rename-out [nutrient-measurement-measurement-date nutrient-measurement-date]
8
[nutrient-measurement-nutrient-values nutrient-measurement-values])
9
(contract-out
10
[create-nutrient-measurement!
11
(case-> (-> nutrient-measurement? nutrient-measurement?)
12
(-> string? nutrient-value-hash/c nutrient-measurement?))]
13
[get-nutrient-measurements (-> (listof nutrient-measurement?))]
14
[get-nutrient-measurement (->* () (#:id db-id? #:date string?) maybe-nutrient-measurement?)]
15
[get-nutrient-measurement-values (-> nutrient-measurement-or-id/c nutrient-value-hash/c)]
16
[get-nutrient-measurement-value
17
(-> nutrient-measurement-or-id/c nutrient? maybe-nutrient-value?)]
18
[get-latest-nutrient-measurement (-> maybe-nutrient-measurement?)]
19
[get-latest-nutrient-measurement-value (-> nutrient? maybe-nutrient-value?)]
20
[get-latest-nutrient-measurement-values (-> nutrient-value-hash/c)]
21
[update-nutrient-measurement! (-> nutrient-measurement? void?)]
22
[delete-nutrient-measurement! (-> nutrient-measurement-or-id/c void?)]))
23
24
(require db
25
sql
26
"../db/conn.rkt"
27
"nutrient.rkt"
28
"nutrient-value.rkt"
29
"utils.rkt")
30
31
(struct nutrient-measurement (id measurement-date nutrient-values)
32
#:transparent
33
#:property prop:custom-write
34
(λ (v out _)
35
(fprintf out
36
"Measurement #~a on ~a\n"
37
(nutrient-measurement-id v)
38
(nutrient-measurement-measurement-date v))
39
(for ([(n v) (in-hash (nutrient-measurement-nutrient-values v))])
40
(fprintf out
41
"~a ~a\n"
42
(~a (nutrient-canonical-name n) #:min-width 14)
43
(~a v #:max-width 6 #:align 'right)))))
44
45
(define (nutrient-measurement-value nm nutrient)
46
(hash-ref (nutrient-measurement-nutrient-values nm) nutrient #f))
47
48
(define nutrient-measurement-or-id/c (or/c nutrient-measurement? db-id?))
49
(define maybe-nutrient-measurement? (or/c nutrient-measurement? #f))
50
51
(define (->nm-id nm-or-id)
52
(match nm-or-id
53
[(? db-id? id) id]
54
[(nutrient-measurement id _ _) id]))
55
56
;; CREATE
57
58
(define create-nutrient-measurement!
59
(case-lambda
60
[(nm) (create-nutrient-measurement!/nm nm)]
61
[(measurement-date nutrient-values)
62
(create-nutrient-measurement!/nm (nutrient-measurement #f measurement-date nutrient-values))]))
63
64
(define (create-nutrient-measurement!/nm nm)
65
(define measurement-date (nutrient-measurement-measurement-date nm))
66
(define nutrient-values (nutrient-measurement-nutrient-values nm))
67
(with-tx (define nm-id
68
(insert-id (query (current-conn)
69
(insert #:into nutrient_measurements
70
#:set [measurement_date ,measurement-date]))))
71
(define nvs-id
72
(insert-id (query (current-conn)
73
(insert #:into nutrient_value_sets
74
#:set [nutrient_measurement_id ,nm-id]))))
75
(insert-nutrient-values (current-conn) nvs-id nutrient-values)
76
(nutrient-measurement nm-id measurement-date nutrient-values)))
77
78
;; READ
79
80
(define joined
81
(table-expr-qq (inner-join (inner-join (inner-join (as nutrient_measurements nm)
82
(as nutrient_value_sets nvs)
83
#:on (= nvs.nutrient_measurement_id nm.id))
84
(as nutrient_values nv)
85
#:on (= nv.value_set_id nvs.id))
86
(as nutrients n)
87
#:on (= n.id nv.nutrient_id))))
88
89
(define (grouped-row->nutrient-measurement grouped-row)
90
(match-define (vector nm-id measurement-date residuals) grouped-row)
91
(nutrient-measurement nm-id measurement-date (residuals->nutrient-value-hash residuals)))
92
93
(define (get-nutrient-measurements)
94
(define grouped-rows
95
(query-rows (current-conn)
96
(select nm.id
97
nm.measurement_date
98
n.id
99
n.canonical_name
100
n.french_name
101
n.formula
102
nv.value_ppm
103
#:from (TableExpr:AST ,joined)
104
#:order-by nm.measurement_date
105
#:desc)
106
#:group '#(0 1)))
107
(map grouped-row->nutrient-measurement grouped-rows))
108
109
(define (get-nutrient-measurement #:id [nm-id #f] #:date [measurement-date #f])
110
(define where
111
(cond
112
[(and nm-id measurement-date)
113
(scalar-expr-qq (and (= nm.id ,nm-id) (= nm.measurement_date ,measurement-date)))]
114
[nm-id (scalar-expr-qq (= nm.id ,nm-id))]
115
[measurement-date (scalar-expr-qq (= nm.measurement_date ,measurement-date))]
116
[else (error 'get-nutrient-measurement "either #:id or #:date must be provided")]))
117
(define grouped-rows
118
(query-rows (current-conn)
119
(select nm.id
120
nm.measurement_date
121
n.id
122
n.canonical_name
123
n.french_name
124
n.formula
125
nv.value_ppm
126
#:from (TableExpr:AST ,joined)
127
#:where (ScalarExpr:AST ,where)
128
#:order-by nm.measurement_date
129
#:desc)
130
#:group '#(0 1)))
131
(match grouped-rows
132
['() #f]
133
[(list grouped-row) (grouped-row->nutrient-measurement grouped-row)]
134
[many (error 'get-nutrient-measurement "expected 1 nutrient measurement, got ~a" (length many))]))
135
136
(define (get-nutrient-measurement-values nm-or-id)
137
(for/hash ([(nutrient-id canonical-name french-name formula value_ppm)
138
(in-query (current-conn)
139
(select n.id
140
n.canonical_name
141
n.french_name
142
n.formula
143
nv.value_ppm
144
#:from (TableExpr:AST ,joined)
145
#:where (= nm.id ,(->nm-id nm-or-id))))])
146
(values (nutrient nutrient-id canonical-name french-name formula) value_ppm)))
147
148
(define (get-nutrient-measurement-value nm-or-id nutrient)
149
(query-maybe-value (current-conn)
150
(select value_ppm
151
#:from (TableExpr:AST ,joined)
152
#:where (and (= nm.id ,(->nm-id nm-or-id))
153
(= nv.nutrient_id ,(nutrient-id nutrient))))))
154
155
(define (get-latest-nutrient-measurement)
156
(define measurements (get-nutrient-measurements))
157
(if (null? measurements)
158
#f
159
(first measurements)))
160
161
(define (get-latest-nutrient-measurement-value nutrient)
162
(query-maybe-value (current-conn)
163
(select value_ppm
164
#:from (TableExpr:AST ,joined)
165
#:where (= nv.nutrient_id ,(nutrient-id nutrient))
166
#:order-by nm.measurement_date
167
#:desc
168
#:limit 1)))
169
170
(define (get-latest-nutrient-measurement-values)
171
(define grouped-rows
172
(query-rows (current-conn)
173
(select n.id
174
n.canonical_name
175
n.french_name
176
n.formula
177
nm.measurement_date
178
nv.value_ppm
179
#:from (TableExpr:AST ,joined)
180
#:order-by nm.measurement_date
181
#:desc)
182
#:group '(#(0 1 2 3))))
183
(for/hash ([grouped-row grouped-rows])
184
(match-define (vector n-id n-canonical-name n-french-name n-formula residual-rows) grouped-row)
185
;; residual-rows is a non-empty list of vectors: #(measurement_date value_ppm)
186
(match-define (vector _ value-ppm) (first residual-rows))
187
(values (nutrient n-id n-canonical-name n-french-name n-formula) value-ppm)))
188
189
;; UPDATE
190
191
(define (update-nutrient-measurement! nm)
192
(define id
193
(or (nutrient-measurement-id nm)
194
(raise-argument-error 'update-nutrient-measurement! "db-id?" (nutrient-measurement-id nm))))
195
(with-tx
196
(query-exec (current-conn)
197
(update nutrient_measurements
198
#:set [measurement_date ,(nutrient-measurement-measurement-date nm)]
199
#:where [= id ,id]))
200
(define nvs-id
201
(query-value (current-conn)
202
(select id #:from nutrient_value_sets #:where [= nutrient_measurement_id ,id])))
203
(update-nutrient-values! (current-conn) nvs-id (nutrient-measurement-nutrient-values nm))))
204
205
;; DELETE
206
207
(define (delete-nutrient-measurement! nm-or-id)
208
(query-exec (current-conn)
209
(delete #:from nutrient_measurements #:where (= id ,(->nm-id nm-or-id)))))
210
211
(module+ test
212
(require rackunit
213
rackunit/text-ui
214
"../db/conn.rkt"
215
"../db/migrations.rkt"
216
"../models/nutrient.rkt")
217
218
(define measurement-date "2025-09-01")
219
220
(run-tests
221
(test-suite "Nutrient measurement model"
222
#:before (λ ()
223
(connect! #:path 'memory)
224
(migrate-all!)
225
(create-nutrient! "Examplium" "Examplium" "Ex")
226
(create-nutrient! "Ignorium" "Ignorium" "Ig")
227
(create-nutrient! "Testium" "Testium" "Ts"))
228
#:after (λ () (disconnect!))
229
230
(test-case "Create measurement with date and values"
231
(define examplium (get-nutrient #:name "Examplium"))
232
(define ignorium (get-nutrient #:name "Ignorium"))
233
(create-nutrient-measurement! measurement-date (hash examplium 12.3 ignorium 4.5))
234
(check-equal? (length (get-nutrient-measurements)) 1)
235
(define nm (get-nutrient-measurement #:date measurement-date))
236
(check-true (nutrient-measurement? nm))
237
(check-equal? (nutrient-measurement-measurement-date nm) measurement-date))
238
239
(test-case "Check all measurement values"
240
(define examplium (get-nutrient #:name "Examplium"))
241
(define ignorium (get-nutrient #:name "Ignorium"))
242
243
(define nm (get-nutrient-measurement #:date measurement-date))
244
(check-equal? (get-nutrient-measurement-value nm examplium) 12.3)
245
(check-equal? (get-nutrient-measurement-value nm ignorium) 4.5)
246
247
(define nmv (nutrient-measurement-nutrient-values nm))
248
(check-equal?
249
(get-nutrient-measurement-values nm)
250
nmv
251
"return value of get-nutrient-measurement-values ≠ nutrient-measurement-values struct accessor")
252
(check-equal? (hash-count nmv) 2)
253
(check-equal? (hash-ref nmv examplium) 12.3)
254
(check-equal? (hash-ref nmv ignorium) 4.5))
255
256
(test-case "Retrieve latest measurement values"
257
(define examplium (get-nutrient #:name "Examplium"))
258
(define ignorium (get-nutrient #:name "Ignorium"))
259
(define second-measurement-date "2025-09-02")
260
(create-nutrient-measurement! second-measurement-date (hash examplium 6.7 ignorium 8.9))
261
262
(check-equal? (get-latest-nutrient-measurement-value examplium) 6.7)
263
(check-equal? (get-latest-nutrient-measurement-value ignorium) 8.9))
264
265
(test-case "Delete measurement and cascade to measurement values"
266
(define nm (get-nutrient-measurement #:date measurement-date))
267
(delete-nutrient-measurement! nm)
268
(check-false (get-nutrient-measurement #:id (nutrient-measurement-id nm)))
269
(check-equal? (length (get-nutrient-measurements))
270
1
271
"wrong number of nutrient measurements were deleted")
272
(check-true (hash-empty? (get-nutrient-measurement-values nm)))))))
273