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
|
#lang racket
(provide crop-requirement
crop-requirement?
crop-requirement-id
crop-requirement-profile
crop-requirement-crop-id
(rename-out [crop-requirement-nutrient-values crop-requirement-values])
(contract-out [create-crop-requirement!
(->* (string? nutrient-value-hash/c) ((or/c #f crop?)) crop-requirement?)]
[get-crop-requirements (-> (listof crop-requirement?))]
[get-crop-requirement
(->* ()
(#:id (or/c #f exact-nonnegative-integer?) #:profile (or/c #f string?))
(or/c crop-requirement? #f))]
[get-crop-requirement-values (-> crop-requirement? nutrient-value-hash/c)]
[get-crop-requirement-value (-> crop-requirement? nutrient? number?)]
[delete-crop-requirement! (-> crop-requirement? void?)]
[average-crop-requirement-nutrient-values
(-> (listof (cons/c crop-requirement? (and/c real? (>=/c 0) (<=/c 100))))
nutrient-value-hash/c)]))
(require racket/contract
db
sql
"../db/conn.rkt"
"nutrient.rkt"
"crop.rkt")
(struct crop-requirement (id profile crop-id nutrient-values)
#:transparent
#:guard (λ (id profile crop-id nutrient-values _)
(values id profile (if (sql-null? crop-id) #f crop-id) nutrient-values)))
;; CREATE
(define (create-crop-requirement! profile nutrient-values [crop #f])
(or
(get-crop-requirement #:profile profile)
(with-tx
(query-exec
(current-conn)
(if crop
(insert #:into crop_requirements #:set [crop_id ,(crop-id crop)] [profile ,profile])
(insert #:into crop_requirements #:set [profile ,profile])))
(define cr-id
(query-value (current-conn) (select id #:from crop_requirements #:where (= profile ,profile))))
(query-exec (current-conn) (insert #:into nutrient_value_sets #:set [crop_requirement_id ,cr-id]))
(define nvs-id
(query-value (current-conn)
(select id #:from nutrient_value_sets #:where (= crop_requirement_id ,cr-id))))
(for ([(n v) (in-hash nutrient-values)])
(query-exec (current-conn)
(insert #:into nutrient_values
#:set [value_set_id ,nvs-id]
[nutrient_id ,(nutrient-id n)]
[value_ppm ,v])))
(get-crop-requirement #:profile profile))))
;; READ
(define joined
(table-expr-qq (inner-join (inner-join (inner-join (as crop_requirements cr)
(as nutrient_value_sets nvs)
#:on (= nvs.crop_requirement_id cr.id))
(as nutrient_values nv)
#:on (= nv.value_set_id nvs.id))
(as nutrients n)
#:on (= n.id nv.nutrient_id))))
(define (grouped-row->crop-requirement row)
(match-define (vector cr-id profile crop-id residuals) row)
(crop-requirement cr-id profile crop-id (residuals->nutrient-value-hash residuals)))
(define (get-crop-requirements)
(define grouped-rows
(query-rows (current-conn)
(select cr.id
cr.profile
cr.crop_id
n.id
n.canonical_name
n.formula
nv.value_ppm
#:from (TableExpr:AST ,joined)
#:order-by cr.id
#:asc)
#:group '#(0 1 2)))
(for/list ([row grouped-rows])
(grouped-row->crop-requirement row)))
(define (get-crop-requirement #:id [cr-id #f] #:profile [profile #f] #:crop-id [crop-id #f])
(define where
(cond
[(and cr-id profile crop-id)
(scalar-expr-qq (and (= cr.id ,cr-id) (= cr.profile ,profile) (= cr.crop_id ,crop-id)))]
[cr-id (scalar-expr-qq (= cr.id ,cr-id))]
[profile (scalar-expr-qq (= cr.profile ,profile))]
[crop-id (scalar-expr-qq (= cr.crop_id ,crop-id))]
[else (error 'get-crop-requirement "one of #:id, #:profile or #:crop-id must be provided")]))
(define grouped-rows
(query-rows (current-conn)
(select cr.id
cr.profile
cr.crop_id
n.id
n.canonical_name
n.formula
nv.value_ppm
#:from (TableExpr:AST ,joined)
#:where (ScalarExpr:AST ,where))
#:group '#(0 1 2)))
(match grouped-rows
['() #f]
[(list row) (grouped-row->crop-requirement row)]
[many (error 'get-crop-requirement "expected 1 crop requirement, got ~a" (length many))]))
(define (get-crop-requirement-values crop-requirement)
(for/hash ([(nutrient-id name formula value_ppm)
(in-query (current-conn)
(select n.id
n.canonical_name
n.formula
nv.value_ppm
#:from (TableExpr:AST ,joined)
#:where (= cr.id ,(crop-requirement-id crop-requirement))))])
(values (nutrient nutrient-id name formula) value_ppm)))
(define (get-crop-requirement-value crop-requirement nutrient)
(query-maybe-value (current-conn)
(select value_ppm
#:from (TableExpr:AST ,joined)
#:where (and (= cr.id ,(crop-requirement-id crop-requirement))
(= nv.nutrient_id ,(nutrient-id nutrient))))))
;; UPDATE
;; DELETE
(define (delete-crop-requirement! crop-requirement)
(define id (crop-requirement-id crop-requirement))
(query-exec (current-conn) (delete #:from crop_requirements #:where (= id ,id))))
;; Helpers
(define (average-crop-requirement-nutrient-values mix)
(for/fold ([acc (hash)]) ([pair (in-list mix)])
(match-define (cons crop-requirement percentage) pair)
(define weight (/ percentage 100))
(for/fold ([acc acc])
([(nutrient value) (in-hash (crop-requirement-nutrient-values crop-requirement))])
(define contribution (* value weight))
(hash-update acc nutrient (λ (old) (+ old contribution)) 0))))
|
