From d2b7a6a7e2739869f8b718c80cad7c9515f10070 Mon Sep 17 00:00:00 2001 From: Marius Peter Date: Thu, 20 Nov 2025 14:08:21 +0100 Subject: Replace nutrient-value alists with hashes everywhere. --- models/crop-requirement.rkt | 53 ++++++++++++++++------------------- models/fertilizer-product.rkt | 60 +++++++++++++++++++-------------------- models/nutrient-measurement.rkt | 62 +++++++++++++++++++---------------------- models/nutrient-target.rkt | 58 ++++++++++++++++++-------------------- models/nutrient.rkt | 16 +++++++++-- 5 files changed, 122 insertions(+), 127 deletions(-) (limited to 'models') diff --git a/models/crop-requirement.rkt b/models/crop-requirement.rkt index 2048091..7d7b5aa 100644 --- a/models/crop-requirement.rkt +++ b/models/crop-requirement.rkt @@ -6,20 +6,19 @@ 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))])) + (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 @@ -50,8 +49,7 @@ (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) + (for ([(n v) (in-hash nutrient-values)]) (query-exec (current-conn) (insert #:into nutrient_values #:set [value_set_id ,nvs-id] @@ -72,8 +70,7 @@ (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)) + (crop-requirement cr-id profile crop-id (residuals->nutrient-value-hash residuals))) (define (get-crop-requirements) (define grouped-rows @@ -121,7 +118,7 @@ [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) + (for/hash ([(nutrient-id name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name @@ -129,7 +126,7 @@ nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= cr.id ,(crop-requirement-id crop-requirement))))]) - (cons (nutrient nutrient-id name formula) value_ppm))) + (values (nutrient nutrient-id name formula) value_ppm))) (define (get-crop-requirement-value crop-requirement nutrient) (query-maybe-value (current-conn) @@ -149,12 +146,10 @@ ;; 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))) + (for/fold ([acc (hash)]) ([pair (in-list mix)]) + (match-define (cons crop-requirement percentage) pair) + (define weight (/ percentage 100.0)) + (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)) (λ () contribution))))) diff --git a/models/fertilizer-product.rkt b/models/fertilizer-product.rkt index 1d6adbb..f9965c2 100644 --- a/models/fertilizer-product.rkt +++ b/models/fertilizer-product.rkt @@ -6,17 +6,17 @@ (rename-out [fertilizer-product-canonical-name fertilizer-name] [fertilizer-product-nutrient-values fertilizer-product-values] [fertilizer-product-brand-name fertilizer-brand-name]) - (contract-out - [create-fertilizer-product! - (->* (string? (listof nutrient-value-pair/c)) (string?) fertilizer-product?)] - [get-fertilizer-products (-> (listof fertilizer-product?))] - [get-fertilizer-product - (->* () - (#:id (or/c #f exact-nonnegative-integer?) #:canonical-name (or/c #f string?)) - (or/c fertilizer-product? #f))] - [get-fertilizer-product-values (-> fertilizer-product? (listof nutrient-value-pair/c))] - [get-fertilizer-product-value (-> fertilizer-product? nutrient? number?)] - [delete-fertilizer-product! (-> fertilizer-product? void?)])) + (contract-out [create-fertilizer-product! + (->* (string? nutrient-value-hash/c) (string?) fertilizer-product?)] + [get-fertilizer-products (-> (listof fertilizer-product?))] + [get-fertilizer-product + (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:canonical-name (or/c #f string?)) + (or/c fertilizer-product? #f))] + [get-fertilizer-product-values (-> fertilizer-product? nutrient-value-hash/c)] + [get-fertilizer-product-value (-> fertilizer-product? nutrient? number?)] + [delete-fertilizer-product! (-> fertilizer-product? void?)])) (require racket/contract db @@ -37,8 +37,7 @@ (fertilizer-product-canonical-name v) (fertilizer-product-brand-name v)) (fprintf out "~a\n" (fertilizer-product-canonical-name v))) - (for ([nv (in-list (fertilizer-product-nutrient-values v))]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash (fertilizer-product-nutrient-values v))]) (fprintf out "~a ~a\n" (~a (nutrient-name n) #:min-width 14) @@ -65,8 +64,7 @@ (define nvs-id (query-value (current-conn) (select id #:from nutrient_value_sets #:where (= fertilizer_product_id ,fp-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash nutrient-values)]) (query-exec (current-conn) (insert #:into nutrient_values #:set [value_set_id ,nvs-id] @@ -87,22 +85,22 @@ (define (grouped-row->fertilizer-product row) (match-define (vector fp-id canonical-name brand-name residuals) row) - (define nutrient-value-pairs (residuals->nutrient-value-pairs residuals)) - (fertilizer-product fp-id canonical-name nutrient-value-pairs brand-name)) + (fertilizer-product fp-id canonical-name (residuals->nutrient-value-hash residuals) brand-name)) (define (get-fertilizer-products) - (define grouped-rows (query-rows (current-conn) - (select fp.id - fp.canonical_name - fp.brand_name - n.id - n.canonical_name - n.formula - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:order-by fp.canonical_name - #:asc) - #:group '#(0 1 2))) + (define grouped-rows + (query-rows (current-conn) + (select fp.id + fp.canonical_name + fp.brand_name + n.id + n.canonical_name + n.formula + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:order-by fp.canonical_name + #:asc) + #:group '#(0 1 2))) (for/list ([row grouped-rows]) (grouped-row->fertilizer-product row))) @@ -134,7 +132,7 @@ [many (error 'get-fertilizer-product "expected 1 fertilizer product, got ~a" (length many))])) (define (get-fertilizer-product-values fertilizer-product) - (for/list ([(nutrient-id name formula value_ppm) + (for/hash ([(nutrient-id name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name @@ -142,7 +140,7 @@ nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= fp.id ,(fertilizer-product-id fertilizer-product))))]) - (cons (nutrient nutrient-id name formula) value_ppm))) + (values (nutrient nutrient-id name formula) value_ppm))) (define (get-fertilizer-product-value fertilizer-product nutrient) (query-maybe-value (current-conn) diff --git a/models/nutrient-measurement.rkt b/models/nutrient-measurement.rkt index 199208f..fa1171c 100644 --- a/models/nutrient-measurement.rkt +++ b/models/nutrient-measurement.rkt @@ -6,14 +6,13 @@ (rename-out [nutrient-measurement-measured-on nutrient-measurement-date] [nutrient-measurement-nutrient-values nutrient-measurement-values]) (contract-out - [create-nutrient-measurement! - (-> string? (listof nutrient-value-pair/c) nutrient-measurement?)] + [create-nutrient-measurement! (-> string? nutrient-value-hash/c nutrient-measurement?)] [get-nutrient-measurements (-> (listof nutrient-measurement?))] [get-nutrient-measurement (->* () (#:id (or/c #f exact-nonnegative-integer?) #:measured-on (or/c #f string?)) (or/c nutrient-measurement? #f))] - [get-nutrient-measurement-values (-> nutrient-measurement? (listof nutrient-value-pair/c))] + [get-nutrient-measurement-values (-> nutrient-measurement? nutrient-value-hash/c)] [get-nutrient-measurement-value (-> nutrient-measurement? nutrient? number?)] [get-latest-nutrient-measurement-value (-> nutrient? (or/c number? #f))] [get-latest-nutrient-measurement-hash (-> (hash/c nutrient? number?))] @@ -33,8 +32,7 @@ "Measurement #~a on ~a\n" (nutrient-measurement-id v) (nutrient-measurement-measured-on v)) - (for ([nv (nutrient-measurement-nutrient-values v)]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash (nutrient-measurement-nutrient-values v))]) (fprintf out "~a ~a\n" (~a (nutrient-name n) #:min-width 14) @@ -55,8 +53,7 @@ (define nvs-id (query-value (current-conn) (select id #:from nutrient_value_sets #:where (= nutrient_measurement_id ,nm-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash nutrient-values)]) (query-exec (current-conn) (insert #:into nutrient_values #:set [value_set_id ,nvs-id] @@ -77,21 +74,21 @@ (define (grouped-row->nutrient-measurement row) (match-define (vector nm-id measured-on residuals) row) - (define nutrient-value-pairs (residuals->nutrient-value-pairs residuals)) - (nutrient-measurement nm-id measured-on nutrient-value-pairs)) + (nutrient-measurement nm-id measured-on (residuals->nutrient-value-hash residuals))) (define (get-nutrient-measurements) - (define grouped-rows (query-rows (current-conn) - (select nm.id - nm.measured_on - n.id - n.canonical_name - n.formula - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:order-by nm.measured_on - #:desc) - #:group '#(0 1))) + (define grouped-rows + (query-rows (current-conn) + (select nm.id + nm.measured_on + n.id + n.canonical_name + n.formula + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:order-by nm.measured_on + #:desc) + #:group '#(0 1))) (for/list ([row grouped-rows]) (grouped-row->nutrient-measurement row))) @@ -122,7 +119,7 @@ [many (error 'get-nutrient-measurement "expected 1 nutrient measurement, got ~a" (length many))])) (define (get-nutrient-measurement-values nutrient-measurement) - (for/list ([(nutrient-id name formula value_ppm) + (for/hash ([(nutrient-id name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name @@ -130,7 +127,7 @@ nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= nm.id ,(nutrient-measurement-id nutrient-measurement))))]) - (cons (nutrient nutrient-id name formula) value_ppm))) + (values (nutrient nutrient-id name formula) value_ppm))) (define (get-nutrient-measurement-value nutrient-measurement nutrient) (query-maybe-value (current-conn) @@ -149,17 +146,16 @@ #:limit 1))) (define (get-latest-nutrient-measurement-hash) - (for/hash ([(n-id n-name n-formula residual-rows) - (in-query (current-conn) - (select n.id - n.canonical_name - n.formula - nm.measured_on - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:order-by nm.measured_on - #:desc) - #:group '(#(0 1 2)))]) + (for/hash ([(n-id n-name n-formula residual-rows) (in-query (current-conn) + (select n.id + n.canonical_name + n.formula + nm.measured_on + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:order-by nm.measured_on + #:desc) + #:group '(#(0 1 2)))]) ;; residual-rows is a non-empty list of vectors: #(measured_on value_ppm) (match-define (vector _measured-on value-ppm) (first residual-rows)) (values (nutrient n-id n-name n-formula) value-ppm))) diff --git a/models/nutrient-target.rkt b/models/nutrient-target.rkt index 261fce0..a19ca6a 100644 --- a/models/nutrient-target.rkt +++ b/models/nutrient-target.rkt @@ -5,18 +5,18 @@ nutrient-target-id (rename-out [nutrient-target-effective-on nutrient-target-date] [nutrient-target-nutrient-values nutrient-target-values]) - (contract-out - [create-nutrient-target! (-> string? (listof nutrient-value-pair/c) nutrient-target?)] - [get-nutrient-targets (-> (listof nutrient-target?))] - [get-nutrient-target - (->* () - (#:id (or/c #f exact-nonnegative-integer?) #:effective-on (or/c #f string?)) - (or/c nutrient-target? #f))] - [get-nutrient-target-values (-> nutrient-target? (listof nutrient-value-pair/c))] - [get-nutrient-target-value (-> nutrient-target? nutrient? number?)] - [get-latest-nutrient-target-value (-> nutrient? (or/c number? #f))] - [get-latest-nutrient-target-hash (-> (hash/c nutrient? number?))] - [delete-nutrient-target! (-> nutrient-target? void?)])) + (contract-out [create-nutrient-target! (-> string? nutrient-value-hash/c nutrient-target?)] + [get-nutrient-targets (-> (listof nutrient-target?))] + [get-nutrient-target + (->* () + (#:id (or/c #f exact-nonnegative-integer?) + #:effective-on (or/c #f string?)) + (or/c nutrient-target? #f))] + [get-nutrient-target-values (-> nutrient-target? nutrient-value-hash/c)] + [get-nutrient-target-value (-> nutrient-target? nutrient? number?)] + [get-latest-nutrient-target-value (-> nutrient? (or/c number? #f))] + [get-latest-nutrient-target-hash (-> (hash/c nutrient? number?))] + [delete-nutrient-target! (-> nutrient-target? void?)])) (require racket/contract db @@ -29,8 +29,7 @@ #:property prop:custom-write (λ (v out _) (fprintf out "Target #~a on ~a\n" (nutrient-target-id v) (nutrient-target-effective-on v)) - (for ([nv (nutrient-target-nutrient-values v)]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash (nutrient-target-nutrient-values v))]) (fprintf out "~a ~a\n" (~a (nutrient-name n) #:min-width 14) @@ -50,8 +49,7 @@ (define nvs-id (query-value (current-conn) (select id #:from nutrient_value_sets #:where (= nutrient_target_id ,nt-id)))) - (for ([nv nutrient-values]) - (match-define (cons n v) nv) + (for ([(n v) (in-hash nutrient-values)]) (query-exec (current-conn) (insert #:into nutrient_values #:set [value_set_id ,nvs-id] @@ -72,8 +70,7 @@ (define (grouped-row->nutrient-target row) (match-define (vector nt-id effective-on residuals) row) - (define nutrient-value-pairs (residuals->nutrient-value-pairs residuals)) - (nutrient-target nt-id effective-on nutrient-value-pairs)) + (nutrient-target nt-id effective-on (residuals->nutrient-value-hash residuals))) (define (get-nutrient-targets) (for/list ([grouped-row (in-query (current-conn) @@ -116,7 +113,7 @@ [many (error 'get-nutrient-target "expected 1 nutrient target, got ~a" (length many))])) (define (get-nutrient-target-values nutrient-target) - (for/list ([(nutrient-id name formula value_ppm) + (for/hash ([(nutrient-id name formula value_ppm) (in-query (current-conn) (select n.id n.canonical_name @@ -124,7 +121,7 @@ nv.value_ppm #:from (TableExpr:AST ,joined) #:where (= nt.id ,(nutrient-target-id nutrient-target))))]) - (cons (nutrient nutrient-id name formula) value_ppm))) + (values (nutrient nutrient-id name formula) value_ppm))) (define (get-nutrient-target-value nutrient-target nutrient) (query-maybe-value (current-conn) @@ -143,17 +140,16 @@ #:limit 1))) (define (get-latest-nutrient-target-hash) - (for/hash ([(n-id n-name n-formula residual-rows) - (in-query (current-conn) - (select n.id - n.canonical_name - n.formula - nt.effective_on - nv.value_ppm - #:from (TableExpr:AST ,joined) - #:order-by nt.effective_on - #:desc) - #:group '(#(0 1 2)))]) + (for/hash ([(n-id n-name n-formula residual-rows) (in-query (current-conn) + (select n.id + n.canonical_name + n.formula + nt.effective_on + nv.value_ppm + #:from (TableExpr:AST ,joined) + #:order-by nt.effective_on + #:desc) + #:group '(#(0 1 2)))]) ;; residual-rows is a non-empty list of vectors: #(effective_on value_ppm) (match-define (vector _effective-on value-ppm) (first residual-rows)) (values (nutrient n-id n-name n-formula) value-ppm))) diff --git a/models/nutrient.rkt b/models/nutrient.rkt index 91be68f..d79801f 100644 --- a/models/nutrient.rkt +++ b/models/nutrient.rkt @@ -5,7 +5,7 @@ nutrient-id nutrient-name nutrient-formula - nutrient-value-pair/c + nutrient-value-hash/c (contract-out [create-nutrient! (-> string? string? nutrient?)] [get-nutrients (-> (listof nutrient?))] [get-nutrient @@ -18,7 +18,9 @@ (->* (nutrient?) (#:name (or/c #f string?) #:formula (or/c #f string?)) (or/c nutrient? #f))] - [delete-nutrient! (-> nutrient? void?)])) + [delete-nutrient! (-> nutrient? void?)] + [residuals->nutrient-value-hash + (-> (listof residual-vector/c) nutrient-value-hash/c)])) (require racket/contract db @@ -30,7 +32,15 @@ #:property prop:custom-write (λ (v out _) (fprintf out "#<~a ~a>" (nutrient-id v) (nutrient-name v)))) -(define nutrient-value-pair/c (cons/c nutrient? (and/c real? (>=/c 0)))) +(define nutrient-value-hash/c (hash/c nutrient? (and/c real? (>=/c 0)) #:immutable #t)) + +;; vector/c id, nutrient name, nutrient formula, value (ppm) +(define residual-vector/c (vector/c exact-nonnegative-integer? string? string? real?)) + +(define (residuals->nutrient-value-hash residuals) + (for/hash ([r (in-list residuals)]) + (match-define (vector n-id n-name n-formula value-ppm) r) + (values (nutrient n-id n-name n-formula) value-ppm))) ;; CREATE -- cgit v1.2.3