diff options
Diffstat (limited to 'models/crop-requirement.rkt')
| -rw-r--r-- | models/crop-requirement.rkt | 121 |
1 files changed, 54 insertions, 67 deletions
diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt index e5f8ae6..8d99434 100644 --- a/models/crop-requirement.rkt +++ b/models/crop-requirement.rkt @@ -1,29 +1,29 @@ #lang racket -(provide - ;; Model struct - crop-requirement - crop-requirement? - crop-requirement-id crop-requirement-profile crop-requirement-crop-id - (contract-out - ;; SQL CRUD - [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?)] - [get-latest-crop-requirement-value (-> nutrient? number?)] - [delete-crop-requirement! (-> crop-requirement? void?)] - ;; Helpers - [average-crop-requirement-nutrient-values (-> (listof (cons/c crop-requirement? - (and/c real? (>=/c 0) (<=/c 100)))) - (listof nutrient-value-pair/c))])) +;; Model struct +(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 + ;; SQL CRUD + [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?)] + [get-latest-crop-requirement-value (-> nutrient? number?)] + [delete-crop-requirement! (-> crop-requirement? void?)] + ;; Helpers + [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 @@ -41,30 +41,25 @@ (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 (crop-requirement-id (get-crop-requirement #: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)))) - + (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 (crop-requirement-id (get-crop-requirement #: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 @@ -103,13 +98,12 @@ (define (get-crop-requirement-values crop-requirement) (for/list ([(nutrient-id name formula value_ppm) (in-query (current-conn) - (string-join - '("SELECT n.id, n.canonical_name, n.formula, nv.value_ppm" - "FROM nutrient_values nv" - "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" - "JOIN crop_requirements cr ON cr.id = nvs.crop_requirement_id" - "JOIN nutrients n ON n.id = nv.nutrient_id" - "WHERE cr.id = $1")) + (string-join '("SELECT n.id, n.canonical_name, n.formula, nv.value_ppm" + "FROM nutrient_values nv" + "JOIN nutrient_value_sets nvs ON nvs.id = nv.value_set_id" + "JOIN crop_requirements cr ON cr.id = nvs.crop_requirement_id" + "JOIN nutrients n ON n.id = nv.nutrient_id" + "WHERE cr.id = $1")) (crop-requirement-id crop-requirement))]) (cons (nutrient nutrient-id name formula) value_ppm))) @@ -139,28 +133,21 @@ ;; 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)))) - + (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)]) - (define crop-requirement (car pair)) - (define percentage (/ (cdr pair) 100)) - (for/fold ([acc acc]) - ([nv (in-list (get-crop-requirement-values crop-requirement))]) + (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) - (hash-update acc n - (λ (old) (+ old (* v percentage))) - (λ () (* v percentage)))))) + (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))) |