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