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