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
|
#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? (listof nutrient-value-pair/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? (listof nutrient-value-pair/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))))
(listof nutrient-value-pair/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 ([nv nutrient-values])
(match-define (cons n v) nv)
(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)
(define nutrient-value-pairs (residuals->nutrient-value-pairs residuals))
(crop-requirement cr-id profile crop-id nutrient-value-pairs))
(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/list ([(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))))])
(cons (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)
(define average-values
(for/fold ([acc (hash)]) ([pair (in-list mix)])
(match-define (cons crop-requirement percentage) pair)
(for/fold ([acc acc]) ([nv (in-list (get-crop-requirement-values crop-requirement))])
(match-define (cons n v) nv)
(define nutrient-contribution (* v (/ percentage 100)))
(hash-update acc n (λ (old) (+ old nutrient-contribution)) (λ () nutrient-contribution)))))
(for/list ([(n v) (in-hash average-values)])
(cons n v)))
|
