Introduce crop rotations.

These will probably replace nutrient targets as the main entry point
for nutrient requirement calculations.

5 files changed, 238 insertions, 51 deletions

diff --git a/db/migrations.rkt b/db/migrations.rkt
index dfb216e..86c9cce 100644
--- a/db/migrations.rkt
+++ b/db/migrations.rkt
@@ -143,6 +143,30 @@
                      #:constraints (primary-key id)
                      (foreign-key crop_id #:references (crops id) #:on-delete #:cascade))))
 
+(define-migration "create table crop_rotations"
+                  (list (create-table #:if-not-exists crop_rotations
+                                      #:columns [id integer #:not-null]
+                                      ;; ISO8601 date
+                                      [rotation_date text #:not-null]
+                                      [nutrient_measurement_id integer]
+                                      #:constraints (primary-key id)
+                                      (foreign-key nutrient_measurement_id
+                                                   #:references (nutrient_measurements id)
+                                                   #:on-delete
+                                                   #:set-null)
+                                      (unique rotation_date))))
+
+(define-migration
+ "create table crop_rotation_requirements"
+ (list (create-table
+        #:if-not-exists crop_rotation_requirements
+        #:columns [crop_rotation_id integer #:not-null]
+        [crop_requirement_id integer #:not-null]
+        [proportion_percent integer #:not-null]
+        #:constraints (primary-key crop_rotation_id crop_requirement_id)
+        (foreign-key crop_rotation_id #:references (crop_rotation id) #:on-delete #:cascade)
+        (foreign-key crop_requirement_id #:references (crop_requirement id) #:on-delete #:cascade))))
+
 ;;;;;;;;;;;;;;
 ;; FERTILIZERS
 ;;;;;;;;;;;;;;
diff --git a/db/seed.rkt b/db/seed.rkt
index d767d63..8d671ba 100644
--- a/db/seed.rkt
+++ b/db/seed.rkt
@@ -9,6 +9,7 @@
          "../models/nutrient-measurement.rkt"
          "../models/crop.rkt"
          "../models/crop-requirement.rkt"
+         "../models/crop-rotation.rkt"
          "../models/fertilizer-product.rkt")
 
 (define (seed-database!)
@@ -20,6 +21,7 @@
         seed-historical-nutrient-measurements!
         seed-crops!
         seed-crop-requirements!
+        seed-initial-crop-rotation!
         seed-existing-fertilizer-products!))
 
 (define (seed-nutrients!)
@@ -90,6 +92,13 @@
       [else (create-crop-requirement! profile nutrient-values)]))
   (with-tx (csv-for-each row->seed! next-row)))
 
+(define (seed-initial-crop-rotation!)
+  (define nm (get-latest-nutrient-measurement))
+  (define generic-requirement (get-crop-requirement #:profile "générique croissance"))
+  (create-crop-rotation! (nutrient-measurement-date nm)
+                         (hash generic-requirement 100)
+                         #:nutrient-measurement (nutrient-measurement-id nm)))
+
 (define-runtime-path fertilizer-products-csv "data/dolibarr_fertilizer_compositions_percentage.csv")
 (define (seed-existing-fertilizer-products!)
   (define next-row (make-csv-reader (open-input-file fertilizer-products-csv)))
diff --git a/handlers.rkt b/handlers.rkt
index a232e56..6141426 100644
--- a/handlers.rkt
+++ b/handlers.rkt
@@ -13,6 +13,7 @@
          "models/nutrient.rkt"
          "models/nutrient-measurement.rkt"
          "models/nutrient-target.rkt"
+         "models/crop-rotation.rkt"
          "models/fertilizer-product.rkt"
          "services/nnls.rkt")
 
@@ -47,31 +48,31 @@
             void))
 
 (define-values (fapg-dispatch fapg-url)
-  (dispatch-rules [("index") #:method "get" index]
-                  ;; Ferti
-                  [("ferti" "index") #:method "get" ferti-index]
-                  [("ferti" "measurements") #:method "get" ferti-measurements]
-                  [("ferti" "targets") #:method "get" ferti-targets]
-                  [("ferti" "recipe") #:method "get" ferti-recipe]
-                  [("ferti" "fertilizers") #:method "get" ferti-fertilizers]
-                  ;; Nutrient measurements
-                  [("ferti" "measurement" "new") #:method "get" new-measurement]
-                  [("ferti" "measurement" "create") #:method "post" create-measurement]
-                  [("ferti" "measurement" (integer-arg)) #:method "get" show-measurement]
-                  [("ferti" "measurement" (integer-arg)) #:method "delete" destroy-measurement]
-                  ;; Nutrient targets
-                  [("ferti" "target" "new") #:method "get" new-target]
-                  [("ferti" "target" "create") #:method "post" create-target]
-                  [("ferti" "target" (integer-arg)) #:method "get" show-target]
-                  [("ferti" "target" (integer-arg)) #:method "delete" destroy-target]
-                  ;; Fertilizer products
-                  [("ferti" "fertilizer" "new") #:method "get" new-fertilizer]
-                  [("ferti" "fertilizer" "create") #:method "post" create-fertilizer]
-                  [("ferti" "fertilizer" (integer-arg)) #:method "get" show-fertilizer]
-                  [("ferti" "fertilizer" "destroy" (integer-arg)) #:method "get" destroy-fertilizer]
-                  ;; Default
-                  [("") #:method "get" index]
-                  [else fallback]))
+  (dispatch-rules
+   [("index") #:method "get" index]
+   ;; Ferti
+   [("ferti" "index") #:method "get" ferti-index]
+   [("ferti" "measurements-and-rotations") #:method "get" ferti-measurements-and-rotations]
+   [("ferti" "recipe") #:method "get" ferti-recipe]
+   [("ferti" "fertilizers") #:method "get" ferti-fertilizers]
+   ;; Nutrient measurements
+   [("ferti" "measurement" "new") #:method "get" new-measurement]
+   [("ferti" "measurement" "create") #:method "post" create-measurement]
+   [("ferti" "measurement" (integer-arg)) #:method "get" show-measurement]
+   [("ferti" "measurement" (integer-arg)) #:method "delete" destroy-measurement]
+   ;; Nutrient targets
+   [("ferti" "target" "new") #:method "get" new-target]
+   [("ferti" "target" "create") #:method "post" create-target]
+   [("ferti" "target" (integer-arg)) #:method "get" show-target]
+   [("ferti" "target" (integer-arg)) #:method "delete" destroy-target]
+   ;; Fertilizer products
+   [("ferti" "fertilizer" "new") #:method "get" new-fertilizer]
+   [("ferti" "fertilizer" "create") #:method "post" create-fertilizer]
+   [("ferti" "fertilizer" (integer-arg)) #:method "get" show-fertilizer]
+   [("ferti" "fertilizer" "destroy" (integer-arg)) #:method "get" destroy-fertilizer]
+   ;; Default
+   [("") #:method "get" index]
+   [else fallback]))
 
 (define (render-page xexpr)
   (response/xexpr #:preamble #"<!DOCTYPE html>" xexpr))
@@ -87,15 +88,11 @@
 (define (ferti-index _)
   (render-page (ferti-index-page)))
 
-(define (ferti-measurements _)
+(define (ferti-measurements-and-rotations _)
   (define nutrients (get-nutrients))
   (define measurements (get-nutrient-measurements))
-  (render-page (ferti-measurements-page nutrients measurements)))
-
-(define (ferti-targets _)
-  (define latest-measurement-hash (get-latest-nutrient-measurement-hash))
-  (define latest-target-hash (get-latest-nutrient-target-hash))
-  (render-page (ferti-targets-page latest-measurement-hash latest-target-hash)))
+  (define rotations (get-crop-rotations))
+  (render-page (ferti-measurements-and-rotations-page nutrients measurements rotations)))
 
 (define (ferti-recipe _)
   (define ferti-recipe (find-ferti-recipe))
@@ -113,7 +110,7 @@
 (define (create-measurement req)
   (define-values (measurement-date nutrient-values) (formlet-process (measurements-formlet) req))
   (create-nutrient-measurement! measurement-date nutrient-values)
-  (redirect-to "/ferti/measurements"))
+  (redirect-to "/ferti/measurements-and-rotations"))
 
 (define (show-measurement _ id)
   (define nm (get-nutrient-measurement #:id id))
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)))))
diff --git a/views.rkt b/views.rkt
index 933594e..a7e9f1f 100644
--- a/views.rkt
+++ b/views.rkt
@@ -2,8 +2,7 @@
 
 (provide index-page
          ferti-index-page
-         ferti-measurements-page
-         ferti-targets-page
+         ferti-measurements-and-rotations-page
          ferti-recipe-page
          ferti-fertilizers-page
          new-measurement-page
@@ -21,6 +20,7 @@
          "models/nutrient.rkt"
          "models/nutrient-measurement.rkt"
          "models/nutrient-target.rkt"
+         "models/crop-rotation.rkt"
          "models/fertilizer-product.rkt")
 
 (define (page-template title body-xexpr)
@@ -83,13 +83,12 @@
        (li ((class "nav-item"))
            (a ((class "nav-link") (aria-current "page") (href "/ferti/index")) "Accueil"))
        (li ((class "nav-item"))
-           (a ((class "nav-link") (aria-current "page") (href "/ferti/measurements")) "Relevés"))
-       (li ((class "nav-item"))
-           (a ((class "nav-link") (aria-current "page") (href "/ferti/targets")) "Cibles"))
+           (a ((class "nav-link") (aria-current "page") (href "/ferti/measurements-and-rotations"))
+              "Relevés & Cibles"))
        (li ((class "nav-item"))
            (a ((class "nav-link") (aria-current "page") (href "/ferti/fertilizers")) "Intrants"))
-       (li ((class "nav-item"))
-           (a ((class "nav-link") (aria-current "page") (href "/ferti/recipe")) "Recette Ferti©"))))
+       #;(li ((class "nav-item"))
+             (a ((class "nav-link") (aria-current "page") (href "/ferti/recipe")) "Recette Ferti©"))))
 
 (define (ferti-index-page)
   (ferti-template
@@ -100,19 +99,39 @@
           (a ((class "btn btn-outline-primary") [href "/ferti/fertilizer/new"])
              "Ajouter un intrant")))))
 
-(define (ferti-measurements-page nutrients measurements)
+(define (ferti-measurements-and-rotations-page nutrients measurements rotations)
+  (define (maybe-rotation-for-measurement m)
+    (findf (λ (r) (= (crop-rotation-measurement-id r) (nutrient-measurement-id m))) rotations))
   (define table
-    `(table ((class "table"))
-            (thead (tr (th "Date")))
-            (tbody ,@(for/list ([m measurements])
-                       `(tr (td (a ((href ,(format "/ferti/measurement/~a"
-                                                   (nutrient-measurement-id m))))
-                                   ,(nutrient-measurement-date m))))))))
-  (ferti-template `((h2 () "Relevés") (a ((class "btn btn-primary mb-3") [href
-                                                                          "/ferti/measurement/new"])
-                                         "Ajouter un relevé")
-                                      ,table)))
+    `(table
+      ((class "table"))
+      (thead (tr (th "Date du relevé") (th "Relevé") (th "Cultures") (th "Recette")))
+      (tbody
+       ,@(for/list ([m measurements])
+           (define maybe-rotation (maybe-rotation-for-measurement m))
+           `(tr (td ,(nutrient-measurement-date m))
+                (td (a ((class "btn btn-outline-secondary")
+                        (href ,(format "/ferti/measurement/~a" (nutrient-measurement-id m))))
+                       "Modifier"))
+                (td ,(if maybe-rotation
+                         `(a ((class "btn btn-outline-secondary")
+                              (href ,(format "/ferti/rotation/~a" (crop-rotation-id maybe-rotation))))
+                             "Modifier")
+                         `(a ((class "btn btn-outline-primary") (href "/ferti/rotation/new"))
+                             "Ajouter")))
+                (td ,(if maybe-rotation
+                         `(a ((class "btn btn-outline-secondary")
+                              (href ,(format "/ferti/recipe/~a" (crop-rotation-date maybe-rotation))))
+                             "Consulter")
+                         "—")))))))
+  (ferti-template
+   `((h2 () "Relevés")
+     (div ((class "btn-group mb-3"))
+          (a ((class "btn btn-primary") [href "/ferti/measurement/new"]) "Ajouter un relevé")
+          #;(a ((class "btn btn-secondary") [href "/ferti/target/new"]) "Créer une cible"))
+     ,table)))
 
+#;
 (define (ferti-targets-page latest-measurement-hash latest-target-hash)
   (define table
     `(table ((class "table"))