diff options
Diffstat (limited to 'models/crop-rotation.rkt')
| -rw-r--r-- | models/crop-rotation.rkt | 138 |
1 files changed, 138 insertions, 0 deletions
diff --git a/models/crop-rotation.rkt b/models/crop-rotation.rkt new file mode 100644 index 0000000..abff080 --- /dev/null +++ b/models/crop-rotation.rkt @@ -0,0 +1,138 @@ +#lang racket + +(provide crop-rotation + crop-rotation? + crop-rotation-id + (rename-out [crop-rotation-rotation-date crop-rotation-date] + [crop-rotation-requirement-proportions crop-rotation-requirements] + [crop-rotation-nutrient-measurement-id crop-rotation-measurement-id]) + (contract-out [create-crop-rotation! + (->* (string? requirement-proportion-hash/c) + (#:nutrient-measurement exact-nonnegative-integer?) + crop-rotation?)] + [get-crop-rotations (-> (listof crop-rotation?))] + [get-crop-rotation + (->* () (#:id crop-rotation-id? #:date string?) (or/c crop-rotation? #f))] + [get-latest-crop-rotation (-> (or/c crop-rotation? #f))] + [delete-crop-rotation! (-> crop-rotation-or-id/c void?)])) + +(require racket/contract + db + sql + "../db/conn.rkt" + "nutrient.rkt" + "crop-requirement.rkt") + +(struct crop-rotation (id rotation-date requirement-proportions nutrient-measurement-id) + #:transparent + #:guard (λ (id rotation-date requirement-proportions nutrient-measurement-id _) + (values id + rotation-date + requirement-proportions + (if (sql-null? nutrient-measurement-id) #f nutrient-measurement-id)))) + +(define crop-rotation-id? exact-nonnegative-integer?) +(define crop-rotation-or-id/c (or/c crop-rotation? crop-rotation-id?)) +(define requirement-proportion-hash/c (hash/c crop-requirement? (between/c 0 100) #:immutable #t)) + +(define (->cr-id cr-or-id) + (match cr-or-id + [(? crop-rotation-id? id) id] + [(crop-rotation id _ _ _) id] + [#f (error '->nt-id "#f can not be converted to an id")])) + +;; CREATE + +(define (create-crop-rotation! rotation-date + requirement-proportions + #:nutrient-measurement [nutrient-measurement-id #f]) + (or (get-crop-rotation #:date rotation-date) + (with-tx + (if nutrient-measurement-id + (query-exec (current-conn) + (insert #:into crop_rotations + #:set [rotation_date ,rotation-date] + [nutrient_measurement_id ,nutrient-measurement-id])) + (query-exec (current-conn) + (insert #:into crop_rotations #:set [rotation_date ,rotation-date]))) + (define cr-id + (query-value (current-conn) + (select id #:from crop_rotations #:where (= rotation_date ,rotation-date)))) + (for ([(r p) (in-hash requirement-proportions)]) + (query-exec (current-conn) + (insert #:into crop_rotation_requirements + #:set [crop_rotation_id ,cr-id] + [crop_requirement_id ,(crop-requirement-id r)] + [proportion_percent ,p]))) + (get-crop-rotation #:date rotation-date)))) + +;; READ + +(define joined + (table-expr-qq (inner-join (as crop_rotations cr) + (as crop_rotation_requirements crr) + #:on (= crr.crop_rotation_id cr.id)))) + +(define (residuals->requirement-proportion-hash residuals) + (for/hash ([r (in-list residuals)]) + (match-define (vector requirement-id proportion) r) + (values requirement-id proportion))) + +(define (grouped-row->crop-rotation grouped-row) + (match-define (vector cr-id cr-rotation-date cr-nutrient-measurement-id residuals) grouped-row) + (crop-rotation cr-id + cr-rotation-date + (residuals->requirement-proportion-hash residuals) + cr-nutrient-measurement-id)) + +(define (get-crop-rotations) + (define grouped-rows + (query-rows (current-conn) + (select cr.id + cr.rotation_date + cr.nutrient_measurement_id + crr.crop_requirement_id + crr.proportion_percent + #:from (TableExpr:AST ,joined) + #:order-by cr.rotation_date + #:desc) + #:group '#(0 1 2))) + (map grouped-row->crop-rotation grouped-rows)) + +(define (get-crop-rotation #:id [cr-id #f] #:date [rotation-date #f]) + (define where + (cond + [(and cr-id rotation-date) + (scalar-expr-qq (and (= cr.id ,cr-id) (= cr.rotation_date ,rotation-date)))] + [cr-id (scalar-expr-qq (= cr.id ,cr-id))] + [rotation-date (scalar-expr-qq (= cr.rotation_date ,rotation-date))] + [else (error 'get-crop-rotation "either #:id or #:date must be provided")])) + (define grouped-rows + (query-rows (current-conn) + (select cr.id + cr.rotation_date + cr.nutrient_measurement_id + crr.crop_requirement_id + crr.proportion_percent + #:from (TableExpr:AST ,joined) + #:where (ScalarExpr:AST ,where) + #:order-by cr.rotation_date + #:desc) + #:group '#(0 1 2))) + (match grouped-rows + ['() #f] + [(list grouped-row) (grouped-row->crop-rotation grouped-row)] + [many (error 'get-crop-rotation "expected 1 nutrient target, got ~a" (length many))])) + +(define (get-latest-crop-rotation) + (define rotations (get-crop-rotations)) + (if (null? rotations) + #f + (first rotations))) + +;; UPDATE + +;; DELETE + +(define (delete-crop-rotation! cr-or-id) + (query-exec (current-conn) (delete #:from crop_rotations #:where (= id ,(->cr-id cr-or-id))))) |